{-----------------------------------------------------------------------------

                 A LIBRARY OF MONADIC PARSER COMBINATORS

                              29th July 1996

                 Graham Hutton               Erik Meijer
            University of Nottingham    University of Utrecht

This Haskell 1.3 script defines a library of parser combinators, and is taken
from sections 1-6 of our article "Monadic Parser Combinators".  Some changes
to the library have been made in the move from Gofer to Haskell:

   * Do notation is used in place of monad comprehension notation;

   * The parser datatype is defined using "newtype", to avoid the overhead
     of tagging and untagging parsers with the P constructor.

------------------------------------------------------------------------------
** Extended to allow a symbol table/state to be threaded through the monad.
** Extended to allow a parameterised token type, rather than just strings.
** Extended to allow error-reporting.

(Extensions: 1998-2000 Malcolm.Wallace@cs.york.ac.uk)
(More extensions: 2004 gk-haskell@ninebynine.org)

------------------------------------------------------------------------------}

-- | This library of monadic parser combinators is based on the ones
--   defined by Graham Hutton and Erik Meijer.  It has been extended by
--   Malcolm Wallace to use an abstract token type (no longer just a
--   string) as input, and to incorporate state in the monad, useful
--   for symbol tables, macros, and so on.  Basic facilities for error
--   reporting have also been added, and later extended by Graham Klyne
--   to return the errors through an @Either@ type, rather than just
--   calling @error@.

module Text.ParserCombinators.HuttonMeijerWallace
  (
  -- * The parser monad
    Parser(..)
  -- * Primitive parser combinators
  , item, eof, papply, papply'
  -- * Derived combinators
  , (+++), {-sat,-} tok, nottok, many, many1
  , sepby, sepby1, chainl, chainl1, chainr, chainr1, ops, bracket
  , toEOF
  -- * Error handling
  , elserror
  -- * State handling
  , stupd, stquery, stget
  -- * Re-parsing
  , reparse
  ) where

import Data.Char
import Control.Applicative ( Applicative(pure,(<*>)), Alternative(empty,(<|>)) )
import Control.Monad
import qualified Control.Monad.Fail as Fail

infixr 5 +++

--- The parser monad ---------------------------------------------------------

type ParseResult s t e a = Either e [(a,s,[Either e t])]

newtype Parser s t e a   = P ( s -> [Either e t] -> ParseResult s t e a )
    -- ^ The parser type is parametrised on the types of the state @s@,
    --   the input tokens @t@, error-type @e@, and the result value @a@.
    --   The state and remaining input are threaded through the monad.

instance Functor (Parser s t e) where
   -- fmap        :: (a -> b) -> (Parser s t e a -> Parser s t e b)
   fmap f (P p)    = P (\st inp -> case p st inp of
                        Right res -> Right [(f v, s, out) | (v,s,out) <- res]
                        Left err  -> Left err
                       )

instance Applicative (Parser s t e) where
   pure v = P (\st inp -> Right [(v,st,inp)])
   (<*>) = ap

