module Text.ParserCombinators.Poly.StateText
  ( -- * The Parser datatype
    Parser(P)
  , Result(..)
  , runParser
    -- ** Basic parsers
  , next
  , eof
  , satisfy
  , onFail
    -- ** Derived parsers (but implemented more efficiently)
  , manySatisfy
  , many1Satisfy
    -- ** State-handling
  , stUpdate    -- :: (s->s) -> Parser s t ()
  , stQuery     -- :: (s->a) -> Parser s t a
  , stGet       -- :: Parser s t s
    -- ** Re-parsing
  , reparse
    -- * Re-export all more general combinators
  , module Text.ParserCombinators.Poly.Base
  , module Control.Applicative
  ) where


import Text.ParserCombinators.Poly.Base
import Text.ParserCombinators.Poly.Result
import qualified Data.Text.Lazy as T
import Data.Text.Lazy (Text)
import Control.Applicative
import qualified Control.Monad.Fail as Fail

-- | This @Parser@ datatype is a specialised parsing monad with error
--   reporting.  Whereas the standard version can be used for arbitrary
--   token types, this version is specialised to Text input only.
newtype Parser s a = P (s -> Text -> Result (Text,s) a)

-- | Apply a parser to an input token sequence.
runParser :: Parser s a -> s -> Text -> (Either String a, s, Text)
runParser :: Parser s a -> s -> Text -> (Either String a, s, Text)
runParser (P s -> Text -> Result (Text, s) a
p) = \s
s -> (Either String a, (Text, s)) -> (Either String a, s, Text)
forall a c b. (a, (c, b)) -> (a, b, c)
reTuple ((Either String a, (Text, s)) -> (Either String a, s, Text))
-> (Text -> (Either String a, (Text, s)))
-> Text
-> (Either String a, s, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result (Text, s) a -> (Either String a, (Text, s))
forall z a. Result z a -> (Either String a, z)
resultToEither (Result (Text, s) a -> (Either String a, (Text, s)))
-> (Text -> Result (Text, s) a)
-> Text
-> (Either String a, (Text, s))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Text -> Result (Text, s) a
p s
s
  where
    reTuple :: (a, (c, b)) -> (a, b, c)
reTuple (a
either, (c
z,b
s)) = (a
either, b
s, c
z)

instance Functor (Parser s) where
    fmap :: (a -> b) -> Parser s a -> Parser s b
fmap a -> b
f (P s -> Text -> Result (Text, s) a
p) = (s -> Text -> Result (Text, s) b) -> Parser s b
forall s a. (s -> Text -> Result (Text, s) a) -> Parser s a
P (\s
s-> (a -> b) -> Result (Text, s) a -> Result (Text, s) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Result (Text, s) a -> Result (Text, s) b)
-> (Text -> Result (Text, s) a) -> Text -> Result (Text, s) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Text -> Result (Text, s) a
p s
s)

instance Monad (Parser s) where
    return :: a -> Parser s a
return       = a -> Parser s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (P s -> Text -> Result (Text, s) a
f) >>= :: Parser s a -> (a -> Parser s b) -> Parser s b
>>= a -> Parser s b
g  = (s -> Text -> Result (Text, s) b) -> Parser s b
forall s a. (s -> Text -> Result (Text, s) a) -> Parser s a
P (\s
s-> Result (Text, s) a -> Result (Text, s) b
continue (Result (Text, s) a -> Result (Text, s) b)
-> (Text -> Result (Text, s) a) -> Text -> Result (Text, s) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Text -> Result (Text, s) a
f s
s)
      where
        continue :: Result (Text, s) a -> Result (Text, s) b
