-----------------------------------------------------------------------------
{-# 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 (..)
  , ParseError (..)
    -- ** Combinators
  , parse
  , satisfy
  , peek
  , token_
  ) 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 [([token], a)]
  | 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] -> [([token], a)]
forall token a. Parser token a -> [token] -> [([token], a)]
runParser 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
    [([token]
xs, a
_)] -> 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)
    [([token], a)]
xs        -> ParseError a token -> Either (ParseError a token) a
forall a b. a -> Either a b
Left ([([token], a)] -> ParseError a token
forall a token. [([token], a)] -> ParseError a token
Ambiguous [([token], a)]
xs)
----------------------------------------------------------------------------
newtype Parser token a
  = Parser
  { forall token a. Parser token a -> [token] -> [([token], a)]
runParser :: [token] -> [([token], a)]
  }
----------------------------------------------------------------------------
instance Functor (Parser token) where
  fmap :: forall a b. (a -> b) -> Parser token a -> Parser token b
fmap a -> b
f (Parser [token] -> [([token], a)]
run) = ([token] -> [([token], b)]) -> Parser token b
forall token a. ([token] -> [([token], a)]) -> Parser token a
Parser (([token] -> [([token], b)]) -> Parser token b)
-> ([token] -> [([token], b)]) -> Parser token b
forall a b. (a -> b) -> a -> b
$ \[token]
input ->
    (a -> b) -> ([token], a) -> ([token], b)
forall a b. (a -> b) -> ([token], a) -> ([token], b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (([token], a) -> ([token], b)) -> [([token], a)] -> [([token], b)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [token] -> [([token], a)]
run [token]
input
----------------------------------------------------------------------------
instance Applicative (Parser token) where
  pure :: forall a. a -> Parser token a
pure a
x = ([token] -> [([token], a)]) -> Parser token a
forall token a. ([token] -> [([token], a)]) -> Parser token a
Parser (([token] -> [([token], a)]) -> Parser token a)
-> ([token] -> [([token], a)]) -> Parser token a
forall a b. (a -> b) -> a -> b
$ \[token]
s -> ([token], a) -> [([token], a)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([token]
s, a
x)
  Parser [token] -> [([token], a -> b)]
f <*> :: forall a b.
Parser token (a -> b) -> Parser token a -> Parser token b
<*> Parser [token] -> [([token], a)]
g = ([token] -> [([token], b)]) -> Parser token b
forall token a. ([token] -> [([token], a)]) -> Parser token a
Parser (([token] -> [([token], b)]) -> Parser token b)
-> ([token] -> [([token], b)]) -> Parser token b
forall a b. (a -> b) -> a -> b
$ \[token]
input -> do
    (s, k) <- [token] -> [([token], a -> b)]
f [token]
input
    (t, x) <- g s
    pure (t, k x)
----------------------------------------------------------------------------
instance Alternative (Parser token) where
  empty :: forall a. Parser token a
empty = ([token] -> [([token], a)]) -> Parser token a
forall token a. ([token] -> [([token], a)]) -> Parser token a
Parser (([token] -> [([token], a)]) -> Parser token a)
-> ([token] -> [([token], a)]) -> Parser token a
forall a b. (a -> b) -> a -> b
$ \[token]
_ -> []
  Parser [token] -> [([token], a)]
f <|> :: forall a. Parser token a -> Parser token a -> Parser token a
<|> Parser [token] -> [([token], a)]
g =
    ([token] -> [([token], a)]) -> Parser token a
forall token a. ([token] -> [([token], a)]) -> Parser token a
Parser (([token] -> [([token], a)]) -> Parser token a)
-> ([token] -> [([token], a)]) -> Parser token a
forall a b. (a -> b) -> a -> b
$ \[token]
tokens ->
      case [token] -> [([token], a)]
f [token]
tokens of
        [] -> [token] -> [([token], a)]
g [token]
tokens
        [([token], a)]
r  -> [([token], a)]
r
----------------------------------------------------------------------------
instance Monad (Parser token) where
  return :: forall a. a -> Parser token a
return = a -> Parser token a
forall a. a -> Parser token a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Parser [token] -> [([token], a)]
f >>= :: forall a b.
Parser token a -> (a -> Parser token b) -> Parser token b
>>= a -> Parser token b
k = ([token] -> [([token], b)]) -> Parser token b
forall token a. ([token] -> [([token], a)]) -> Parser token a
Parser (([token] -> [([token], b)]) -> Parser token b)
-> ([token] -> [([token], b)]) -> Parser token b
forall a b. (a -> b) -> a -> b
$ \[token]
tokens -> do
    (tokens', x) <- [token] -> [([token], a)]
f [token]
tokens
    runParser (k x) tokens'
----------------------------------------------------------------------------
#if __GLASGOW_HASKELL__ <= 881
instance MonadFail (Parser token) where
  fail _ = Parser $ \_ -> []
#endif
----------------------------------------------------------------------------
satisfy :: (token -> Bool) -> Parser token token
satisfy :: forall token. (token -> Bool) -> Parser token token
satisfy token -> Bool
f = ([token] -> [([token], token)]) -> Parser token token
forall token a. ([token] -> [([token], a)]) -> Parser token a
Parser (([token] -> [([token], token)]) -> Parser token token)
-> ([token] -> [([token], token)]) -> Parser token token
forall a b. (a -> b) -> a -> b
$ \[token]
input ->
  case [token]
input of
    token
t : [token]
ts | token -> Bool
f token
t -> [([token]
ts, token
t)]
    [token]
_ -> []
----------------------------------------------------------------------------
token_ :: Eq token => token -> Parser token token
token_ :: forall token. Eq token => token -> Parser token token
token_ token
t = (token -> Bool) -> Parser token token
forall token. (token -> Bool) -> Parser token token
satisfy (token -> token -> Bool
forall a. Eq a => a -> a -> Bool
==token
t)
----------------------------------------------------------------------------
peek :: Parser a a
peek :: forall a. Parser a a
peek = ([a] -> [([a], a)]) -> Parser a a
forall token a. ([token] -> [([token], a)]) -> Parser token a
Parser (([a] -> [([a], a)]) -> Parser a a)
-> ([a] -> [([a], a)]) -> Parser a a
forall a b. (a -> b) -> a -> b
$ \[a]
tokens ->
  case [a]
tokens of
    [] -> []
    (a
x:[a]
xs) -> [(a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs,a
x)]
----------------------------------------------------------------------------