2 Parser(..), (+.+), (..+), (+..), (|||), (>>>), (||!), (|!!), (.>),
3 into, lit, litp, many, many1, succeed, sepBy, count, sepBy1, testp, token, recover,
4 ParseResult, parse, sParse, simpleParse,
14 import {-flummox mkdependHS-}
17 Either renaming (Left to Wrong)
22 import UnsafeDirty(seq)
25 infixr 8 +.+ , ..+ , +..
27 infix 6 >> , `act` , >>>, `into` , .>
29 infix 6 `act` , >>>, `into` , .>
31 infixr 4 ||| , ||! , |!!
34 seq x y = y --partain: a substitute
40 = FailAt Int{-#STRICT#-} [ErrMsg] a -- token pos, list of acceptable tokens, rest of tokens
43 = Many [(b, Int, a)] (FailAt a) -- parse succeeded with many (>1) parses)
44 | One b Int{-#STRICT#-} a (FailAt a){-#STRICT#-} -- parse succeeded with one parse
45 | None Bool{-#STRICT#-} (FailAt a){-#STRICT#-} -- parse failed. The Bool indicates hard fail
48 type Parser a b = a -> Int -> ParseResult a b
50 noFail = FailAt (-1) [] (error "noFail") -- indicates no failure yet
52 updFail f (None w f') = None w (bestFailAt f f')
53 updFail f (One c n as f') = One c n as (bestFailAt f f')
54 updFail f (Many cas f') = let r = bestFailAt f f' in seq r (Many cas r)
56 bestFailAt f@(FailAt i a t) f'@(FailAt j a' _) =
62 noFail --FailAt (-1) [] []
67 (|||) :: Parser a b -> Parser a b -> Parser a b
69 case (p as n, q as n) of
70 (pr@(None True _), _ ) -> pr
71 (pr@(None _ f), qr ) -> updFail f qr
72 ( One b k as f , qr ) -> Many ((b,k,as) : l') (bestFailAt f f') where (l',f') = lf qr
73 ( Many l f , qr ) -> Many ( l++l') (bestFailAt f f') where (l',f') = lf qr
74 where lf (Many l f) = (l, f)
75 lf (One b k as f) = ([(b,k,as)], f)
76 lf (None _ f) = ([], f)
78 -- Alternative, but with committed choice
79 (||!) :: Parser a b -> Parser a b -> Parser a b
81 case (p as n, q as n) of
82 (pr@(None True _), _ ) -> pr
83 ( None _ f , qr ) -> updFail f qr
86 process f [] [] = seq f (None False f)
87 process f [(b,k,as)] [] = seq f (One b k as f)
88 process f rs [] = seq f (Many rs f)
89 process f rs (w@(None True _):_) = seq f w
90 process f rs (None False f':rws) = process (bestFailAt f f') rs rws
91 process f rs (One b k as f':rws) = process (bestFailAt f f') (rs++[(b,k,as)]) rws
92 process f rs (Many rs' f' :rws) = process (bestFailAt f f') (rs++rs') rws
94 doMany g cas f = Many [ (g c, n, as) | (c,n,as) <- cas] f
97 (+.+) :: Parser a b -> Parser a c -> Parser a (b,c)
104 None w f' -> None w (bestFailAt f f')
105 One c n'' as'' f' -> One (b,c) n'' as'' (bestFailAt f f')
106 Many cas f' -> doMany (\x->(b,x)) cas (bestFailAt f f')
108 let rss = [ case q as' n' of { None w f -> None w f;
109 One c n'' as'' f' -> One (b,c) n'' as'' f';
110 Many cas f' -> doMany (\x->(b,x)) cas f' }
111 | (b,n',as') <- bas ]
114 -- Sequence, throw away first part
115 (..+) :: Parser a b -> Parser a c -> Parser a c
116 p ..+ q = -- p +.+ q `act` snd
120 One _ n' as' f -> updFail f (q as' n')
121 Many bas f -> process f [] [ q as' n' | (_,n',as') <- bas ]
123 -- Sequence, throw away second part
124 (+..) :: Parser a b -> Parser a c -> Parser a b
125 p +.. q = -- p +.+ q `act` fst
131 None w f' -> None w (bestFailAt f f')
132 One _ n'' as'' f' -> One b n'' as'' (bestFailAt f f')
133 Many cas f' -> doMany (const b) cas (bestFailAt f f')
135 let rss = [ case q as' n' of { None w f -> None w f;
136 One _ n'' as'' f' -> One b n'' as'' f';
137 Many cas f' -> doMany (const b) cas f' }
138 | (b,n',as') <- bas ]
141 -- Return a fixed value
142 (.>) :: Parser a b -> c -> Parser a c
147 One _ n' as' f' -> One v n' as' f'
148 Many bas f -> doMany (const v) bas f
153 (>>) :: Parser a b -> (b->c) -> Parser a c
157 One b n as' ff -> One (f b) n as' ff
158 Many bas ff -> doMany f bas ff
160 act :: Parser a b -> (b->c) -> Parser a c
164 One b n as' ff -> One (f b) n as' ff
165 Many bas ff -> doMany f bas ff
168 -- Action on two items
169 (>>>) :: Parser a (b,c) -> (b->c->d) -> Parser a d
172 None w ff -> None w ff
173 One (b,c) n as' ff -> One (f b c) n as' ff
174 Many bas ff -> doMany (\ (x,y)->f x y) bas ff
177 into :: Parser a b -> (b -> Parser a c) -> Parser a c
178 p `into` fq = \as n ->
181 One b n' as' f -> updFail f (fq b as' n')
182 Many bas f -> process f [] [ fq b as' n' | (b,n',as') <- bas ]
184 -- Succeeds with a value
185 succeed :: b -> Parser a b
186 succeed v = \as n -> One v n as noFail
190 fail :: ErrMsg -> Parser a b
191 fail s = \as n -> None False (FailAt n [s] as)
193 failP :: ErrMsg -> Parser a b
194 failP s = \as n -> None False (FailAt n [s] as)
197 -- Fail completely if parsing proceeds a bit and then fails
198 mustAll :: Parser a b -> Parser a b
201 None False f@(FailAt x _ _) | x/=n -> None True f
204 -- If first alternative gives partial parse it's a failure
205 p |!! q = mustAll p ||! q
208 many :: Parser a b -> Parser a [b]
209 many p = p `into` (\v-> many p `act` (v:))
212 many1 :: Parser a b -> Parser a [b]
213 many1 p = p `into` (\v-> many p `act` (v:))
215 -- Parse an exact number of items
216 count :: Parser a b -> Int -> Parser a [b]
217 count p 0 = succeed []
218 count p k = p +.+ count p (k-1) >>> (:)
220 -- Non-empty sequence of items separated by something
221 sepBy1 :: Parser a b -> Parser a c -> Parser a [b]
222 p `sepBy1` q = p `into` (\v-> many (q ..+ p) `act` (v:)) -- p +.+ many (q ..+ p) >>> (:) is slower
224 -- Sequence of items separated by something
225 sepBy :: Parser a b -> Parser a c -> Parser a [b]
226 p `sepBy` q = p `sepBy1` q
229 -- Recognize a literal token
230 lit :: (Eq a, Text a) => a -> Parser [a] a
233 a:as' | a==x -> One a (n+1) as' noFail
234 _ -> None False (FailAt n [show x] as)
236 -- Recognize a token with a predicate
237 litp :: ErrMsg -> (a->Bool) -> Parser [a] a
240 a:as' | p a -> One a (n+1) as' noFail
241 _ -> None False (FailAt n [s] as)
243 -- Generic token recognizer
244 token :: (a -> Either ErrMsg (b,a)) -> Parser a b
247 Wrong s -> None False (FailAt n [s] as)
248 Right (b, as') -> One b (n+1) as' noFail
250 -- Test a semantic value
251 testp :: String -> (b->Bool) -> Parser a b -> Parser a b
252 testp s tst p = \ as n ->
255 o@(One b _ _ _) -> if tst b then o else None False (FailAt n [s] as)
257 case [ r | r@(b, _, _) <- bas, tst b] of
258 [] -> None False (FailAt n [s] as)
259 [(x,y,z)] -> One x y z f
262 -- Try error recovery.
263 recover :: Parser a b -> ([ErrMsg] -> a -> Maybe (a, b)) -> Parser a b
264 recover p f = \ as n ->
266 r@(None _ fa@(FailAt n ss ts)) ->
269 Just (a, b) -> One b (n+1) a fa
272 -- Parse, and check if it was ok.
273 parse :: Parser a b -> a -> Either ([ErrMsg],a) [(b, a)]
276 None w (FailAt _ ss ts) -> Wrong (ss,ts)
277 One b _ ts _ -> Right [(b,ts)]
278 Many bas _ -> Right [(b,ts) | (b,_,ts) <- bas ]
280 sParse :: (Text a) => Parser [a] b -> [a] -> Either String b
283 Wrong (ss,ts) -> Wrong ("Parse failed at token "++pshow ts++", expected "++unwords ss++"\n")
284 where pshow [] = "<EOF>"
286 Right ((b,[]):_) -> Right b
287 Right ((_,t:_):_) -> Wrong ("Parse failed at token "++show t++", expected <EOF>\n")
289 simpleParse :: (Text a) => Parser [a] b -> [a] -> b
292 Wrong msg -> error msg