continue (Success (Text
ts,s
s) a
x)         = let (P s -> Text -> Result (Text, s) b
g') = a -> Parser s b
g a
x in s -> Text -> Result (Text, s) b
g' s
s Text
ts
        continue (Committed Result (Text, s) a
r)              = Result (Text, s) b -> Result (Text, s) b
forall z a. Result z a -> Result z a
Committed (Result (Text, s) a -> Result (Text, s) b
continue Result (Text, s) a
r)
        continue (Failure (Text, s)
ts String
e)             = (Text, s) -> String -> Result (Text, s) b
forall z a. z -> String -> Result z a
Failure (Text, s)
ts String
e

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

instance Fail.MonadFail (Parser s) where
    fail :: String -> Parser s a
fail String
e       = (s -> Text -> Result (Text, s) a) -> Parser s a
forall s a. (s -> Text -> Result (Text, s) a) -> Parser s a
P (\s
s Text
ts-> (Text, s) -> String -> Result (Text, s) a
forall z a. z -> String -> Result z a
Failure (Text
ts,s
s) String
e)

instance Commitment (Parser s) where
    commit :: Parser s a -> Parser s a
commit (P s -> Text -> Result (Text, s) a
p)         = (s -> Text -> Result (Text, s) a) -> Parser s a
forall s a. (s -> Text -> Result (Text, s) a) -> Parser s a
P (\s
s-> Result (Text, s) a -> Result (Text, s) a
forall z a. Result z a -> Result z a
Committed (Result (Text, s) a -> Result (Text, s) a)
-> (Text -> Result (Text, s) a) -> Text -> Result (Text, s) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result (Text, s) a -> Result (Text, s) a
forall z a. Result z a -> Result z a
squash (Result (Text, s) a -> Result (Text, s) a)
-> (Text -> Result (Text, s) a) -> Text -> Result (Text, s) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Text -> Result (Text, s) a
p s
s)
      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 s -> Text -> Result (Text, s) a
p) adjustErr :: Parser s a -> (String -> String) -> Parser s a
`adjustErr` String -> String
f  = (s -> Text -> Result (Text, s) a) -> Parser s a
forall s a. (s -> Text -> Result (Text, s) a) -> Parser s a
P (\s
s-> Result (Text, s) a -> Result (Text, s) a
forall z a. Result z a -> Result z a
adjust (Result (Text, s) a -> Result (Text, s) a)
-> (Text -> Result (Text, s) a) -> Text -> Result (Text, s) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Text -> Result (Text, s) a
p s
s)
      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 s a)] -> Parser s a
oneOf' = [(String, String)] -> [(String, Parser s a)] -> Parser s a
forall s a.
[(String, String)] -> [(String, Parser s a)] -> Parser s a
accum []
      where accum :: [(String, String)] -> [(String, Parser s a)] -> Parser s a
accum [(String, String)]
errs [] =
                String -> Parser s 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 s -> Text -> Result (Text, s) a
p):[(String, Parser s a)]
ps) =
                (s -> Text -> Result (Text, s) a) -> Parser s a
