module Text.ParserCombinators.PolyState
(
Parser(P)
, runParser
, failBad
, commit
, next
, satisfy
, apply
, discard
, adjustErr
, adjustErrBad
, indent
, onFail
, oneOf
, oneOf'
, exactly
, many
, many1
, sepBy
, sepBy1
, bracketSep
, bracket
, manyFinally
, stUpdate
, stQuery
, stGet
, reparse
) where
newtype Parser s t a = P (s -> [t] -> (EitherE String a, s, [t]))
type EitherE a b = Either (Bool,a) b
runParser :: Parser s t a -> s -> [t] -> (Either String a, s, [t])
runParser (P p) s =
(\ (e,s,ts)-> (case e of Left (_,m)->Left m; Right m->Right m
,s,ts))
. p s
instance Functor (Parser s t) where
fmap f (P p) = P (\s ts-> case p s ts of
(Left msg, s', ts') -> (Left msg, s', ts')
(Right x, s', ts') -> (Right (f x), s', ts'))
instance Monad (Parser s t) where
return x = P (\s ts-> (Right x, s, ts))
(P f) >>= g = P (\s ts-> case f s ts of
(Left msg, s', ts') -> (Left msg, s', ts')
(Right x, s', ts') -> let (P g') = g x
in g' s' ts')
fail msg = P (\s ts-> (Left (False,msg), s, ts))
failBad :: String -> Parser s t a
failBad msg = P (\s ts-> (Left (True,msg), s, ts))
commit :: Parser s t a -> Parser s t a
commit (P p) = P (\s ts-> case p s ts of
(Left (_,e), s', ts') -> (Left (True,e), s', ts')
right -> right )
next :: Parser s t t
next = P (\s ts-> case ts of
[] -> (Left (False,"Ran out of input (EOF)"), s, [])
(t:ts') -> (Right t, s, ts') )
satisfy :: (t->Bool) -> Parser s t t
satisfy p = do{ x <- next
; if p x then return x else fail "Parse.satisfy: failed"
}
infixl 3 `apply`
apply :: Parser s t (a->b) -> Parser s t a -> Parser s t b
pf `apply` px = do { f <- pf; x <- px; return (f x) }
infixl 3 `discard`
discard :: Parser s t a -> Parser s t b -> Parser s t a
px `discard` py = do { x <- px; _ <- py; return x }
adjustErr :: Parser s t a -> (String->String) -> Parser s t a
(P p) `adjustErr` f =
P (\s ts-> case p s ts of
(Left (b,msg), s', ts') -> (Left (b,(f msg)), s, ts')
right -> right )
adjustErrBad :: Parser s t a -> (String->String) -> Parser s t a
(P p) `adjustErrBad` f =
P (\s ts-> case p s ts of
(Left (_,msg), s', ts') -> (Left (True,(f msg)), s, ts')
right -> right )
infixl 6 `onFail`
onFail :: Parser s t a -> Parser s t a -> Parser s t a
(P p) `onFail` (P q) = P (\s ts-> case p s ts of
r@(Left (True,_), _, _) -> r
(Left _, _, _) -> q s ts
right -> right )
oneOf :: [Parser s t a] -> Parser s t a
oneOf [] = fail ("Failed to parse any of the possible choices")
oneOf (p:ps) = p `onFail` oneOf ps
oneOf' :: [(String, Parser s t a)] -> Parser s t a
oneOf' = accum []
where accum errs [] =
case filter isBad errs of
[] -> fail ("failed to parse any of the possible choices:\n"
++indent 2 (concatMap showErr (reverse errs)))
[(_,(_,e))] -> failBad e
es -> failBad ("one of the following failures occurred:\n"
++indent 2 (concatMap showErr (reverse es)))
accum errs ((e,P p):ps) =
P (\u ts-> case p u ts of
(Left err,_,_) -> let (P p) = accum ((e,err):errs) ps
in p u ts
right -> right )
showErr (name,(_,err)) = name++":\n"++indent 2 err
isBad (_,(b,_)) = b
indent :: Int -> String -> String
indent n = unlines . map (replicate n ' ' ++) . lines
exactly :: Int -> Parser s t a -> Parser s t [a]
exactly 0 p = return []
exactly n p = do x <- p
xs <- exactly (n1) p
return (x:xs)
many :: Parser s t a -> Parser s t [a]
many p = many1 p `onFail` return []
many1 :: Parser s t a -> Parser s t [a]
many1 p = do { x <- p `adjustErr` (("In a sequence:\n"++). indent 2)
; xs <- many p
; return (x:xs)
}
sepBy :: Parser s t a -> Parser s t sep -> Parser s t [a]
sepBy p sep = do sepBy1 p sep `onFail` return []
sepBy1 :: Parser s t a -> Parser s t sep -> Parser s t [a]
sepBy1 p sep = do { x <- p
; xs <- many (do {sep; p})
; return (x:xs)
}
`adjustErr` ("When looking for a non-empty sequence with separators:\n"++)
bracketSep :: Parser s t bra -> Parser s t sep -> Parser s t ket
-> Parser s t a -> Parser s t [a]
bracketSep open sep close p =
do { open; close; return [] }
`onFail`
do { open `adjustErr` ("Missing opening bracket:\n"++)
; x <- p `adjustErr` ("After first bracket in a group:\n"++)
; xs <- many (do {sep; p})
; close `adjustErrBad` ("When looking for closing bracket:\n"++)
; return (x:xs)
}
bracket :: Parser s t bra -> Parser s t ket -> Parser s t a -> Parser s t a
bracket open close p = do
do { open `adjustErr` ("Missing opening bracket:\n"++)
; x <- p
; close `adjustErrBad` ("Missing closing bracket:\n"++)
; return x
}
manyFinally :: Parser s t a -> Parser s t z -> Parser s t [a]
manyFinally p t =
do { xs <- many p
; oneOf' [ ("sequence terminator", do { t; return () } )
, ("item in a sequence", do { p; return () } )
]
; return xs
}
stUpdate :: (s->s) -> Parser s t ()
stUpdate f = P (\s ts-> (Right (), f s, ts))
stQuery :: (s->a) -> Parser s t a
stQuery f = P (\s ts-> (Right (f s), s, ts))
stGet :: Parser s t s
stGet = P (\s ts-> (Right s, s, ts))
reparse :: [t] -> Parser s t ()
reparse ts = P (\s inp-> (Right (), s, ts++inp))