@@ -1,355 +0,0 @@
1−-----------------------------------------------------------------------------
2−-- |
3−-- Module : Data.ParserCombinators.ByteStringParser.Internal
4−-- Copyright : Daan Leijen 1999-2001, Jeremy Shaw 2006, Bryan O'Sullivan 2007-2008
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−-----------------------------------------------------------------------------
15−module Data.ParserCombinators.ByteStringParser.Internal
16− (
17− -- * Parser
18− ParseError
19− , Parser
20−
21− -- * Running parsers
22− , parse
23− , parseAt
24− , parseTest
25−
26− -- * Combinators
27− , (<?>)
28−
29− -- * Things vaguely like those in @Parsec.Combinator@ (and @Parsec.Prim@)
30− , try
31− , manyTill
32− , eof
33− , skipMany
34− , skipMany1
35− , count
36− , lookAhead
37− , peek
38− , sepBy
39− , sepBy1
40−
41− -- * Things like in @Parsec.Char@
42− , satisfy
43− , anyWord8
44− , word8
45− , notWord8
46− , string
47− , stringTransform
48−
49− -- * Parser converters.
50− , eitherP
51−
52− -- * Miscellaneous functions.
53− , getInput
54− , getConsumed
55− , takeWhile
56− , takeWhile1
57− , takeTill
58− , takeAll
59− , skipWhile
60− , notEmpty
61− , match
62− ) where
63−
64−import Control.Applicative
65− (Alternative(..), Applicative(..), (<$>), (<*), (*>))
66−import Control.Monad (MonadPlus(..), ap, liftM2)
67−import Control.Monad.Fix (MonadFix(..))
68−import qualified Data.ByteString as SB
69−import qualified Data.ByteString.Lazy as LB
70−import qualified Data.ByteString.Lazy.Internal as LB
71−import Data.Int (Int64)
72−import Data.Word (Word8)
73−import Prelude hiding (takeWhile)
74−
75−type ParseError = String
76−
77−data S = S {-# UNPACK #-} !SB.ByteString
78− LB.ByteString
79− {-# UNPACK #-} !Int64
80−
81−newtype Parser a = Parser {
82− unParser :: S -> Either (LB.ByteString, [String]) (a, S)
83− }
84−
85−instance Functor Parser where
86− fmap f p =
87− Parser $ \s ->
88− case unParser p s of
89− Right (a, s') -> Right (f a, s')
90− Left err -> Left err
91−
92−instance Monad Parser where
93− return a = Parser $ \s -> Right (a, s)
94− m >>= f = Parser $ \s ->
95− case unParser m s of
96− Right (a, s') -> unParser (f a) s'
97− Left (s', msgs) -> Left (s', msgs)
98− fail err = Parser $ \(S sb lb _) -> Left (sb +: lb, [err])
99−
100−instance MonadFix Parser where
101− mfix f = Parser $ \s ->
102− let r = case r of
103− Right (a, _) -> unParser (f a) s
104− err -> err
105− in r
106−
107−zero :: Parser a
108−zero = Parser $ \(S sb lb _) -> Left (sb +: lb, [])
109−{-# INLINE zero #-}
110−
111−plus :: Parser a -> Parser a -> Parser a
112−plus p1 p2 =
113− Parser $ \s@(S sb lb _) ->
114− case unParser p1 s of
115− Left (_, msgs1) ->
116− case unParser p2 s of
117− Left (_, msgs2) -> Left (sb +: lb, (msgs1 ++ msgs2))
118− ok -> ok
119− ok -> ok
120−{-# INLINE plus #-}
121−
122−instance MonadPlus Parser where
123− mzero = zero
124− mplus = plus
125−
126−instance Applicative Parser where
127− pure = return
128− (<*>) = ap
129−
130−instance Alternative Parser where
131− empty = zero
132− (<|>) = plus
133−
134−mkState :: LB.ByteString -> Int64 -> S
135−mkState s = case s of
136− LB.Empty -> S SB.empty s
137− LB.Chunk x xs -> S x xs
138−
139−-- | Turn our chunked representation back into a normal lazy
140−-- ByteString.
141−(+:) :: SB.ByteString -> LB.ByteString -> LB.ByteString
142−sb +: lb | SB.null sb = lb
143− | otherwise = LB.Chunk sb lb
144−{-# INLINE (+:) #-}
145−
146−infix 0 <?>
147−
148−-- | Name the parser.
149−(<?>) :: Parser a -> String -> Parser a
150−p <?> msg =
151− Parser $ \s@(S sb lb _) ->
152− case unParser p s of
153− (Left _) -> Left (sb +: lb, [msg])
154− ok -> ok
155−{-# INLINE (<?>) #-}
156−
157−nextChunk :: Parser ()
158−nextChunk = Parser $ \(S _ lb n) ->
159− case lb of
160− LB.Chunk sb' lb' -> Right ((), S sb' lb' n)
161− LB.Empty -> Left (lb, [])
162−
163−-- | Get remaining input.
164−getInput :: Parser LB.ByteString
165−getInput = Parser $ \s@(S sb lb _) -> Right (sb +: lb, s)
166−
167−-- | Get number of bytes consumed so far.
168−getConsumed :: Parser Int64
169−getConsumed = Parser $ \s@(S _ _ n) -> Right (n, s)
170−
171−-- | Character parser.
172−satisfy :: (Word8 -> Bool) -> Parser Word8
173−satisfy p =
174− Parser $ \s@(S sb lb n) ->
175− case SB.uncons sb of
176− Just (c, sb') | p c -> Right (c, S sb' lb (n + 1))
177− | otherwise -> Left (sb +: lb, [])
178− Nothing -> unParser (nextChunk >> satisfy p) s
179−{-# INLINE satisfy #-}
180−
181−anyWord8 :: Parser Word8
182−anyWord8 = satisfy $ const True
183−{-# INLINE anyWord8 #-}
184−
185−-- | Satisfy a specific character.
186−word8 :: Word8 -> Parser Word8
187−word8 c = satisfy (== c) <?> show c
188−{-# INLINE word8 #-}
189−
190−-- | Satisfy a specific character.
191−notWord8 :: Word8 -> Parser Word8
192−notWord8 c = satisfy (/= c) <?> "not " ++ show c
193−{-# INLINE notWord8 #-}
194−
195−sepBy :: Parser a -> Parser s -> Parser [a]
196−sepBy p s = liftM2 (:) p ((s >> sepBy1 p s) <|> return []) <|> return []
197−
198−sepBy1 :: Parser a -> Parser s -> Parser [a]
199−sepBy1 p s = liftM2 (:) p ((s >> sepBy1 p s) <|> return [])
200−
201−-- | Satisfy a literal string.
202−string :: LB.ByteString -> Parser LB.ByteString
203−string s = Parser $ \(S sb lb n) ->
204− let bs = sb +: lb
205− l = LB.length s
206− (h, t) = LB.splitAt l bs
207− in if s == h
208− then Right (s, mkState t (n + l))
209− else Left (bs, [])
210−{-# INLINE string #-}
211−
212−-- | Satisfy a literal string, after applying a transformation to both
213−-- it and the matching text.
214−stringTransform :: (LB.ByteString -> LB.ByteString) -> LB.ByteString
215− -> Parser LB.ByteString
216−stringTransform f s = Parser $ \(S sb lb n) ->
217− let bs = sb +: lb
218− l = LB.length s
219− (h, t) = LB.splitAt l bs
220− in if fs == f h
221− then Right (s, mkState t (n + l))
222− else Left (bs, [])
223− where fs = f s
224−{-# INLINE stringTransform #-}
225−
226−-- | Apply the given parser repeatedly, returning every parse result.
227−count :: Int -> Parser a -> Parser [a]
228−count n p = sequence (replicate n p)
229−{-# INLINE count #-}
230−
231−try :: Parser a -> Parser a
232−try p = Parser $ \s@(S sb lb _) ->
233− case unParser p s of
234− Left (_, msgs) -> Left (sb +: lb, msgs)
235− ok -> ok
236−
237−-- | Detect 'end of file'.
238−eof :: Parser ()
239−eof = Parser $ \s@(S sb lb _) -> if SB.null sb && LB.null lb
240− then Right ((), s)
241− else Left (sb +: lb, ["EOF"])
242−
243−takeAll :: Parser LB.ByteString
244−takeAll = Parser $ \(S sb lb n) ->
245− let bs = sb +: lb
246− in Right (bs, mkState LB.empty (n + LB.length bs))
247−
248−oneChunk :: SB.ByteString -> LB.ByteString
249−oneChunk s = LB.Chunk s LB.Empty
250−
251−length64 :: SB.ByteString -> Int64
252−length64 = fromIntegral . SB.length
253−
254−-- | Consume characters while the predicate is true.
255−takeWhile :: (Word8 -> Bool) -> Parser LB.ByteString
256−takeWhile p = Parser $ \s@(S sb lb n) ->
257− let (h, t) = SB.span p sb
258− in if SB.null t
259− then unParser ((h +:) <$> (nextChunk *> takeWhile p)) s
260− else Right (oneChunk h, S t lb (n + length64 h))
261−{-# INLINE takeWhile #-}
262−
263−takeTill :: (Word8 -> Bool) -> Parser LB.ByteString
264−takeTill p = takeWhile (not . p) <* satisfy p
265−{-# INLINE takeTill #-}
266−
267−takeWhile1 :: (Word8 -> Bool) -> Parser LB.ByteString
268−takeWhile1 p = Parser $ \s@(S sb lb n) ->
269− let (h, t) = SB.span p sb
270− in if SB.null t
271− then case unParser (nextChunk *> takeWhile p) s of
272− Left err -> Left err
273− Right (xs, s') ->
274− let bs = h +: xs
275− in if LB.null bs
276− then Left (sb +: lb, [])
277− else Right (bs, s')
278− else Right (oneChunk h, S t lb (n + length64 h))
279−{-# INLINE takeWhile1 #-}
280−
281−-- | Skip over characters while the predicate is true.
282−skipWhile :: (Word8 -> Bool) -> Parser ()
283−skipWhile p = takeWhile p >> return ()
284−{-# INLINE skipWhile #-}
285−
286−manyTill :: Parser a -> Parser b -> Parser [a]
287−manyTill p end = scan
288− where scan = (end >> return []) <|> liftM2 (:) p scan
289−
290−-- |'skipMany' - skip zero or many instances of the parser
291−skipMany :: Parser a -> Parser ()
292−skipMany p = scan
293− where scan = (p >> scan) <|> return ()
294−
295−-- |'skipMany1' - skip one or many instances of the parser
296−skipMany1 :: Parser a -> Parser ()
297−skipMany1 p = p >> skipMany p
298−
299−-- | Test that a parser returned a non-null ByteString.
300−notEmpty :: Parser LB.ByteString -> Parser LB.ByteString
301−notEmpty p = Parser $ \s ->
302− case unParser p s of
303− o@(Right (a, _)) ->
304− if LB.null a
305− then Left (a, ["notEmpty"])
306− else o
307− x -> x
308−
309−-- | Parse some input with the given parser and return that input
310−-- without copying it.
311−match :: Parser a -> Parser LB.ByteString
312−match p = do bs <- getInput
313− start <- getConsumed
314− p
315− end <- getConsumed
316− return (LB.take (end - start) bs)
317−
318−eitherP :: Parser a -> Parser b -> Parser (Either a b)
319−eitherP a b = (Left <$> a) <|> (Right <$> b)
320−{-# INLINE eitherP #-}
321−
322−peek :: Parser a -> Parser (Maybe a)
323−peek p = Parser $ \s ->
324− case unParser p s of
325− Right (m, _) -> Right (Just m, s)
326− _ -> Right (Nothing, s)
327−
328−lookAhead :: Parser a -> Parser a
329−lookAhead p = Parser $ \s ->
330− case unParser p s of
331− Right (m, _) -> Right (m, s)
332− Left (e, bs) -> Left (e, bs)
333−
334−parseAt :: Parser a -> LB.ByteString -> Int64
335− -> (LB.ByteString, Either ParseError (a, Int64))
336−parseAt p bs n =
337− case unParser p (mkState bs n) of
338− Left (bs', msg) -> (bs', Left $ showError msg)
339− Right (a, S sb lb n') -> (sb +: lb, Right (a, n'))
340− where
341− showError [msg] = "Parser error, expected:\n" ++ msg ++ "\n"
342− showError msgs = "Parser error, expected one of:\n" ++ unlines msgs
343−
344−-- | Run a parser.
345−parse :: Parser a -> LB.ByteString
346− -> (LB.ByteString, Either ParseError a)
347−parse p bs = case parseAt p bs 0 of
348− (bs', Right (a, _)) -> (bs', Right a)
349− (bs', Left err) -> (bs', Left err)
350−
351−parseTest :: (Show a) => Parser a -> LB.ByteString -> IO ()
352−parseTest p s =
353− case parse p s of
354− (st, Left msg) -> putStrLn $ msg ++ "\nGot:\n" ++ show st
355− (_, Right r) -> print r