-----------------------------------------------------------------------------
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE CPP                  #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Util.Parser
-- Copyright   :  (C) 2016-2025 David M. Johnson (@dmjio)
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <code@dmj.io>
-- Stability   :  experimental
-- Portability :  non-portable
----------------------------------------------------------------------------
module Miso.Util.Parser
  ( -- ** Types
    Parser
  , ParserT (..)
  , ParseError (..)
    -- ** Combinators
  , 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)]
----------------------------------------------------------------------------