instance Monad (Parser s t e) where
   -- return      :: a -> Parser s t e a
   return          = pure
   -- >>=         :: Parser s t e a -> (a -> Parser s t e b) -> Parser s t e b
   (P p) >>= f     = P (\st inp -> case p st inp of
                        Right res -> foldr joinresults (Right [])
                            [ papply' (f v) s out | (v,s,out) <- res ]
                        Left err  -> Left err
                       )

#if !MIN_VERSION_base(4,13,0)
   fail            = Fail.fail
#endif

instance Fail.MonadFail (Parser s t e) where
   -- fail        :: String -> Parser s t e a
   fail err        = P (\st inp -> Right [])
  -- I know it's counterintuitive, but we want no-parse, not an error.

instance Alternative (Parser s t e) where
   empty = mzero
   (<|>) = mplus

instance MonadPlus (Parser s t e) where
   -- mzero       :: Parser s t e a
   mzero           = P (\st inp -> Right [])
   -- mplus       :: Parser s t e a -> Parser s t e a -> Parser s t e a
   (P p) `mplus` (P q) = P (\st inp -> joinresults (p st inp) (q st inp))

-- joinresults ensures that explicitly raised errors are dominant,
-- provided no parse has yet been found.  The commented out code is
-- a slightly stricter specification of the real code.
joinresults :: ParseResult s t e a -> ParseResult s t e a -> ParseResult s t e a
{-
joinresults (Left  p)  (Left  q)  = Left  p
joinresults (Left  p)  (Right _)  = Left  p
joinresults (Right []) (Left  q)  = Left  q
joinresults (Right p)  (Left  q)  = Right p
joinresults (Right p)  (Right q)  = Right (p++q)
-}
joinresults (Left  p)  q  = Left p
joinresults (Right []) q  = q
joinresults (Right p)  q  = Right (p++ case q of Left _  -> []
                                                 Right r -> r)


--- Primitive parser combinators ---------------------------------------------

-- | Deliver the first remaining token.
item              :: Parser s t e t
item               = P (\st inp -> case inp of
                        []            -> Right []
                        (Left e: _)   -> Left e
                        (Right x: xs) -> Right [(x,st,xs)]
                       )

-- | Fail if end of input is not reached
eof               :: Show p => Parser s (p,t) String ()
eof                = P (\st inp -> case inp of
                        []         -> Right [((),st,[])]
                        (Left e:_) -> Left e
                        (Right (p,_):_) -> Left ("End of input expected at "
                                                 ++show p++"\n  but found text")
                       )

{-
-- | Ensure the value delivered by the parser is evaluated to WHNF.
force             :: Parser s t e a -> Parser s t e a
force (P p)        = P (\st inp -> let Right xs = p st inp
                                       h = head xs in
                                   h `seq` Right (h: tail xs)
                       )
--  [[[GK]]]  ^^^^^^
--  WHNF = Weak Head Normal Form, meaning that it has no top-level redex.
--  In this case, I think that means that the first element of the list
--  is fully evaluated.
--
--  NOTE:  the original form of this function fails if there is no parse
--  result for p st inp (head xs fails if xs is null), so the modified
--  form can assume a Right value only.
--
--  Why is this needed?
--  It's not exported, and the only use of this I see is commented out.
---------------------------------------
-}


-- | Deliver the first parse result only, eliminating any backtracking.
first             :: Parser s t e a -> Parser s t e a
first (P p)        = P (\st inp -> case p st inp of
                                   Right (x:xs) -> Right [x]
                                   otherwise    -> otherwise
                       )

-- | Apply the parser to some real input, given an initial state value.
--   If the parser fails, raise 'error' to halt the program.
--   (This is the original exported behaviour - to allow the caller to
--   deal with the error differently, see @papply'@.)
papply            :: Parser s t String a -> s -> [Either String t]
                                              -> [(a,s,[Either String t])]
papply (P p) st inp = either error id (p st inp)

-- | Apply the parser to some real input, given an initial state value.
--   If the parser fails, return a diagnostic message to the caller.
papply'           :: Parser s t e a -> s -> [Either e t]
                                         -> Either e [(a,s,[Either e t])]
papply' (P p) st inp = p st inp

--- Derived combinators ------------------------------------------------------

-- | A choice between parsers.  Keep only the first success.
(+++)             :: Parser s t e a -> Parser s t e a -> Parser s t e a
p +++ q            = first (p `mplus` q)

-- | Deliver the first token if it satisfies a predicate.
sat               :: (t -> Bool) -> Parser s (p,t) e t
sat p              = do {(_,x) <- item; if p x then return x else mzero}

-- | Deliver the first token if it equals the argument.
tok               :: Eq t => t -> Parser s (p,t) e t
tok t              = do {(_,x) <- item; if x==t then return t else mzero}

-- | Deliver the first token if it does not equal the argument.
nottok            :: Eq t => [t] -> Parser s (p,t) e t
nottok ts          = do {(_,x) <- item; if x `notElem` ts then return x
                                        else mzero}

-- | Deliver zero or more values of @a@.
many              :: Parser s t e a -> Parser s t e [a]
many p             = many1 p +++ return []
--many p           = force (many1 p +++ return [])

-- | Deliver one or more values of @a@.
many1             :: Parser s t e a -> Parser s t e [a]
many1 p            = do {x <- p; xs <- many p; return (x:xs)}

-- | Deliver zero or more values of @a@ separated by @b@'s.
sepby             :: Parser s t e a -> Parser s t e b -> Parser s t e [a]
p `sepby` sep      = (p `sepby1` sep) +++ return []

-- | Deliver one or more values of @a@ separated by @b@'s.
sepby1            :: Parser s t e a -> Parser s t e b -> Parser s t e [a]
p `sepby1` sep     = do {x <- p; xs <- many (do {sep; p}); return (x:xs)}

chainl            :: Parser s t e a -> Parser s t e (a->a->a) -> a
                                                              -> Parser s t e a
chainl p op v      = (p `chainl1` op) +++ return v

chainl1           :: Parser s t e a -> Parser s t e (a->a->a) -> Parser s t e a
p `chainl1` op     = do {x <- p; rest x}
                     where
                        rest x = do {f <- op; y <- p; rest (f x y)}
                                 +++ return x

chainr            :: Parser s t e a -> Parser s t e (a->a->a) -> a
                                                              -> Parser s t e a
chainr p op v      = (p `chainr1` op) +++ return v

chainr1           :: Parser s t e a -> Parser s t e (a->a->a) -> Parser s t e a
p `chainr1` op     = do {x <- p; rest x}
                     where
                        rest x = do { f <- op
                                    ; y <- p `chainr1` op
                                    ; return (f x y)
                                    }
                                 +++ return x

ops               :: [(Parser s t e a, b)] -> Parser s t e b
ops xs             = foldr1 (+++) [do {p; return op} | (p,op) <- xs]

bracket           :: (Show p,Show t) =>
                     Parser s (p,t) e a -> Parser s (p,t) e b ->
                               Parser s (p,t) e c -> Parser s (p,t) e b
bracket open p close = do { open
                          ; x <- p
                          ; close -- `elserror` "improperly matched construct";
                          ; return x
                          }

-- | Accept a complete parse of the input only, no partial parses.
toEOF             :: Show p =>
                     Parser s (p,t) String a -> Parser s (p,t) String a
toEOF p            = do { x <- p; eof; return x }


--- Error handling -----------------------------------------------------------

-- | Return an error using the supplied diagnostic string, and a token type
--   which includes position information.
parseerror :: (Show p,Show t) => String -> Parser s (p,t) String a
parseerror err = P (\st inp ->
                         case inp of
                           [] -> Left "Parse error: unexpected EOF\n"
                           (Left e:_) -> Left ("Lexical error:  "++e)
                           (Right (p,t):_)  ->
                                 Left ("Parse error: in  "++show p++"\n    "
                                       ++err++"\n  "++"Found "++show t)
                   )


-- | If the parser fails, generate an error message.
elserror          :: (Show p,Show t) => Parser s (p,t) String a -> String
                                        -> Parser s (p,t) String a
p `elserror` s     = p +++ parseerror s

--- State handling -----------------------------------------------------------

-- | Update the internal state.
stupd      :: (s->s) -> Parser s t e ()
stupd f     = P (\st inp-> {-let newst = f st in newst `seq`-}
                           Right [((), f st, inp)])

-- | Query the internal state.
stquery    :: (s->a) -> Parser s t e a
stquery f   = P (\st inp-> Right [(f st, st, inp)])

-- | Deliver the entire internal state.
stget      :: Parser s t e s
stget       = P (\st inp-> Right [(st, st, inp)])


--- Push some tokens back onto the input stream and reparse ------------------

-- | This is useful 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    :: [Either e t] -> Parser s t e ()
reparse ts  = P (\st inp-> Right [((), st, ts++inp)])

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