-- | This module contains the definitions for a generic parser, without
--   running state.  These are the parts that are shared between the Plain
--   and Lazy variations.  Do not import this module directly, but only
--   via T.P.Poly.Plain or T.P.Poly.Lazy.
module Text.ParserCombinators.Poly.Parser
  ( -- * The Parser datatype
    Parser(P)	-- datatype, instance of: Functor, Monad, PolyParse
  , Result(..)	-- internal to the Parser Monad.
    -- ** Basic parsers
  , next	-- :: Parser t t
  , eof		-- :: Parser t ()
  , satisfy	-- :: (t->Bool) -> Parser t t
  , satisfyMsg	-- :: Show t => (t->Bool) -> String -> Parser t t
  , onFail      -- :: Parser t a -> Parser t a -> Parser t a

    -- ** Re-parsing
  , reparse	-- :: [t] -> Parser t ()
  ) where

import Text.ParserCombinators.Poly.Base
import Text.ParserCombinators.Poly.Result
import Control.Applicative
import qualified Control.Monad.Fail as Fail

-- | This @Parser@ datatype is a fairly generic parsing monad with error
--   reporting.  It can be used for arbitrary token types, not just
--   String input.  (If you require a running state, use module Poly.State
--   instead)
newtype Parser t a = P ([t] -> Result [t] a)

instance Functor (Parser t) where
    fmap :: (a -> b) -> Parser t a -> Parser t b
fmap a -> b
f (P [t] -> Result [t] a
p) = ([t] -> Result [t] b) -> Parser t b
forall t a. ([t] -> Result [t] a) -> Parser t a
P ((a -> b) -> Result [t] a -> Result [t] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Result [t] a -> Result [t] b)
-> ([t] -> Result [t] a) -> [t] -> Result [t] b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [t] -> Result [t] a
p)

instance Applicative (Parser t) where
    pure :: a -> Parser t a
