implementation module StdParsComb import StdInt, StdBool, StdOverloaded, StdList, StdFunc, StdString :: Parser s r :== [s] -> ParsResult s r :: ParsResult s r :== [([s],r)] :: CParser s r t :== (SucCont s r t) (XorCont s t) (AltCont s t) -> Parser s t :: SucCont s r t :== r (XorCont s t) (AltCont s t) -> Parser s t :: XorCont s t :== (AltCont s t) -> ParsResult s t :: AltCont s t :== ParsResult s t fail :: CParser s r t fail = \ sc xc ac ss -> xc ac yield :: r -> CParser s r t yield x = \sc -> sc x cut :: (CParser s r t) -> CParser s r t cut p = \sc xc ac -> p sc (\ac -> ac) ac symbol :: s -> CParser s s t | == s symbol s = p where p sc xc ac [x:ss] | x==s = sc s xc ac ss p sc xc ac _ = xc ac token :: [s] -> CParser s [s] t | ==s token t = p where p sc xc ac ss | t == head = sc t xc ac tail | otherwise = xc ac where (head,tail) = splitAt (length t) ss satisfy :: (s->Bool) -> CParser s s t satisfy f = p where p sc xc ac [s:ss] | f s = sc s xc ac ss p sc xc ac _ = xc ac eof :: CParser s Int t eof = p where p sc xc ac [] = sc 42 xc ac [] p sc xc ac _ = xc ac begin :: !(CParser s t t) -> Parser s t begin p = p (\x xc ac ss -> [(ss,x):xc ac]) (\ac -> ac) [] (<|>) infixr 4 :: (CParser s r t) (CParser s r t) -> CParser s r t (<|>) p1 p2 = \sc xc ac ss -> p1 sc (\ac2 -> ac2) (p2 sc xc ac ss) ss () infixr 4 :: (CParser s r t) (CParser s r t) -> CParser s r t () p1 p2 = \sc xc ac ss -> p1 (\x xc2 -> sc x xc) (\ac3 -> p2 sc xc ac3 ss) ac ss (<&>) infixr 6 :: (CParser s u t) (u -> CParser s v t) -> CParser s v t (<&>) p1 p2 = \sc -> p1 (\t -> p2 t sc) (<&) infixr 6 :: (CParser s u t) (CParser s v t) -> CParser s u t (<&) p1 p2 = p1 <&> \u -> p2 <@ \_ -> u (&>) infixr 6 :: (CParser s u t) (CParser s v t) -> CParser s v t (&>) p1 p2 = p1 <&> \_ -> p2 (<:&>) infixr 6 :: (CParser s u t) (CParser s [u] t) -> CParser s [u] t (<:&>) p1 p2 = p1 <&> \h -> p2 <@ \t -> [h:t] (<++>) infixr 6 :: (CParser s [u] t) (CParser s [u] t) -> CParser s [u] t (<++>) p1 p2 = p1 <&> \l -> p2 <@ \m -> l++m () infixr 6 :: (CParser s u t) (u -> CParser s v t) -> CParser s v t () p1 p2 = \sc -> p1 (\t ac2 -> p2 t sc (\ac -> ac)) // Cut inside , if p1 succeeds, next alt is removed (<@) infixl 5 :: (CParser s r t) (r->u) -> CParser s u t (<@) p f = \sc -> p (sc o f) <*?> :: (CParser s r t) -> CParser s [r] t <*?> p = ( p <&> \r -> <*?> p <@ \rs -> [r:rs]) <|> yield [] <*> :: (CParser s r t) -> CParser s [r] t //<*> p = ( p \r -> // <*> p <@ \rs -> [r:rs]) // yield [] <*> p = ClistP p [] ClistP :: (CParser s r t) [r] -> CParser s [r] t ClistP p l // = (p \r -> ClistP p [r:l]) // yield (reverse l) = clp l where clp l sc xc ac ss = p (\r xc2 -> clp [r:l] sc (\ac -> ac)) (\ac3 -> sc (reverse l) xc ac3 ss) ac ss <+> :: (CParser s r t) -> CParser s [r] t //<+> p = p <&> \r -> <*> p <@ \rs -> [r:rs] <+> p = p <&> \r -> ClistP p [r] <+?> :: (CParser s r t) -> CParser s [r] t <+?> p = p <&> \r -> <*?> p <@ \rs -> [r:rs] :: (CParser s r t) -> CParser s [r] t // Eager version, if p succeeds use it! p = (p <@ \r -> [r]) yield [] :: (CParser s r t) (r->u) u -> CParser s u t p f u = (p <@ \r -> f r) yield u :: (CParser s r t) -> CParser s [r] t // Lazy version p = (p <@ \r -> [r]) <|> yield [] :: (CParser s r t) (r->u) u -> CParser s u t p f u = (p <@ \r -> f r) <|> yield u (>?<) infix 9 :: (CParser s r t) (r -> Bool) -> (CParser s r t) // condition on parsed item (>?<) p f = \sc -> p (\r xc2 ac2 ss2 -> if (f r) (sc r xc2 ac2 ss2) (xc2 ac2)) digit :: CParser Char Int x digit = satisfy isDigit <@ digitToInt nat :: CParser Char Int t nat = <+> digit <@ foldl (\x y -> x*10 + y) 0 int :: CParser Char Int t int = symbol '-' (\_ -> nat <@ ~) nat identifier :: CParser Char String t identifier = satisfy isAlpha <&> \c -> <*> (satisfy isAlphanum) <@ \r -> toString [c:r] sp :: (CParser Char r t) -> CParser Char r t sp p = \sc xc ac ss -> p sc xc ac (dropWhile isSpace ss) spsymbol :: Char -> CParser Char Char t spsymbol s = sp (symbol s) sptoken :: [Char] -> CParser Char [Char] t sptoken t = sp (token t) parseSequence :: (CParser a b c) (CParser a d c) -> CParser a [b] c parseSequence p1 p2 = p1 <:&> (<*> (p2 &> p1)) // accept one or more 'b''s sepparated by 'd''s; accumulate 'b''s in a list parseChainLeft :: (CParser a b c) (CParser a (b b -> b) c) -> CParser a b c parseChainLeft p1 p2 = p1 <&> chainl where chainl x = p2 <&> (\op -> p1 <&> (\y -> chainl (op x y))) yield x // p1 parses elements that are given to the function found by p2. Left associative. parseChainRight :: (CParser a b c) (CParser a (b b -> b) c) -> CParser a b c parseChainRight p1 p2 = p1 <&> chainr where chainr x = p2 <&> (\op -> p1 <&> (\y -> chainr y <@ op x)) yield x // p1 parses elements that are given to the function found by p2. Right associative. choice :: ![CParser a b c] -> CParser a b c // Apply the first parser from the list that succeeds choice l = foldl () fail l