@@ -1,32 +1,33 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE Rank2Types, RecordWildCards #-}
22-----------------------------------------------------------------------------
33-- |
44-- Module : Data.Attoparsec.Internal
5−-- Copyright : Daan Leijen 1999-2001, Jeremy Shaw 2006, Bryan O'Sullivan 2007-2008
5+-- Copyright : Bryan O'Sullivan 2007-2010
66-- License : BSD3
77--
88-- Maintainer : bos@serpentine.com
99-- Stability : experimental
1010-- Portability : unknown
1111--
12−-- Simple, efficient parser combinators for lazy 'LB.ByteString'
13−-- strings, loosely based on 'Text.ParserCombinators.Parsec'.
12+-- Simple, efficient parser combinators for 'bB.ByteString' strings,
13+-- loosely based on 'Text.ParserCombinators.Parsec'.
1414--
1515-----------------------------------------------------------------------------
1616module Data.Attoparsec.Internal
1717 (
1818 -- * Parser types
19− ParseError
20− , Parser
19+ Parser
20+ , Result(..)
2121
2222 -- * Running parsers
2323 , parse
24− , parseAt
25− , parseTest
24+ , parseAll
25+ , feed
2626
2727 -- * Combinators
2828 , (<?>)
2929 , try
30+ , module Data.Attoparsec.Combinator
3031
3132 -- * Parsing individual bytes
3233 , satisfy
@@ -38,312 +39,315 @@ module Data.Attoparsec.Internal
3839 , inClass
3940 , notInClass
4041
42+ -- * Parsing more complicated structures
43+ , storable
44+
4145 -- * Efficient string handling
42− , match
43− , notEmpty
4446 , skipWhile
4547 , string
4648 , stringTransform
47− , takeAll
48− , takeCount
49+ , take
4950 , takeTill
5051 , takeWhile
5152 , takeWhile1
5253
5354 -- * State observation functions
55+ , ensure
5456 , endOfInput
55− , getConsumed
56− , getInput
57− , lookAhead
58− , setInput
5957
6058 -- * Utilities
6159 , endOfLine
62− , (+:)
6360 ) where
6461
65−import Control.Applicative
66− (Alternative(..), Applicative(..), (*>))
67−import Control.Monad (MonadPlus(..))
68−import Control.Monad.Fix (MonadFix(..))
62+import Control.Applicative (Alternative(..), Applicative(..), (<$>))
63+import Control.Monad (MonadPlus(..), when)
64+import Data.Attoparsec.Combinator
6965import Data.Attoparsec.FastSet (charClass, memberWord8)
70−import qualified Data.ByteString as SB
71−import qualified Data.ByteString.Lazy as LB
72−import qualified Data.ByteString.Lazy.Char8 as L8
73−import qualified Data.ByteString.Unsafe as U
74−import qualified Data.ByteString.Internal as I
75−import qualified Data.ByteString.Lazy.Internal as LB
76−import Data.Int (Int64)
66+import Data.Monoid (Monoid(..))
7767import Data.Word (Word8)
78−import Prelude hiding (takeWhile)
68+import Foreign.ForeignPtr (withForeignPtr)
69+import Foreign.Ptr (castPtr, plusPtr)
70+import Foreign.Storable (Storable(peek, sizeOf))
71+import Prelude hiding (getChar, take, takeWhile)
72+import qualified Data.ByteString as B8
73+import qualified Data.ByteString.Char8 as B
74+import qualified Data.ByteString.Internal as B
75+import qualified Data.ByteString.Unsafe as B
76+
77+data Result r = Fail S [String] String
78+ | Partial (B.ByteString -> Result r)
79+ | Done S r
80+
81+-- | The Parser monad is an Exception and State monad.
82+newtype Parser a = Parser {
83+ runParser :: forall r. S
84+ -> Failure r
85+ -> Success a r
86+ -> Result r
87+ }
7988
80−-- ^ A description of a parsing error.
81−type ParseError = String
89+type Failure r = S -> [String] -> String -> Result r
90+type Success a r = S -> a -> Result r
8291
83−-- State invariants:
84−-- * If both strict and lazy bytestrings are empty, the entire input
85−-- is considered to be empty.
86−data S = S {-# UNPACK #-} !SB.ByteString
87− LB.ByteString
88− {-# UNPACK #-} !Int64
92+data More = Complete | Incomplete
93+ deriving (Eq, Show)
8994
90−-- ^ A parser that produces a result of type @a@.
91−newtype Parser a = Parser {
92− unParser :: S -> Either (LB.ByteString, [String]) (a, S)
93− }
95+plusMore :: More -> More -> More
96+plusMore Complete _ = Complete
97+plusMore _ Complete = Complete
98+plusMore _ _ = Incomplete
99+{-# INLINE plusMore #-}
94100
95−fmapP :: (a -> b) -> Parser a -> Parser b
96−fmapP f p = Parser $ \s ->
97− case unParser p s of
98− Right (a, s') -> Right (f a, s')
99− Left err -> Left err
100−{-# INLINE fmapP #-}
101+instance Monoid More where
102+ mempty = Incomplete
103+ mappend = plusMore
101104
102−returnP :: a -> Parser a
103−returnP a = Parser $ \s -> Right (a, s)
104−{-# INLINE returnP #-}
105+data S = S {
106+ input :: !B.ByteString
107+ , _added :: !B.ByteString
108+ , more :: !More
109+ } deriving (Show)
110+
111+instance Show r => Show (Result r) where
112+ show (Fail _ stack msg) = "Fail " ++ show stack ++ " " ++ show msg
113+ show (Partial _) = "Partial _"
114+ show (Done bs r) = "Done " ++ show bs ++ " " ++ show r
115+
116+addS :: S -> S -> S
117+addS (S s0 a0 c0) (S _s1 a1 c1) = S (s0 +++ a1) (a0 +++ a1) (mappend c0 c1)
118+{-# INLINE addS #-}
119+
120+instance Monoid S where
121+ mempty = S B.empty B.empty Incomplete
122+ mappend = addS
105123
106124bindP :: Parser a -> (a -> Parser b) -> Parser b
107−bindP m f = Parser $ \s ->
108− case unParser m s of
109− Right (a, s') -> unParser (f a) s'
110− Left (s', msgs) -> Left (s', msgs)
125+bindP m g =
126+ Parser (\st0 kf ks -> runParser m st0 kf (\s a -> runParser (g a) s kf ks))
111127{-# INLINE bindP #-}
112128
113−failP :: String -> Parser a
114−failP err = Parser $ \(S sb lb _) -> Left (sb +: lb, [err])
115−{-# INLINE failP #-}
129+returnP :: a -> Parser a
130+returnP a = Parser (\st0 _kf ks -> ks st0 a)
131+{-# INLINE returnP #-}
116132
117−instance MonadFix Parser where
118− mfix f = Parser $ \s ->
119− let r = case r of
120− Right (a, _) -> unParser (f a) s
121− err -> err
122− in r
133+instance Monad Parser where
134+ return = returnP
135+ (>>=) = bindP
136+ fail = failDesc
123137
124−zero :: Parser a
125−zero = Parser $ \(S sb lb _) -> Left (sb +: lb, [])
126−{-# INLINE zero #-}
138+clear :: S -> S
139+clear (S s0 _a0 c0) = S s0 B.empty c0
140+{-# INLINE clear #-}
127141
128142plus :: Parser a -> Parser a -> Parser a
129−plus p1 p2 =
130− Parser $ \s@(S sb lb _) ->
131− case unParser p1 s of
132− Left (_, msgs1) ->
133− case unParser p2 s of
134− Left (_, msgs2) -> Left (sb +: lb, (msgs1 ++ msgs2))
135− ok -> ok
136− ok -> ok
143+plus a b = Parser $ \st0 kf ks ->
144+ let kf' st1 _ _ = runParser b (mappend st0 st1) kf ks
145+ in runParser a (clear st0) kf' ks
137146{-# INLINE plus #-}
138147
139−mkState :: LB.ByteString -> Int64 -> S
140−mkState s = case s of
141− LB.Empty -> S SB.empty s
142− LB.Chunk x xs -> S x xs
148+instance MonadPlus Parser where
149+ mzero = failDesc "mzero"
150+ mplus = plus
143151
144−-- | Turn our split representation back into a normal lazy ByteString.
145−(+:) :: SB.ByteString -> LB.ByteString -> LB.ByteString
146−sb +: lb | SB.null sb = lb
147− | otherwise = LB.Chunk sb lb
148−{-# INLINE (+:) #-}
152+fmapP :: (a -> b) -> Parser a -> Parser b
153+fmapP p m = Parser (\st0 f k -> runParser m st0 f (\s a -> k s (p a)))
154+{-# INLINE fmapP #-}
149155
150−infix 0 <?>
156+instance Functor Parser where
157+ fmap = fmapP
158+
159+apP :: Parser (a -> b) -> Parser a -> Parser b
160+apP d e = do
161+ b <- d
162+ a <- e
163+ return (b a)
164+{-# INLINE apP #-}
165+
166+instance Applicative Parser where
167+ pure = returnP
168+ (<*>) = apP
169+
170+instance Alternative Parser where
171+ empty = failDesc "empty"
172+ (<|>) = mplus
173+
174+failDesc :: String -> Parser a
175+failDesc err = Parser (\st0 kf _ks -> kf st0 [] msg)
176+ where msg = "Failed reading: " ++ err
177+{-# INLINE failDesc #-}
178+
179+ensure :: Int -> Parser ()
180+ensure n = Parser $ \st0@(S s0 _a0 _c0) kf ks ->
181+ if B.length s0 >= n
182+ then ks st0 ()
183+ else runParser (requireInput >> ensure n) st0 kf ks
184+
185+requireInput :: Parser ()
186+requireInput = Parser $ \st0@(S s0 a0 c0) kf ks ->
187+ if c0 == Complete
188+ then kf st0 ["requireInput"] "not enough bytes"
189+ else Partial $ \s ->
190+ if B.null s
191+ then kf (S s0 a0 Complete) ["requireInput"] "not enough bytes"
192+ else let st1 = S (s0 +++ s) (a0 +++ s) Incomplete
193+ in ks st1 ()
194+
195+failK :: Failure a
196+failK st0 stack msg = Fail st0 stack msg
197+
198+successK :: Success a a
199+successK state a = Done state a
200+
201+get :: Parser B.ByteString
202+get = Parser (\st0 _kf ks -> ks st0 (input st0))
203+
204+put :: B.ByteString -> Parser ()
205+put s = Parser (\(S _s0 a0 c0) _kf ks -> ks (S s a0 c0) ())
206+
207+take :: Int -> Parser B.ByteString
208+take n = takeWith n (const True)
209+
210+(+++) :: B.ByteString -> B.ByteString -> B.ByteString
211+(+++) = B.append
212+{-# INLINE (+++) #-}
213+
214+try :: Parser a -> Parser a
215+try p = Parser $ \st0 kf ks ->
216+ runParser p (clear st0) (kf . mappend st0) ks
151217
152−-- | Name the parser, in case failure occurs.
153−(<?>) :: Parser a
154− -> String -- ^ the name to use if parsing fails
155− -> Parser a
156−p <?> msg =
157− Parser $ \s@(S sb lb _) ->
158− case unParser p s of
159− (Left _) -> Left (sb +: lb, [msg])
160− ok -> ok
161−{-# INLINE (<?>) #-}
162−
163−nextChunk :: Parser ()
164−nextChunk = Parser $ \(S _ lb n) ->
165− case lb of
166− LB.Chunk sb' lb' -> Right ((), S sb' lb' n)
167− LB.Empty -> Left (lb, [])
168−
169−-- | Get remaining input.
170−getInput :: Parser LB.ByteString
171−getInput = Parser $ \s@(S sb lb _) -> Right (sb +: lb, s)
172−
173−-- | Set the remaining input.
174−setInput :: LB.ByteString -> Parser ()
175−setInput bs = Parser $ \(S _ _ n) -> Right ((), mkState bs n)
176−
177−-- | Get number of bytes consumed so far.
178−getConsumed :: Parser Int64
179−getConsumed = Parser $ \s@(S _ _ n) -> Right (n, s)
180−
181−-- | Match a single byte based on the given predicate.
182218satisfy :: (Word8 -> Bool) -> Parser Word8
183−satisfy p =
184− Parser $ \s@(S sb lb n) ->
185− case SB.uncons sb of
186− Just (c, sb') | p c -> Right (c, mkState (sb' +: lb) (n + 1))
187− | otherwise -> Left (sb +: lb, [])
188− Nothing -> unParser (nextChunk >> satisfy p) s
219+satisfy p = do
220+ ensure 1
221+ s <- get
222+ let w = B.unsafeHead s
223+ if p w
224+ then put (B.unsafeTail s) >> return w
225+ else fail "satisfy"
189226{-# INLINE satisfy #-}
190227
191−-- | Match a literal string exactly.
192−string :: LB.ByteString -> Parser LB.ByteString
193−string s = Parser $ \(S sb lb n) ->
194− let bs = sb +: lb
195− l = LB.length s
196− (h,t) = LB.splitAt l bs
197− in if s == h
198− then Right (s, mkState t (n + l))
199− else Left (bs, [])
200−{-# INLINE string #-}
201−
202−-- | Match the end of a line. This may be any of a newline character,
203−-- a carriage return character, or a carriage return followed by a newline.
204−endOfLine :: Parser ()
205−endOfLine = Parser $ \(S sb lb n) ->
206− let bs = sb +: lb
207− in if SB.null sb
208− then Left (bs, ["EOL"])
209− else case I.w2c (U.unsafeHead sb) of
210− '\n' -> Right ((), mkState (LB.tail bs) (n + 1))
211− '\r' -> let (h,t) = LB.splitAt 2 bs
212− rn = L8.pack "\r\n"
213− in if h == rn
214− then Right ((), mkState t (n + 2))
215− else Right ((), mkState (LB.tail bs) (n + 1))
216− _ -> Left (bs, ["EOL"])
217−
218−-- | Match a literal string, after applying a transformation to both
219−-- it and the matching text. Useful for e.g. case insensitive string
220−-- comparison.
221−stringTransform :: (LB.ByteString -> LB.ByteString) -> LB.ByteString
222− -> Parser LB.ByteString
223−stringTransform f s = Parser $ \(S sb lb n) ->
224− let bs = sb +: lb
225− l = LB.length s
226− (h, t) = LB.splitAt l bs
227− in if fs == f h
228− then Right (s, mkState t (n + l))
229− else Left (bs, [])
230− where fs = f s
231−{-# INLINE stringTransform #-}
232−
233−-- | Attempt a parse, but do not consume any input if the parse fails.
234−try :: Parser a -> Parser a
235−try p = Parser $ \s@(S sb lb _) ->
236− case unParser p s of
237− Left (_, msgs) -> Left (sb +: lb, msgs)
238− ok -> ok
228+storable :: Storable a => Parser a
229+storable = hack undefined
230+ where
231+ hack :: Storable b => b -> Parser b
232+ hack dummy = do
233+ (fp,o,_) <- B.toForeignPtr `fmapP` take (sizeOf dummy)
234+ return . B.inlinePerformIO . withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)
235+
236+takeWith :: Int -> (B.ByteString -> Bool) -> Parser B.ByteString
237+takeWith n p = do
238+ ensure n
239+ s <- get
240+ let (h,t) = B.splitAt n s
241+ if p h
242+ then put t >> return h
243+ else failDesc "takeWith"
244+{-# INLINE takeWith #-}
245+
246+string :: B.ByteString -> Parser B.ByteString
247+string s = takeWith (B.length s) (==s)
248+
249+stringTransform :: (B.ByteString -> B.ByteString) -> B.ByteString
250+ -> Parser B.ByteString
251+stringTransform f s = takeWith (B.length s) ((==s) . f)
252+
253+skipWhile :: (Word8 -> Bool) -> Parser ()
254+skipWhile p = do
255+ (`when` requireInput) =<< B.null <$> get
256+ t <- B8.dropWhile p <$> get
257+ put t
258+ if B.null t
259+ then (skipWhile p <|> return ())
260+ else return ()
261+
262+takeTill :: (Word8 -> Bool) -> Parser B.ByteString
263+takeTill p = takeWhile (not . p)
264+
265+takeWhile :: (Word8 -> Bool) -> Parser B.ByteString
266+takeWhile p = do
267+ (`when` requireInput) =<< B.null <$> get
268+ (h,t) <- B8.span p <$> get
269+ put t
270+ if B.null t
271+ then (h+++) `fmapP` (takeWhile p <|> return B.empty)
272+ else return h
273+
274+takeWhile1 :: (Word8 -> Bool) -> Parser B.ByteString
275+takeWhile1 p = do
276+ (`when` requireInput) =<< B.null <$> get
277+ (h,t) <- B8.span p <$> get
278+ when (B.null h) $ failDesc "takeWhile1"
279+ put t
280+ if B.null t
281+ then (h+++) `fmapP` (takeWhile p <|> return B.empty)
282+ else return h
283+
284+-- | Match any character in a set.
285+--
286+-- > vowel = inClass "aeiou"
287+--
288+-- Range notation is supported.
289+--
290+-- > halfAlphabet = inClass "a-nA-N"
291+--
292+-- To add a literal \'-\' to a set, place it at the beginning or end
293+-- of the string.
294+inClass :: String -> Word8 -> Bool
295+inClass s = (`memberWord8` mySet)
296+ where mySet = charClass s
297+{-# INLINE inClass #-}
298+
299+-- | Match any character not in a set.
300+notInClass :: String -> Word8 -> Bool
301+notInClass s = not . inClass s
302+{-# INLINE notInClass #-}
303+
304+-- | Match any byte.
305+anyWord8 :: Parser Word8
306+anyWord8 = satisfy $ const True
307+{-# INLINE anyWord8 #-}
308+
309+-- | Match a specific byte.
310+word8 :: Word8 -> Parser Word8
311+word8 c = satisfy (== c) <?> show c
312+{-# INLINE word8 #-}
313+
314+-- | Match any byte except the given one.
315+notWord8 :: Word8 -> Parser Word8
316+notWord8 c = satisfy (/= c) <?> "not " ++ show c
317+{-# INLINE notWord8 #-}
239318
240−-- | Succeed if we have reached the end of the input string.
241319endOfInput :: Parser ()
242−endOfInput = Parser $ \s@(S sb lb _) -> if SB.null sb && LB.null lb
243− then Right ((), s)
244− else Left (sb +: lb, ["EOF"])
245−
246−-- | Return all of the remaining input as a single string.
247−takeAll :: Parser LB.ByteString
248−takeAll = Parser $ \(S sb lb n) ->
249− let bs = sb +: lb
250− in Right (bs, mkState LB.empty (n + LB.length bs))
251−
252−-- | Return exactly the given number of bytes. If not enough are
253−-- available, fail.
254−takeCount :: Int -> Parser LB.ByteString
255−takeCount k =
256− Parser $ \(S sb lb n) ->
257− let bs = sb +: lb
258− k' = fromIntegral k
259− (h,t) = LB.splitAt k' bs
260− in if LB.length h == k'
261− then Right (h, mkState t (n + k'))
262− else Left (bs, [show k ++ " bytes"])
263−
264−-- | Consume bytes while the predicate succeeds.
265−takeWhile :: (Word8 -> Bool) -> Parser LB.ByteString
266−takeWhile p =
267− Parser $ \(S sb lb n) ->
268− let (h,t) = LB.span p (sb +: lb)
269− in Right (h, mkState t (n + LB.length h))
270−{-# INLINE takeWhile #-}
271−
272−-- | Consume bytes while the predicate fails. If the predicate never
273−-- succeeds, the entire input string is returned.
274−takeTill :: (Word8 -> Bool) -> Parser LB.ByteString
275−takeTill p =
276− Parser $ \(S sb lb n) ->
277− let (h,t) = LB.break p (sb +: lb)
278− in Right (h, mkState t (n + LB.length h))
279−{-# INLINE takeTill #-}
280−
281−-- | Consume bytes while the predicate is true. Fails if the
282−-- predicate fails on the first byte.
283−takeWhile1 :: (Word8 -> Bool) -> Parser LB.ByteString
284−takeWhile1 p =
285− Parser $ \(S sb lb n) ->
286− case LB.span p (sb +: lb) of
287− (h,t) | LB.null h -> Left (t, [])
288− | otherwise -> Right (h, mkState t (n + LB.length h))
289−{-# INLINE takeWhile1 #-}
290−
291−-- | Test that a parser returned a non-null 'LB.ByteString'.
292−notEmpty :: Parser LB.ByteString -> Parser LB.ByteString
293−notEmpty p = Parser $ \s ->
294− case unParser p s of
295− o@(Right (a, _)) ->
296− if LB.null a
297− then Left (a, ["notEmpty"])
298− else o
299− x -> x
300−
301−-- | Parse some input with the given parser, and return the input it
302−-- consumed as a string.
303−match :: Parser a -> Parser LB.ByteString
304−match p = do bs <- getInput
305− start <- getConsumed
306− p
307− end <- getConsumed
308− return (LB.take (end - start) bs)
309−
310−-- | Apply a parser without consuming any input.
311−lookAhead :: Parser a -> Parser a
312−lookAhead p = Parser $ \s ->
313− case unParser p s of
314− Right (m, _) -> Right (m, s)
315− err -> err
316−
317−-- | Run a parser. The 'Int64' value is used as a base to count the
318−-- number of bytes consumed.
319−parseAt :: Parser a -- ^ parser to run
320− -> LB.ByteString -- ^ input to parse
321− -> Int64 -- ^ offset to count input from
322− -> (LB.ByteString, Either ParseError (a, Int64))
323−parseAt p bs n =
324− case unParser p (mkState bs n) of
325− Left (bs', msg) -> (bs', Left $ showError msg)
326− Right (a, ~(S sb lb n')) -> (sb +: lb, Right (a, n'))
327− where
328− showError [""] = "Parser error\n"
329− showError [msg] = "Parser error, expected:\n" ++ msg ++ "\n"
330− showError [] = "Parser error\n"
331− showError msgs = "Parser error, expected one of:\n" ++ unlines msgs
332−
333−-- | Run a parser.
334−parse :: Parser a -- ^ parser to run
335− -> LB.ByteString -- ^ input to parse
336− -> (LB.ByteString, Either ParseError a)
337−parse p bs = case parseAt p bs 0 of
338− (bs', Right (a, _)) -> (bs', Right a)
339− (bs', Left err) -> (bs', Left err)
340−
341−-- | Try out a parser, and print its result.
342−parseTest :: (Show a) => Parser a -> LB.ByteString -> IO ()
343−parseTest p s =
344− case parse p s of
345− (st, Left msg) -> putStrLn $ msg ++ "\nGot:\n" ++ show st
346− (_, Right r) -> print r
347−
348−#define PARSER Parser
349−#include "Word8Boilerplate.h"
320+endOfInput = Parser $ \st0@S{..} kf ks ->
321+ if B.null input
322+ then if more == Complete
323+ then ks st0 ()
324+ else let kf' st1 _ _ = ks (mappend st0 st1) ()
325+ ks' st1 _ = kf (mappend st0 st1) [] "endOfInput"
326+ in runParser requireInput st0 kf' ks'
327+ else kf st0 [] "endOfInput"
328+
329+endOfLine :: Parser ()
330+endOfLine = (word8 10 >> return ()) <|> (string (B.pack "\r\n") >> return ())
331+
332+--- | Name the parser, in case failure occurs.
333+(<?>) :: Parser a
334+ -> String -- ^ the name to use if parsing fails
335+ -> Parser a
336+p <?> _msg = p
337+infix 0 <?>
338+
339+parse :: Parser a -> B.ByteString -> Result a
340+parse m s = runParser m (S s B.empty Incomplete) failK successK
341+
342+feed :: Result r -> B.ByteString -> Result r
343+feed f@(Fail _ _ _) _ = f
344+feed (Partial k) d = k d
345+feed (Done (S s a c) r) d = Done (S (s +++ d) a c) r
346+
347+parseAll :: Parser a -> [B.ByteString] -> Result a
348+parseAll p ss = case ss of
349+ [] -> go (parse p B.empty) []
350+ (c:cs) -> go (parse p c) cs
351+ where go (Partial k) (c:cs) = go (k c) cs
352+ go (Partial k) [] = k B.empty
353+ go r _ = r