forall s a. (s -> Text -> Result (Text, s) a) -> Parser s a
P (\s
s Text
ts-> case s -> Text -> Result (Text, s) a
p s
s Text
ts of
                           Failure (Text, s)
_ String
err ->
                                       let (P s -> Text -> Result (Text, s) a
p') = [(String, String)] -> [(String, Parser s a)] -> Parser s a
accum ((String
e,String
err)(String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
:[(String, String)]
errs) [(String, Parser s a)]
ps
                                       in s -> Text -> Result (Text, s) a
p' s
s Text
ts
                           r :: Result (Text, s) a
r@(Success (Text, s)
_ a
_)    -> Result (Text, s) a
r
                           r :: Result (Text, s) a
r@(Committed Result (Text, s) a
_)    -> Result (Text, s) 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

instance Applicative (Parser s) where
    pure :: a -> Parser s a
pure a
x    = (s -> Text -> Result (Text, s) a) -> Parser s a
forall s a. (s -> Text -> Result (Text, s) a) -> Parser s a
P (\s
s Text
ts-> (Text, s) -> a -> Result (Text, s) a
forall z a. z -> a -> Result z a
Success (Text
ts,s
s) a
x)
    Parser s (a -> b)
pf <*> :: Parser s (a -> b) -> Parser s a -> Parser s b
<*> Parser s a
px = do { a -> b
f <- Parser s (a -> b)
pf; a
x <- Parser s a
px; b -> Parser s 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 Alternative (Parser s) where
    empty :: Parser s a
empty     = String -> Parser s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no parse"
    Parser s a
p <|> :: Parser s a -> Parser s a -> Parser s a
<|> Parser s a
q   = Parser s a
p Parser s a -> Parser s a -> Parser s a
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail` Parser s a
q

instance PolyParse (Parser s)

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

-- | Simply return the next token in the input tokenstream.
next :: Parser s Char
next :: Parser s Char
next = (s -> Text -> Result (Text, s) Char) -> Parser s Char
forall s a. (s -> Text -> Result (Text, s) a) -> Parser s a
P (\s
s Text
bs-> case Text -> Maybe (Char, Text)
T.uncons Text
bs of
                  Maybe (Char, Text)
Nothing       -> (Text, s) -> String -> Result (Text, s) Char
forall z a. z -> String -> Result z a
Failure (Text
bs,s
s) String
"Ran out of input (EOF)"
                  Just (Char
c, Text
bs') -> (Text, s) -> Char -> Result (Text, s) Char
forall z a. z -> a -> Result z a
Success (Text
bs',s
s) Char
c )

-- | Succeed if the end of file/input has been reached, fail otherwise.
eof :: Parser s ()
eof :: Parser s ()
eof = (s -> Text -> Result (Text, s) ()) -> Parser s ()
forall s a. (s -> Text -> Result (Text, s) a) -> Parser s a
P (\s
s Text
bs -> if Text -> Bool
T.null Text
bs
                  then (Text, s) -> () -> Result (Text, s) ()
forall z a. z -> a -> Result z a
Success (Text
bs,s
s) ()
                  else (Text, s) -> String -> Result (Text, s) ()
forall z a. z -> String -> Result z a
Failure (Text
bs,s
s) String
"Expected end of input (EOF)" )

-- | Return the next token if it satisfies the given predicate.
satisfy :: (Char -> Bool) -> Parser s Char
satisfy :: (Char -> Bool) -> Parser s Char
satisfy Char -> Bool
f = do { Char
x <- Parser s Char
forall s. Parser s Char
next
               ; if Char -> Bool
f Char
x then Char -> Parser s Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
x else String -> Parser s Char
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Parse.satisfy: failed"
               }

-- | @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 s a -> Parser s a -> Parser s a
(P s -> Text -> Result (Text, s) a
p) onFail :: Parser s a -> Parser s a -> Parser s a
`onFail` (P s -> Text -> Result (Text, s) a
q) = (s -> Text -> Result (Text, s) a) -> Parser s a
forall s a. (s -> Text -> Result (Text, s) a) -> Parser s a
P (\s
s Text
ts-> s -> Text -> Result (Text, s) a -> Result (Text, s) a
continue s
s Text
ts (Result (Text, s) a -> Result (Text, s) a)
-> Result (Text, s) a -> Result (Text, s) a
forall a b. (a -> b) -> a -> b
$ s -> Text -> Result (Text, s) a
p s
s Text
ts)
  where continue :: s -> Text -> Result (Text, s) a -> Result (Text, s) a
continue s
s Text
ts (Failure (Text, s)
_ String
_) = s -> Text -> Result (Text, s) a
q s
s Text
ts
    --  continue _ _  (Committed r) = r	-- no, remain Committed
        continue s
_ Text
_  Result (Text, s) a
r             = Result (Text, s) a
r

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

-- | @manySatisfy p@ is a more efficient fused version of @many (satisfy p)@
manySatisfy :: (Char->Bool) -> Parser s Text
manySatisfy :: (Char -> Bool) -> Parser s Text
manySatisfy Char -> Bool
f = (s -> Text -> Result (Text, s) Text) -> Parser s Text
forall s a. (s -> Text -> Result (Text, s) a) -> Parser s a
P (\s
s Text
bs-> let (Text
pre,Text
suf) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
f Text
bs in (Text, s) -> Text -> Result (Text, s) Text
forall z a. z -> a -> Result z a
Success (Text
suf,s
s) Text
pre)

-- | @many1Satisfy p@ is a more efficient fused version of @many1 (satisfy p)@
many1Satisfy :: (Char->Bool) -> Parser s Text
many1Satisfy :: (Char -> Bool) -> Parser s Text
many1Satisfy Char -> Bool
f = do Text
x <- (Char -> Bool) -> Parser s Text
forall s. (Char -> Bool) -> Parser s Text
manySatisfy Char -> Bool
f
                    if Text -> Bool
T.null Text
x then String -> Parser s Text
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Parse.many1Satisfy: failed"
                                else Text -> Parser s Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
x

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

-- | Update the internal state.
stUpdate   :: (s->s) -> Parser s ()
stUpdate :: (s -> s) -> Parser s ()
stUpdate s -> s
f  = (s -> Text -> Result (Text, s) ()) -> Parser s ()
forall s a. (s -> Text -> Result (Text, s) a) -> Parser s a
P (\s
s Text
bs-> (Text, s) -> () -> Result (Text, s) ()
forall z a. z -> a -> Result z a
Success (Text
bs, s -> s
f s
s) ())

-- | Query the internal state.
stQuery    :: (s->a) -> Parser s a
stQuery :: (s -> a) -> Parser s a
stQuery s -> a
f   = (s -> Text -> Result (Text, s) a) -> Parser s a
forall s a. (s -> Text -> Result (Text, s) a) -> Parser s a
P (\s
s Text
bs-> (Text, s) -> a -> Result (Text, s) a
forall z a. z -> a -> Result z a
Success (Text
bs,s
s) (s -> a
f s
s))

-- | Deliver the entire internal state.
stGet      :: Parser s s
stGet :: Parser s s
stGet       = (s -> Text -> Result (Text, s) s) -> Parser s s
forall s a. (s -> Text -> Result (Text, s) a) -> Parser s a
P (\s
s Text
bs-> (Text, s) -> s -> Result (Text, s) s
forall z a. z -> a -> Result z a
Success (Text
bs,s
s) s
s)

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

-- | 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    :: Text -> Parser s ()
reparse :: Text -> Parser s ()
reparse Text
ts  = (s -> Text -> Result (Text, s) ()) -> Parser s ()
forall s a. (s -> Text -> Result (Text, s) a) -> Parser s a
P (\s
s Text
inp-> (Text, s) -> () -> Result (Text, s) ()
forall z a. z -> a -> Result z a
Success (Text
ts Text -> Text -> Text
`T.append` Text
inp,s
s) ())

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