{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE CPP #-}
module Miso.Util.Parser
(
Parser
, ParserT (..)
, ParseError (..)
, parse
, satisfy
, peek
, token_
, errorOut
, allTokens
, modifyTokens
, askParser
) where
#if __GLASGOW_HASKELL__ <= 881
import Control.Monad.Fail (MonadFail (..))
#endif
import Control.Applicative
import Miso.Util.Lexer (LexerError)
data ParseError a token
= UnexpectedParse [token]
| LexicalError LexerError
| Ambiguous [(a, [token])]
| NoParses token
| EmptyStream
deriving (Int -> ParseError a token -> ShowS
[ParseError a token] -> ShowS
ParseError a token -> String
(Int -> ParseError a token -> ShowS)
-> (ParseError a token -> String)
-> ([ParseError a token] -> ShowS)
-> Show (ParseError a token)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a token.
(Show a, Show token) =>
Int -> ParseError a token -> ShowS
forall a token.
(Show a, Show token) =>
[ParseError a token] -> ShowS
forall a token.
(Show a, Show token) =>
ParseError a token -> String
$cshowsPrec :: forall a token.
(Show a, Show token) =>
Int -> ParseError a token -> ShowS
showsPrec :: Int -> ParseError a token -> ShowS
$cshow :: forall a token.
(Show a, Show token) =>
ParseError a token -> String
show :: ParseError a token -> String
$cshowList :: forall a token.
(Show a, Show token) =>
[ParseError a token] -> ShowS
showList :: [ParseError a token] -> ShowS
Show, ParseError a token -> ParseError a token -> Bool
(ParseError a token -> ParseError a token -> Bool)
-> (ParseError a token -> ParseError a token -> Bool)
-> Eq (ParseError a token)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a token.
(Eq a, Eq token) =>
ParseError a token -> ParseError a token -> Bool
$c== :: forall a token.
(Eq a, Eq token) =>
ParseError a token -> ParseError a token -> Bool
== :: ParseError a token -> ParseError a token -> Bool
$c/= :: forall a token.
(Eq a, Eq token) =>
ParseError a token -> ParseError a token -> Bool
/= :: ParseError a token -> ParseError a token -> Bool
Eq)
parse :: Parser token a -> [token] -> Either (ParseError a token) a
parse :: forall token a.
Parser token a -> [token] -> Either (ParseError a token) a
parse Parser token a
_ [] = ParseError a token -> Either (ParseError a token) a
forall a b. a -> Either a b
Left ParseError a token
forall a token. ParseError a token
EmptyStream
parse Parser token a
parser [token]
tokens =
case Parser token a -> () -> [token] -> [(a, [token])]
forall r token (m :: * -> *) a.
ParserT r token m a -> r -> token -> m (a, token)
runParserT Parser token a
parser () [token]
tokens of
[] -> ParseError a token -> Either (ParseError a token) a
forall a b. a -> Either a b
Left (token -> ParseError a token
forall a token. token -> ParseError a token
NoParses ([token] -> token
forall a. HasCallStack => [a] -> a
last [token]
tokens))
[(a
x, [])] -> a -> Either (ParseError a token) a
forall a b. b -> Either a b
Right a
x
[(a
_, [token]
xs)] -> ParseError a token -> Either (ParseError a token) a
forall a b. a -> Either a b
Left ([token] -> ParseError a token
forall a token. [token] -> ParseError a token
UnexpectedParse [token]
xs)
[(a, [token])]
xs -> ParseError a token -> Either (ParseError a token) a
forall a b. a -> Either a b
Left ([(a, [token])] -> ParseError a token
forall a token. [(a, [token])] -> ParseError a token
Ambiguous [(a, [token])]
xs)
type Parser token a = ParserT () [token] [] a
newtype ParserT r token m a
= Parser
{ forall r token (m :: * -> *) a.
ParserT r token m a -> r -> token -> m (a, token)
runParserT :: r -> token -> m (a, token)
}
instance Functor (ParserT r token []) where
fmap :: forall a b.
(a -> b) -> ParserT r token [] a -> ParserT r token [] b
fmap a -> b
f (Parser r -> token -> [(a, token)]
run) = (r -> token -> [(b, token)]) -> ParserT r token [] b
forall r token (m :: * -> *) a.
(r -> token -> m (a, token)) -> ParserT r token m a
Parser ((r -> token -> [(b, token)]) -> ParserT r token [] b)
-> (r -> token -> [(b, token)]) -> ParserT r token [] b
forall a b. (a -> b) -> a -> b
$ \r
r token
input ->
case r -> token -> [(a, token)]
run r
r token
input of
[(a, token)]
tokens -> [ (a -> b
f a
x, token
toks) | (a
x, token
toks) <- [(a, token)]
tokens ]
instance Applicative (ParserT r token []) where
pure :: forall a. a -> ParserT r token [] a
pure a
x = (r -> token -> [(a, token)]) -> ParserT r token [] a
forall r token (m :: * -> *) a.
(r -> token -> m (a, token)) -> ParserT r token m a
Parser ((r -> token -> [(a, token)]) -> ParserT r token [] a)
-> (r -> token -> [(a, token)]) -> ParserT r token [] a
forall a b. (a -> b) -> a -> b
$ \r
_ token
s -> (a, token) -> [(a, token)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
x,token
s)
Parser r -> token -> [(a -> b, token)]
f <*> :: forall a b.
ParserT r token [] (a -> b)
-> ParserT r token [] a -> ParserT r token [] b
<*> Parser r -> token -> [(a, token)]
g = (r -> token -> [(b, token)]) -> ParserT r token [] b
forall r token (m :: * -> *) a.
(r -> token -> m (a, token)) -> ParserT r token m a
Parser ((r -> token -> [(b, token)]) -> ParserT r token [] b)
-> (r -> token -> [(b, token)]) -> ParserT r token [] b
forall a b. (a -> b) -> a -> b
$ \r
r token
input -> do
(k, s) <- r -> token -> [(a -> b, token)]
f r
r token
input
(x, t) <- g r s
pure (k x, t)
instance Alternative (ParserT r token []) where
empty :: forall a. ParserT r token [] a
empty = (r -> token -> [(a, token)]) -> ParserT r token [] a
forall r token (m :: * -> *) a.
(r -> token -> m (a, token)) -> ParserT r token m a
Parser ((r -> token -> [(a, token)]) -> ParserT r token [] a)
-> (r -> token -> [(a, token)]) -> ParserT r token [] a
forall a b. (a -> b) -> a -> b
$ \r
_ token
_ -> []
Parser r -> token -> [(a, token)]
f <|> :: forall a.
ParserT r token [] a
-> ParserT r token [] a -> ParserT r token [] a
<|> Parser r -> token -> [(a, token)]
g =
(r -> token -> [(a, token)]) -> ParserT r token [] a
forall r token (m :: * -> *) a.
(r -> token -> m (a, token)) -> ParserT r token m a
Parser ((r -> token -> [(a, token)]) -> ParserT r token [] a)
-> (r -> token -> [(a, token)]) -> ParserT r token [] a
forall a b. (a -> b) -> a -> b
$ \r
r token
tokens ->
case r -> token -> [(a, token)]
f r
r token
tokens of
[] -> r -> token -> [(a, token)]
g r
r token
tokens
[(a, token)]
x -> [(a, token)]
x
instance Monad (ParserT r token []) where
return :: forall a. a -> ParserT r token [] a
return = a -> ParserT r token [] a
forall a. a -> ParserT r token [] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
Parser r -> token -> [(a, token)]
f >>= :: forall a b.
ParserT r token [] a
-> (a -> ParserT r token [] b) -> ParserT r token [] b
>>= a -> ParserT r token [] b
k = (r -> token -> [(b, token)]) -> ParserT r token [] b
forall r token (m :: * -> *) a.
(r -> token -> m (a, token)) -> ParserT r token m a
Parser ((r -> token -> [(b, token)]) -> ParserT r token [] b)
-> (r -> token -> [(b, token)]) -> ParserT r token [] b
forall a b. (a -> b) -> a -> b
$ \r
r token
tokens -> do
(x, tokens') <- r -> token -> [(a, token)]
f r
r token
tokens
runParserT (k x) r tokens'
instance MonadFail (ParserT r token []) where
fail :: forall a. String -> ParserT r token [] a
fail String
_ = (r -> token -> [(a, token)]) -> ParserT r token [] a
forall r token (m :: * -> *) a.
(r -> token -> m (a, token)) -> ParserT r token m a
Parser ((r -> token -> [(a, token)]) -> ParserT r token [] a)
-> (r -> token -> [(a, token)]) -> ParserT r token [] a
forall a b. (a -> b) -> a -> b
$ \r
_ token
_ -> []
satisfy :: (a -> Bool) -> ParserT r [a] [] a
satisfy :: forall a r. (a -> Bool) -> ParserT r [a] [] a
satisfy a -> Bool
f = (r -> [a] -> [(a, [a])]) -> ParserT r [a] [] a
forall r token (m :: * -> *) a.
(r -> token -> m (a, token)) -> ParserT r token m a
Parser ((r -> [a] -> [(a, [a])]) -> ParserT r [a] [] a)
-> (r -> [a] -> [(a, [a])]) -> ParserT r [a] [] a
forall a b. (a -> b) -> a -> b
$ \r
_ [a]
input ->
case [a]
input of
a
t : [a]
ts | a -> Bool
f a
t -> [(a
t, [a]
ts)]
[a]
_ -> []
allTokens :: ParserT r a [] a
allTokens :: forall r a. ParserT r a [] a
allTokens = (r -> a -> [(a, a)]) -> ParserT r a [] a
forall r token (m :: * -> *) a.
(r -> token -> m (a, token)) -> ParserT r token m a
Parser ((r -> a -> [(a, a)]) -> ParserT r a [] a)
-> (r -> a -> [(a, a)]) -> ParserT r a [] a
forall a b. (a -> b) -> a -> b
$ \r
_ a
input -> [(a
input, a
input)]
modifyTokens :: (t -> t) -> ParserT r t [] ()
modifyTokens :: forall t r. (t -> t) -> ParserT r t [] ()
modifyTokens t -> t
f = (r -> t -> [((), t)]) -> ParserT r t [] ()
forall r token (m :: * -> *) a.
(r -> token -> m (a, token)) -> ParserT r token m a
Parser ((r -> t -> [((), t)]) -> ParserT r t [] ())
-> (r -> t -> [((), t)]) -> ParserT r t [] ()
forall a b. (a -> b) -> a -> b
$ \r
_ t
input -> [((), t -> t
f t
input)]
token_ :: Eq token => token -> Parser token token
token_ :: forall token. Eq token => token -> Parser token token
token_ token
t = (token -> Bool) -> ParserT () [token] [] token
forall a r. (a -> Bool) -> ParserT r [a] [] a
satisfy (token -> token -> Bool
forall a. Eq a => a -> a -> Bool
==token
t)
askParser :: ParserT r token [] r
askParser :: forall r token. ParserT r token [] r
askParser = (r -> token -> [(r, token)]) -> ParserT r token [] r
forall r token (m :: * -> *) a.
(r -> token -> m (a, token)) -> ParserT r token m a
Parser ((r -> token -> [(r, token)]) -> ParserT r token [] r)
-> (r -> token -> [(r, token)]) -> ParserT r token [] r
forall a b. (a -> b) -> a -> b
$ \r
r token
input -> [(r
r, token
input)]
peek :: Parser a a
peek :: forall a. Parser a a
peek = (() -> [a] -> [(a, [a])]) -> ParserT () [a] [] a
forall r token (m :: * -> *) a.
(r -> token -> m (a, token)) -> ParserT r token m a
Parser ((() -> [a] -> [(a, [a])]) -> ParserT () [a] [] a)
-> (() -> [a] -> [(a, [a])]) -> ParserT () [a] [] a
forall a b. (a -> b) -> a -> b
$ \()
_ [a]
tokens ->
case [a]
tokens of
[] -> []
(a
x:[a]
xs) -> [(a
x, a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)]
errorOut :: errorToken -> ParserT r errorToken [] ()
errorOut :: forall errorToken r. errorToken -> ParserT r errorToken [] ()
errorOut errorToken
x = (r -> errorToken -> [((), errorToken)])
-> ParserT r errorToken [] ()
forall r token (m :: * -> *) a.
(r -> token -> m (a, token)) -> ParserT r token m a
Parser ((r -> errorToken -> [((), errorToken)])
-> ParserT r errorToken [] ())
-> (r -> errorToken -> [((), errorToken)])
-> ParserT r errorToken [] ()
forall a b. (a -> b) -> a -> b
$ \r
_ errorToken
_ -> [((),errorToken
x)]