Incremental parsing with parsec

nshepperd 2018-04-23 02:52:46.271129 UTC

1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE OverloadedStrings #-}
5
6import Control.Monad
7import Data.Foldable
8import Data.Monoid
9import Data.Text (Text)
10import qualified Data.Text as T
11import qualified Data.Text.Lazy as TL
12import Text.Parsec (Stream(..), SourceName, ParseError, ParsecT, runParserT)
13import Text.Parser.Char
14
15
16newtype Inc = Inc Text
17
18data Step a = Yield (Text -> Step a)
19 | Done a
20 deriving (Functor)
21
22instance Show a => Show (Step a) where
23 showsPrec n (Done a) = showString "Done " . showsPrec 11 a
24 showsPrec n (Yield f) = showString "Yield <func>"
25
26instance Applicative Step where
27 pure = return
28 (<*>) = ap
29
30instance Monad Step where
31 return = Done
32 Done a >>= k = k a
33 Yield f >>= k = Yield (f >=> k)
34
35instance Stream Inc Step Char where
36 uncons (Inc buffer) = case T.uncons buffer of
37 Just (c, rest) -> Done (Just (c, Inc rest))
38 Nothing -> Yield (\buf -> case T.null buf of
39 True -> return Nothing
40 False -> uncons (Inc buf))
41
42parseIncremental :: ParsecT Inc () Step a -> SourceName -> Step (Either ParseError a)
43parseIncremental p sname = runParserT p () sname (Inc mempty)
44
45parseLazy :: ParsecT Inc () Step a -> SourceName -> TL.Text -> Either ParseError a
46parseLazy p sname text = go (parseIncremental p sname) (TL.toChunks text)
47 where
48 go (Done a) _ = a
49 go (Yield f) [] = case f mempty of Done a -> a
50 go (Yield f) (t:ts) = go (f t) ts
51
52-- Examples
53huge :: () -> TL.Text
54huge () = fold (repeat "1")
55
56parseOnes :: (Monad m, CharParsing m) => Int -> m Int
57parseOnes = go 0
58 where
59 go !acc 0 = return acc
60 go !acc n = do char '1'
61 go (acc + 1) (n - 1)