@@ -0,0 +1,204 @@
1+-----------------------------------------------------------------------------
2+-- |
3+-- Module : Data.ParserCombinators.Attoparsec.Incremental
4+-- Copyright : Bryan O'Sullivan 2009
5+-- License : BSD3
6+--
7+-- Maintainer : bos@serpentine.com
8+-- Stability : experimental
9+-- Portability : unknown
10+--
11+-- Simple, efficient parser combinators for lazy 'LB.ByteString'
12+-- strings, loosely based on 'Text.ParserCombinators.Parsec'.
13+--
14+-- Heavily influenced by Adam Langley's incremental parser in the
15+-- binary-strict package.
16+--
17+-----------------------------------------------------------------------------
18+module Data.ParserCombinators.Attoparsec.Incremental
19+ (
20+ Parser
21+ , Result(..)
22+ , parse
23+
24+ , takeWhile
25+ , takeTill
26+ , string
27+
28+ , yield
29+ ) where
30+
31+import Control.Applicative (Alternative(..), Applicative(..))
32+import Control.Monad (MonadPlus(..), ap)
33+import Data.ParserCombinators.Attoparsec.Internal ((+:))
34+import Data.Word (Word8)
35+import qualified Data.ByteString as S
36+import qualified Data.ByteString.Lazy as L
37+import qualified Data.ByteString.Lazy.Internal as L
38+import Prelude hiding (takeWhile)
39+
40+data S = S {-# UNPACK #-} !S.ByteString -- ^ first chunk of input
41+ L.ByteString -- ^ rest of input
42+ [S.ByteString] -- ^ input acquired during backtracks
43+ {-# UNPACK #-} !Int -- ^ failure depth
44+
45+-- | The result of a partial parse
46+data Result a = Failed String
47+ -- ^ the parse failed with the given error message
48+ | Done L.ByteString a
49+ -- ^ the parse finished and produced the given list of
50+ -- results doing so. Any unparsed data is returned.
51+ | Partial (S.ByteString -> Result a)
52+ -- ^ the parse ran out of data before finishing, but produced
53+ -- the given list of results before doing so. To continue the
54+ -- parse pass more data to the given continuation
55+
56+instance (Show a) => Show (Result a) where
57+ show (Failed err) = "Failed " ++ err
58+ show (Done rest rs) = "Done " ++ show rest ++ " " ++ show rs
59+ show (Partial _) = "Partial"
60+
61+-- | This is the internal version of the above. This is the type which is
62+-- actually used by the code, as it has the extra information needed
63+-- for backtracking. This is converted to an external friendly @Result@
64+-- type just before giving it to the outside world.
65+data IResult a = IFailed S String
66+ | IDone S a
67+ | IPartial (S.ByteString -> IResult a)
68+
69+instance Show (IResult a) where
70+ show (IFailed _ err) = "IFailed " ++ err
71+ show (IDone _ _) = "IDone"
72+ show (IPartial _) = "IPartial"
73+
74+newtype Parser r a = Parser {
75+ unParser :: S -> (a -> S -> IResult r) -> IResult r
76+ }
77+
78+instance Monad (Parser r) where
79+ return a = Parser $ \s k -> k a s
80+ m >>= k = Parser $ \s cont -> unParser m s $ \a s' -> unParser (k a) s' cont
81+ fail err = Parser $ \s -> const $ IFailed s err
82+
83+zero :: Parser r a
84+zero = fail ""
85+
86+-- | I'm not sure if this is a huge bodge or not. It probably is.
87+--
88+-- When performing a choice (in @plus@), the failure depth in the
89+-- current state is incremented. If a failure is generated inside the
90+-- attempted path, the state carried in the IFailure will have this
91+-- incremented failure depth. However, we don't want to backtrack
92+-- after the attempted path has completed. Thus we insert this cut
93+-- continuation, which decrements the failure count of any failure
94+-- passing though, thus it would be caught in @plus@ and doesn't
95+-- trigger a backtrack.
96+cutContinuation :: (a -> S -> IResult r) -> a -> S -> IResult r
97+cutContinuation k v s =
98+ case k v s of
99+ IFailed (S lb i adds failDepth) err -> IFailed (S lb i adds (failDepth - 1)) err
100+ x -> x
101+
102+appL :: L.ByteString -> L.ByteString -> L.ByteString
103+appL xs L.Empty = xs
104+appL L.Empty ys = ys
105+appL xs ys = xs `L.append` ys
106+
107+plus :: Parser r a -> Parser r a -> Parser r a
108+plus p1 p2 =
109+ Parser $ \(S sb lb adds failDepth) k ->
110+ let
111+ filt f@(IFailed (S _ _ adds' failDepth') _)
112+ | failDepth' == failDepth + 1 =
113+ let lb' = lb `appL` L.fromChunks (reverse adds')
114+ in unParser p2 (S sb lb' (adds' ++ adds) failDepth) k
115+ | otherwise = f
116+ filt (IPartial cont) = IPartial (filt . cont)
117+ filt v@(IDone _ _) = v
118+ in
119+ filt $ unParser p1 (S sb lb [] (failDepth + 1)) (cutContinuation k)
120+
121+instance Functor (Parser r) where
122+ fmap f m = Parser $ \s cont -> unParser m s (cont . f)
123+
124+instance MonadPlus (Parser r) where
125+ mzero = zero
126+ mplus = plus
127+
128+instance Applicative (Parser r) where
129+ pure = return
130+ (<*>) = ap
131+
132+instance Alternative (Parser r) where
133+ empty = zero
134+ (<|>) = plus
135+
136+initState :: S.ByteString -> S
137+initState input = S input L.empty [] 0
138+
139+mkState :: L.ByteString -> [S.ByteString] -> Int -> S
140+mkState bs adds failDepth =
141+ case bs of
142+ L.Empty -> S S.empty L.empty adds failDepth
143+ L.Chunk sb lb -> S sb lb adds failDepth
144+
145+toLazy :: S.ByteString -> L.ByteString
146+toLazy s | S.null s = L.Empty
147+ | otherwise = L.Chunk s L.Empty
148+
149+addX :: S.ByteString -> [S.ByteString] -> [S.ByteString]
150+addX s adds | S.null s = adds
151+ | otherwise = s : adds
152+
153+yield :: Parser r ()
154+yield = Parser $ \(S sb lb adds failDepth) k ->
155+ IPartial $ \s -> k () (S sb (lb `appL` toLazy s) (addX s adds) failDepth)
156+
157+takeWith :: (L.ByteString -> (L.ByteString, L.ByteString))
158+ -> Parser r L.ByteString
159+takeWith splitf =
160+ Parser $ \(S sb lb adds failDepth) k ->
161+ let bs = sb +: lb
162+ (left,rest) = splitf bs
163+ in case rest of
164+ L.Empty -> IPartial $ \s ->
165+ let s' = S s L.empty (addX s adds) failDepth
166+ k' a = k (appL left a)
167+ in unParser (takeWith splitf) s' k'
168+ L.Chunk h t -> k left (S h t adds failDepth)
169+
170+string :: L.ByteString -> Parser r L.ByteString
171+string s = string' s
172+ where
173+ string' r =
174+ Parser $ \st@(S sb lb adds failDepth) k ->
175+ let bs = sb +: lb
176+ l = L.length r
177+ in case L.splitAt l bs of
178+ (h,t)
179+ | h == r -> k s (mkState t adds failDepth)
180+ (h,L.Empty)
181+ | h `L.isPrefixOf` r ->
182+ IPartial $ \s' ->
183+ let st' = S s' L.empty (addX s' adds) failDepth
184+ k' a = k (appL h a)
185+ in unParser (string (L.drop (L.length h) r)) st' k'
186+ _ -> IFailed st "string failed to match"
187+
188+takeWhile :: (Word8 -> Bool) -> Parser r L.ByteString
189+takeWhile = takeWith . L.span
190+
191+takeTill :: (Word8 -> Bool) -> Parser r L.ByteString
192+takeTill = takeWith . L.break
193+
194+toplevelTranslate :: IResult a -> Result a
195+toplevelTranslate (IFailed _ err) = Failed err
196+toplevelTranslate (IDone (S sb lb _ _) value) = Done (sb +: lb) value
197+toplevelTranslate (IPartial k) = Partial $ toplevelTranslate . k
198+
199+terminalContinuation :: a -> S -> IResult a
200+terminalContinuation v s = IDone s v
201+
202+parse :: Parser r r -> S.ByteString -> Result r
203+parse m input =
204+ toplevelTranslate $ unParser m (initState input) terminalContinuation