module Text.ParserCombinators.Poly.Lex
(
LexReturn(..)
, Parser(P)
, Result(..)
, runParser
, next
, eof
, satisfy
, onFail
, reparse
, module Text.ParserCombinators.Poly.Base
, module Control.Applicative
) where
import Text.ParserCombinators.Poly.Base
import Text.ParserCombinators.Poly.Result
import Control.Applicative
import qualified Control.Monad.Fail as Fail
data LexReturn t = LexReturn t String (String->LexReturn t)
| LexFinish
newtype Parser t a = P (LexReturn t -> Result (LexReturn t) a)
runParser :: Parser t a -> LexReturn t -> (Either String a, String)
runParser :: Parser t a -> LexReturn t -> (Either String a, String)
runParser (P LexReturn t -> Result (LexReturn t) a
p) = (\ (Either String a
a,LexReturn t
b)->(Either String a
a,LexReturn t -> String
forall t. LexReturn t -> String
stripLex LexReturn t
b)) ((Either String a, LexReturn t) -> (Either String a, String))
-> (LexReturn t -> (Either String a, LexReturn t))
-> LexReturn t
-> (Either String a, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result (LexReturn t) a -> (Either String a, LexReturn t)
forall z a. Result z a -> (Either String a, z)
resultToEither (Result (LexReturn t) a -> (Either String a, LexReturn t))
-> (LexReturn t -> Result (LexReturn t) a)
-> LexReturn t
-> (Either String a, LexReturn t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LexReturn t -> Result (LexReturn t) a
p
where stripLex :: LexReturn t -> String
stripLex LexReturn t
LexFinish = String
""
stripLex (LexReturn t
_ String
s String -> LexReturn t
_) = String
s
instance Functor (Parser t) where
fmap :: (a -> b) -> Parser t a -> Parser t b
fmap a -> b
f (P LexReturn t -> Result (LexReturn t) a
p) = (LexReturn t -> Result (LexReturn t) b) -> Parser t b
forall t a. (LexReturn t -> Result (LexReturn t) a) -> Parser t a
P ((a -> b) -> Result (LexReturn t) a -> Result (LexReturn t) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Result (LexReturn t) a -> Result (LexReturn t) b)
-> (LexReturn t -> Result (LexReturn t) a)
-> LexReturn t
-> Result (LexReturn t) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LexReturn t -> Result (LexReturn t) a
p)
instance Monad (Parser t) where
return :: a -> Parser t a
return = a -> Parser t a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(P LexReturn t -> Result (LexReturn t) a
f) >>= :: Parser t a -> (a -> Parser t b) -> Parser t b
>>= a -> Parser t b
g = (LexReturn t -> Result (LexReturn t) b) -> Parser t b
forall t a. (LexReturn t -> Result (LexReturn t) a) -> Parser t a
P (Result (LexReturn t) a -> Result (LexReturn t) b
continue (Result (LexReturn t) a -> Result (LexReturn t) b)
-> (LexReturn t -> Result (LexReturn t) a)
-> LexReturn t
-> Result (LexReturn t) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LexReturn t -> Result (LexReturn t) a
f)
where
continue :: Result (LexReturn t) a -> Result (LexReturn t) b
continue (Success LexReturn t
ts a
x) = let (P LexReturn t -> Result (LexReturn t) b
g') = a -> Parser t b
g a
x in LexReturn t -> Result (LexReturn t) b
g' LexReturn t
ts
continue (Committed Result (LexReturn t) a
r) = Result (LexReturn t) b -> Result (LexReturn t) b
forall z a. Result z a -> Result z a
Committed (Result (LexReturn t) a -> Result (LexReturn t) b
continue Result (LexReturn t) a
r)
continue (Failure LexReturn t
ts String
e) = LexReturn t -> String -> Result (LexReturn t) b
forall z a. z -> String -> Result z a
Failure LexReturn t
ts String
e
#if !MIN_VERSION_base(4,13,0)
fail = Fail.fail
#endif
instance Fail.MonadFail (Parser t) where
fail :: String -> Parser t a
fail String
e = (LexReturn t -> Result (LexReturn t) a) -> Parser t a
forall t a. (LexReturn t -> Result (LexReturn t) a) -> Parser t a
P (\LexReturn t
ts-> LexReturn t -> String -> Result (LexReturn t) a
forall z a. z -> String -> Result z a
Failure LexReturn t
ts String
e)
instance Commitment (Parser t) where
commit :: Parser t a -> Parser t a
commit (P LexReturn t -> Result (LexReturn t) a
p) = (LexReturn t -> Result (LexReturn t) a) -> Parser t a
forall t a. (LexReturn t -> Result (LexReturn t) a) -> Parser t a
P (Result (LexReturn t) a -> Result (LexReturn t) a
forall z a. Result z a -> Result z a
Committed (Result (LexReturn t) a -> Result (LexReturn t) a)
-> (LexReturn t -> Result (LexReturn t) a)
-> LexReturn t
-> Result (LexReturn t) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result (LexReturn t) a -> Result (LexReturn t) a
forall z a. Result z a -> Result z a
squash (Result (LexReturn t) a -> Result (LexReturn t) a)
-> (LexReturn t -> Result (LexReturn t) a)
-> LexReturn t
-> Result (LexReturn t) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LexReturn t -> Result (LexReturn t) a
p)
where
squash :: Result z a -> Result z a
squash (Committed Result z a
r) = Result z a -> Result z a
squash Result z a
r
squash Result z a
r = Result z a
r
(P LexReturn t -> Result (LexReturn t) a
p) adjustErr :: Parser t a -> (String -> String) -> Parser t a
`adjustErr` String -> String
f = (LexReturn t -> Result (LexReturn t) a) -> Parser t a
forall t a. (LexReturn t -> Result (LexReturn t) a) -> Parser t a
P (Result (LexReturn t) a -> Result (LexReturn t) a
forall z a. Result z a -> Result z a
adjust (Result (LexReturn t) a -> Result (LexReturn t) a)
-> (LexReturn t -> Result (LexReturn t) a)
-> LexReturn t
-> Result (LexReturn t) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LexReturn t -> Result (LexReturn t) a
p)
where
adjust :: Result z a -> Result z a
adjust (Failure z
z String
e) = z -> String -> Result z a
forall z a. z -> String -> Result z a
Failure z
z (String -> String
f String
e)
adjust (Committed Result z a
r) = Result z a -> Result z a
forall z a. Result z a -> Result z a
Committed (Result z a -> Result z a
adjust Result z a
r)
adjust Result z a
good = Result z a
good
oneOf' :: [(String, Parser t a)] -> Parser t a
oneOf' = [(String, String)] -> [(String, Parser t a)] -> Parser t a
forall t a.
[(String, String)] -> [(String, Parser t a)] -> Parser t a
accum []
where accum :: [(String, String)] -> [(String, Parser t a)] -> Parser t a
accum [(String, String)]
errs [] =
String -> Parser t a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"failed to parse any of the possible choices:\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++(Int -> String -> String
indent Int
2 (String -> String)
-> ([(String, String)] -> String) -> [(String, String)] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String)
-> ([(String, String)] -> [String]) -> [(String, String)] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
showErr ([(String, String)] -> [String])
-> ([(String, String)] -> [(String, String)])
-> [(String, String)]
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, String)] -> [(String, String)]
forall a. [a] -> [a]
reverse ([(String, String)] -> String) -> [(String, String)] -> String
forall a b. (a -> b) -> a -> b
$ [(String, String)]
errs))
accum [(String, String)]
errs ((String
e,P LexReturn t -> Result (LexReturn t) a
p):[(String, Parser t a)]
ps) =
(LexReturn t -> Result (LexReturn t) a) -> Parser t a
forall t a. (LexReturn t -> Result (LexReturn t) a) -> Parser t a
P (\LexReturn t
ts-> case LexReturn t -> Result (LexReturn t) a
p LexReturn t
ts of
Failure LexReturn t
_ String
err ->
let (P LexReturn t -> Result (LexReturn t) a
p') = [(String, String)] -> [(String, Parser t a)] -> Parser t a
accum ((String
e,String
err)(String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
:[(String, String)]
errs) [(String, Parser t a)]
ps
in LexReturn t -> Result (LexReturn t) a
p' LexReturn t
ts
r :: Result (LexReturn t) a
r@(Success LexReturn t
_ a
_) -> Result (LexReturn t) a
r
r :: Result (LexReturn t) a
r@(Committed Result (LexReturn t) a
_) -> Result (LexReturn t) a
r )
showErr :: (String, String) -> String
showErr (String
name,String
err) = String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
indent Int
2 String
err
infixl 6 `onFail`
(P LexReturn t -> Result (LexReturn t) a
p) onFail :: Parser t a -> Parser t a -> Parser t a
`onFail` (P LexReturn t -> Result (LexReturn t) a
q) = (LexReturn t -> Result (LexReturn t) a) -> Parser t a
forall t a. (LexReturn t -> Result (LexReturn t) a) -> Parser t a
P (\LexReturn t
ts-> LexReturn t -> Result (LexReturn t) a -> Result (LexReturn t) a
continue LexReturn t
ts (Result (LexReturn t) a -> Result (LexReturn t) a)
-> Result (LexReturn t) a -> Result (LexReturn t) a
forall a b. (a -> b) -> a -> b
$ LexReturn t -> Result (LexReturn t) a
p LexReturn t
ts)
where
continue :: LexReturn t -> Result (LexReturn t) a -> Result (LexReturn t) a
continue LexReturn t
ts (Failure LexReturn t
_ String
_) = LexReturn t -> Result (LexReturn t) a
q LexReturn t
ts
continue LexReturn t
_ Result (LexReturn t) a
r = Result (LexReturn t) a
r
instance Applicative (Parser t) where
pure :: a -> Parser t a
pure a
x = (LexReturn t -> Result (LexReturn t) a) -> Parser t a
forall t a. (LexReturn t -> Result (LexReturn t) a) -> Parser t a
P (\LexReturn t
ts-> LexReturn t -> a -> Result (LexReturn t) a
forall z a. z -> a -> Result z a
Success LexReturn t
ts a
x)
Parser t (a -> b)
pf <*> :: Parser t (a -> b) -> Parser t a -> Parser t b
<*> Parser t a
px = do { a -> b
f <- Parser t (a -> b)
pf; a
x <- Parser t a
px; b -> Parser t b
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
f a
x) }
#if defined(GLASGOW_HASKELL) && GLASGOW_HASKELL > 610
p <* q = p `discard` q
#endif
instance Alternative (Parser t) where
empty :: Parser t a
empty = String -> Parser t a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no parse"
Parser t a
p <|> :: Parser t a -> Parser t a -> Parser t a
<|> Parser t a
q = Parser t a
p Parser t a -> Parser t a -> Parser t a
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` Parser t a
q
instance PolyParse (Parser t)
next :: Parser t t
next :: Parser t t
next = (LexReturn t -> Result (LexReturn t) t) -> Parser t t
forall t a. (LexReturn t -> Result (LexReturn t) a) -> Parser t a
P (\LexReturn t
ts-> case LexReturn t
ts of
LexReturn t
LexFinish -> LexReturn t -> String -> Result (LexReturn t) t
forall z a. z -> String -> Result z a
Failure LexReturn t
ts String
"Ran out of input (EOF)"
LexReturn t
t String
s String -> LexReturn t
k -> LexReturn t -> t -> Result (LexReturn t) t
forall z a. z -> a -> Result z a
Success (String -> LexReturn t
k String
s) t
t)
eof :: Parser t ()
eof :: Parser t ()
eof = (LexReturn t -> Result (LexReturn t) ()) -> Parser t ()
forall t a. (LexReturn t -> Result (LexReturn t) a) -> Parser t a
P (\LexReturn t
ts -> case LexReturn t
ts of
LexReturn t
LexFinish -> LexReturn t -> () -> Result (LexReturn t) ()
forall z a. z -> a -> Result z a
Success LexReturn t
ts ()
LexReturn t
_ String
_ String -> LexReturn t
_ -> LexReturn t -> String -> Result (LexReturn t) ()
forall z a. z -> String -> Result z a
Failure LexReturn t
ts String
"Expected end of input (EOF)" )
satisfy :: (t -> Bool) -> Parser t t
satisfy :: (t -> Bool) -> Parser t t
satisfy t -> Bool
f = do { t
x <- Parser t t
forall t. Parser t t
next
; if t -> Bool
f t
x then t -> Parser t t
forall (m :: * -> *) a. Monad m => a -> m a
return t
x else String -> Parser t t
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Parse.satisfy: failed"
}
reparse :: [t] -> Parser t ()
reparse :: [t] -> Parser t ()
reparse [t]
ts = (LexReturn t -> Result (LexReturn t) ()) -> Parser t ()
forall t a. (LexReturn t -> Result (LexReturn t) a) -> Parser t a
P (\LexReturn t
inp-> LexReturn t -> () -> Result (LexReturn t) ()
forall z a. z -> a -> Result z a
Success ([t]
ts [t] -> LexReturn t -> LexReturn t
forall t. [t] -> LexReturn t -> LexReturn t
`prefix` LexReturn t
inp) ())
where
(t
t:[t]
ts) prefix :: [t] -> LexReturn t -> LexReturn t
`prefix` LexReturn t
k = t -> String -> (String -> LexReturn t) -> LexReturn t
forall t. t -> String -> (String -> LexReturn t) -> LexReturn t
LexReturn t
t String
"" (LexReturn t -> String -> LexReturn t
forall a b. a -> b -> a
const ([t]
ts [t] -> LexReturn t -> LexReturn t
`prefix` LexReturn t
k))
[] `prefix` LexReturn t
k = LexReturn t
k