pure a
x    = ([t] -> Result [t] a) -> Parser t a
forall t a. ([t] -> Result [t] a) -> Parser t a
P (\[t]
ts-> [t] -> a -> Result [t] a
forall z a. z -> a -> Result z a
Success [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 Monad (Parser t) where
    return :: a -> Parser t a
return       = a -> Parser t a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (P [t] -> Result [t] a
f) >>= :: Parser t a -> (a -> Parser t b) -> Parser t b
>>= a -> Parser t b
g  = ([t] -> Result [t] b) -> Parser t b
forall t a. ([t] -> Result [t] a) -> Parser t a
P (Result [t] a -> Result [t] b
continue (Result [t] a -> Result [t] b)
-> ([t] -> Result [t] a) -> [t] -> Result [t] b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [t] -> Result [t] a
f)
      where
        continue :: Result [t] a -> Result [t] b
continue (Success [t]
ts a
x)             = let (P [t] -> Result [t] b
g') = a -> Parser t b
g a
x in [t] -> Result [t] b
g' [t]
ts
        continue (Committed Result [t] a
r)              = Result [t] b -> Result [t] b
forall z a. Result z a -> Result z a
Committed (Result [t] a -> Result [t] b
continue Result [t] a
r)
        continue (Failure [t]
ts String
e)             = [t] -> String -> Result [t] b
forall z a. z -> String -> Result z a
Failure [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       = ([t] -> Result [t] a) -> Parser t a
forall t a. ([t] -> Result [t] a) -> Parser t a
P (\[t]
ts-> [t] -> String -> Result [t] a
forall z a. z -> String -> Result z a
Failure [t]
ts String
e)

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)

instance Commitment (Parser t) where
    commit :: Parser t a -> Parser t a
commit (P [t] -> Result [t] a
p)         = ([t] -> Result [t] a) -> Parser t a
forall t a. ([t] -> Result [t] a) -> Parser t a
P (Result [t] a -> Result [t] a
forall z a. Result z a -> Result z a
Committed (Result [t] a -> Result [t] a)
-> ([t] -> Result [t] a) -> [t] -> Result [t] a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result [t] a -> Result [t] a
forall z a. Result z a -> Result z a
squash (Result [t] a -> Result [t] a)
-> ([t] -> Result [t] a) -> [t] -> Result [t] a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [t] -> Result [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 [t] -> Result [t] a
p) adjustErr :: Parser t a -> (String -> String) -> Parser t a
`adjustErr` String -> String
f  = ([t] -> Result [t] a) -> Parser t a
forall t a. ([t] -> Result [t] a) -> Parser t a
P (Result [t] a -> Result [t] a
forall z a. Result z a -> Result z a
adjust (Result [t] a -> Result [t] a)
-> ([t] -> Result [t] a) -> [t] -> Result [t] a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [t] -> Result [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
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String, String) -> String
showErr ([(String, String)] -> [(String, String)]
forall a. [a] -> [a]
reverse [(String, String)]
errs)))
            accum [(String, String)]
errs ((String
e,P [t] -> Result [t] a
p):[(String, Parser t a)]
ps) =
                ([t] -> Result [t] a) -> Parser t a
forall t a. ([t] -> Result [t] a) -> Parser t a
P (\[t]
ts-> case [t] -> Result [t] a
p [t]
ts of
                           Failure [t]
_ String
err ->
                                       let (P [t] -> Result [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 [t] -> Result [t] a
p [t]
ts
                           r :: Result [t] a
r@(Success [t]
z a
a)    -> Result [t] a
r
                           r :: Result [t] a
r@(Committed Result [t] a
_)    -> Result [t] a
r )
            showErr :: (String, String) -> String
showErr (String
name,String
err) = String
nameString -> 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`	-- not sure about precedence 6?

-- | @p `onFail` q@ means parse p, unless p fails, in which case
--   parse q instead.
--   Can be chained together to give multiple attempts to parse something.
--   (Note that q could itself be a failing parser, e.g. to change the error
--   message from that defined in p to something different.)
--   However, a severe failure in p cannot be ignored.
onFail :: Parser t a -> Parser t a -> Parser t a
(P [t] -> Result [t] a
p) onFail :: Parser t a -> Parser t a -> Parser t a
`onFail` (P [t] -> Result [t] a
q) = ([t] -> Result [t] a) -> Parser t a
forall t a. ([t] -> Result [t] a) -> Parser t a
P (\[t]
ts-> [t] -> Result [t] a -> Result [t] a
continue [t]
ts (Result [t] a -> Result [t] a) -> Result [t] a -> Result [t] a
forall a b. (a -> b) -> a -> b
$ [t] -> Result [t] a
p [t]
ts)
  where
    continue :: [t] -> Result [t] a -> Result [t] a
continue [t]
ts (Failure [t]
z String
e) = [t] -> Result [t] a
q [t]
ts
--  continue _  (Committed r) = r   -- no, remain Committed
    continue [t]
_  Result [t] a
r             = Result [t] a
r


------------------------------------------------------------------------

-- | Simply return the next token in the input tokenstream.
next :: Parser t t
next :: Parser t t
next = ([t] -> Result [t] t) -> Parser t t
forall t a. ([t] -> Result [t] a) -> Parser t a
P (\[t]
ts-> case [t]
ts of
                  []      -> [t] -> String -> Result [t] t
forall z a. z -> String -> Result z a
Failure [] String
"Ran out of input (EOF)"
                  (t
t:[t]
ts') -> [t] -> t -> Result [t] t
forall z a. z -> a -> Result z a
Success [t]
ts' t
t )

-- | Succeed if the end of file/input has been reached, fail otherwise.
eof  :: Parser t ()
eof :: Parser t ()
eof  = ([t] -> Result [t] ()) -> Parser t ()
forall t a. ([t] -> Result [t] a) -> Parser t a
P (\[t]
ts-> case [t]
ts of
                  []      -> [t] -> () -> Result [t] ()
forall z a. z -> a -> Result z a
Success [] ()
                  (t
t:[t]
ts') -> [t] -> String -> Result [t] ()
forall z a. z -> String -> Result z a
Failure [t]
ts String
"Expected end of input (EOF)" )

-- | Return the next token if it satisfies the given predicate.
satisfy :: (t->Bool) -> Parser t t
satisfy :: (t -> Bool) -> Parser t t
satisfy t -> Bool
pred = do { t
x <- Parser t t
forall t. Parser t t
next
                  ; if t -> Bool
pred 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"
                  }

-- | Return the next token if it satisfies the given predicate.  The
--   String argument describes the function, for better error messages.
satisfyMsg :: Show t => (t->Bool) -> String -> Parser t t
satisfyMsg :: (t -> Bool) -> String -> Parser t t
satisfyMsg t -> Bool
pred String
s
             = do { t
x <- Parser t t
forall t. Parser t t
next
                  ; if t -> Bool
pred 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 -> Parser t t) -> String -> Parser t t
forall a b. (a -> b) -> a -> b
$ String
"Parse.satisfy ("String -> String -> String
forall a. [a] -> [a] -> [a]
++String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++String
") ("
                                                           String -> String -> String
forall a. [a] -> [a] -> [a]
++t -> String
forall a. Show a => a -> String
show t
xString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"): failed"
                  }

------------------------------------------------------------------------

-- | Push some tokens back onto the front of the input stream and reparse.
--   This is useful e.g. for recursively expanding macros.  When the
--   user-parser recognises a macro use, it can lookup the macro
--   expansion from the parse state, lex it, and then stuff the
--   lexed expansion back down into the parser.
reparse    :: [t] -> Parser t ()
reparse :: [t] -> Parser t ()
reparse [t]
ts  = ([t] -> Result [t] ()) -> Parser t ()
forall t a. ([t] -> Result [t] a) -> Parser t a
P (\[t]
inp-> [t] -> () -> Result [t] ()
forall z a. z -> a -> Result z a
Success ([t]
ts[t] -> [t] -> [t]
forall a. [a] -> [a] -> [a]
++[t]
inp) ())

------------------------------------------------------------------------