@@ -0,0 +1,159 @@
1+-----------------------------------------------------------------------------
2+-- |
3+-- Module : ByteStringParser
4+-- Copyright : (c) Jeremy Shaw 2006
5+-- Copyright : (c) Daan Leijen 1999-2001
6+-- License : BSD-style (see the file libraries/parsec/LICENSE)
7+--
8+-- Maintainer : jeremy@n-heptane.com
9+-- Stability : experimental
10+-- Portability : unknown
11+--
12+-- Primitive parser combinators for ByteStrings loosely based on Parsec.
13+--
14+-----------------------------------------------------------------------------
15+module ByteStringParser where
16+
17+import Data.Char
18+import Data.Word
19+import Control.Monad
20+import qualified Data.ByteString.Char8 as C
21+
22+-- * Parser
23+
24+type ParserError state = (state, String)
25+
26+-- * Parser Monad
27+
28+newtype Parser state a = Parser { unParser :: (state -> Either (state,[String]) (a, state)) }
29+
30+instance Functor (Parser state) where
31+ fmap f (Parser p) =
32+ Parser $ \st ->
33+ case p st of
34+ Right (a, st') -> Right (f a, st')
35+ Left err -> Left err
36+
37+instance Monad (Parser state) where
38+ return a = Parser (\s -> Right (a,s))
39+ m >>= f =
40+ Parser $ \state ->
41+ let r = (unParser m) state in
42+ case r of
43+ Right (a,state') -> unParser (f a) $ state'
44+ (Left (st, msgs)) -> (Left (st, msgs))
45+
46+instance MonadPlus (Parser state) where
47+ mzero = Parser (\st -> (Left (st, [])))
48+ mplus (Parser p1) (Parser p2) =
49+ Parser (\s -> case p1 s of
50+ (Left (_, msgs1)) ->
51+ case p2 s of
52+ Left (_, msgs2) -> Left (s, (msgs1 ++ msgs2))
53+ o -> o
54+ o -> o
55+ )
56+
57+-- |Always succeed
58+pSucceed :: a -> Parser state a
59+pSucceed = return
60+
61+-- |Always fail
62+pFail :: Parser state a
63+pFail = Parser (\st -> Left (st, []))
64+
65+infix 0 <?>
66+infixr 1 <|>
67+
68+-- |choice
69+(<|>) :: Parser state a -> Parser state a -> Parser state a
70+(<|>) = mplus
71+
72+-- |name the parser
73+(<?>) :: Parser state a -> String -> Parser state a
74+p <?> msg =
75+ Parser $ \st ->
76+ case (unParser p) st of
77+ (Left _) -> Left (st, [msg])
78+ ok -> ok
79+
80+-- |character parser
81+satisfy :: (Char -> Bool) -> Parser C.ByteString Char
82+satisfy f =
83+ Parser $ \bs ->
84+ if C.null bs
85+ then Left (bs, [])
86+ else let (s,ss) = (C.head bs, C.tail bs) in
87+ if (f s)
88+ then Right (s,ss)
89+ else Left (bs, [])
90+
91+-- |satisfy a specific character
92+pChar :: Char -> Parser C.ByteString Char
93+pChar c = satisfy (== c) <?> [c]
94+
95+-- |detect 'end of file'
96+pEOF :: Parser C.ByteString ()
97+pEOF =
98+ Parser $ \bs -> if C.null bs then Right ((),bs) else (Left (bs, ["EOF"]))
99+
100+-- |pTakeWhile take characters while the predicate is true
101+pTakeWhile :: (Char -> Bool) -> Parser C.ByteString C.ByteString
102+pTakeWhile f =
103+ Parser $ \bs -> Right (C.span f bs)
104+
105+-- |pSkipWhile skip over characters while the predicate is true
106+pSkipWhile :: (Char -> Bool) -> Parser C.ByteString ()
107+pSkipWhile p =
108+ Parser $ \bs -> Right ((), C.dropWhile p bs)
109+
110+-- |'pMany' - take zero or more instances of the parser
111+pMany :: Parser st a -> Parser st [a]
112+pMany p
113+ = scan id
114+ where
115+ scan f = do x <- p
116+ scan (\tail -> f (x:tail))
117+ <|> return (f [])
118+
119+-- |'pMany1' - take one or more instances of the parser
120+pMany1 :: Parser st a -> Parser st [a]
121+pMany1 p =
122+ do x <- p
123+ xs <- pMany p
124+ return (x:xs)
125+
126+-- |'pSkipMany' - skip zero or many instances of the parser
127+pSkipMany :: Parser st a -> Parser st ()
128+pSkipMany p = scan
129+ where
130+ scan = (p >> scan) <|> return ()
131+
132+-- |'pSkipMany1' - skip one or many instances of the parser
133+pSkipMany1 :: Parser st a -> Parser st ()
134+pSkipMany1 p = p >> pSkipMany p
135+
136+-- |'notEmpty' - tests that a parser returned a non-null ByteString
137+notEmpty :: Parser C.ByteString C.ByteString -> Parser C.ByteString C.ByteString
138+notEmpty (Parser p) =
139+ Parser $ \s -> case p s of
140+ o@(Right (a, s)) ->
141+ if C.null a
142+ then Left (a, ["notEmpty"])
143+ else o
144+ x -> x
145+
146+-- |'parse' - run a parser
147+parse :: Parser state a -> state -> Either (ParserError state) (a, state)
148+parse p s =
149+ case ((unParser p) s) of
150+ Left (st, msg) -> Left (st, showError msg)
151+ (Right r) -> (Right r)
152+ where
153+ showError [msg] = "Parser error, expected:\n" ++ msg ++ "\n"
154+ showError msgs = "Parser error, expected one of:\n" ++ unlines msgs
155+
156+parseTest p s =
157+ case parse p s of
158+ Left (st, msg) -> putStrLn $ msg ++ "\nGot:\n" ++ show st
159+ Right (r,_) -> print r