module Text.Parser.List
       ( Parser, runParser, evalParser
       , Error, errorE, errorP, noteP

       , token, eof, sink, satisfy', satisfy, list
       ) where

import Control.Applicative (pure)
import Control.Monad (guard)
import Control.Monad.Trans.State.Strict (StateT (..), evalStateT, get, put)
import Control.Monad.Trans.Except (Except, runExcept, withExcept, throwE)
import Data.Monoid (Last (..))
import Data.Maybe (fromMaybe)


type Error = Last String

unError :: String -> Error -> String
unError :: String -> Error -> String
unError String
s = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
s (Maybe String -> String)
-> (Error -> Maybe String) -> Error -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Maybe String
forall a. Last a -> Maybe a
getLast

type Parser t = StateT [t] (Except Error)

runParser :: Parser t a -> [t] -> Either String (a, [t])
runParser :: forall t a. Parser t a -> [t] -> Either String (a, [t])
runParser Parser t a
p = Except String (a, [t]) -> Either String (a, [t])
forall e a. Except e a -> Either e a
runExcept (Except String (a, [t]) -> Either String (a, [t]))
-> ([t] -> Except String (a, [t])) -> [t] -> Either String (a, [t])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Error -> String)
-> Except Error (a, [t]) -> Except String (a, [t])
forall e e' a. (e -> e') -> Except e a -> Except e' a
withExcept (String -> Error -> String
unError String
"runParser: parse error.") (Except Error (a, [t]) -> Except String (a, [t]))
-> ([t] -> Except Error (a, [t])) -> [t] -> Except String (a, [t])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser t a -> [t] -> Except Error (a, [t])
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Parser t a
p

evalParser :: Parser t a -> [t] -> Either String a
evalParser :: forall t a. Parser t a -> [t] -> Either String a
evalParser Parser t a
p = Except String a -> Either String a
forall e a. Except e a -> Either e a
runExcept (Except String a -> Either String a)
-> ([t] -> Except String a) -> [t] -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Error -> String) -> Except Error a -> Except String a
forall e e' a. (e -> e') -> Except e a -> Except e' a
withExcept (String -> Error -> String
unError String
"evalParser: parse error.") (Except Error a -> Except String a)
-> ([t] -> Except Error a) -> [t] -> Except String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser t a -> [t] -> Except Error a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT Parser t a
p

errorE :: String -> Except Error a
errorE :: forall a. String -> Except Error a
errorE = Error -> ExceptT Error Identity a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error Identity a)
-> (String -> Error) -> String -> ExceptT Error Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> Error
forall a. Maybe a -> Last a
Last (Maybe String -> Error)
-> (String -> Maybe String) -> String -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. a -> Maybe a
Just

errorP :: String -> Parser t a
errorP :: forall t a. String -> Parser t a
errorP = ([t] -> Except Error (a, [t]))
-> StateT [t] (ExceptT Error Identity) a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT (([t] -> Except Error (a, [t]))
 -> StateT [t] (ExceptT Error Identity) a)
-> (String -> [t] -> Except Error (a, [t]))
-> String
-> StateT [t] (ExceptT Error Identity) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Except Error (a, [t]) -> [t] -> Except Error (a, [t])
forall a b. a -> b -> a
const (Except Error (a, [t]) -> [t] -> Except Error (a, [t]))
-> (String -> Except Error (a, [t]))
-> String
-> [t]
-> Except Error (a, [t])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Except Error (a, [t])
forall a. String -> Except Error a
errorE

noteP :: String -> Maybe a -> Parser t a
noteP :: forall a t. String -> Maybe a -> Parser t a
noteP String
s = Parser t a -> (a -> Parser t a) -> Maybe a -> Parser t a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser t a
forall t a. String -> Parser t a
errorP String
s) a -> Parser t a
forall a. a -> StateT [t] (ExceptT Error Identity) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

token :: Parser t t
token :: forall t. Parser t t
token = do
  [t]
cs0 <- StateT [t] (ExceptT Error Identity) [t]
forall (m :: * -> *) s. Monad m => StateT s m s
get
  case [t]
cs0 of
    t
c:[t]
cs  ->  do
      [t] -> StateT [t] (ExceptT Error Identity) ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put [t]
cs
      t -> Parser t t
forall a. a -> StateT [t] (ExceptT Error Identity) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
c
    []    ->
      String -> Parser t t
forall t a. String -> Parser t a
errorP String
"token: end of input"

eof :: Parser t ()
eof :: forall t. Parser t ()
eof = do
  [t]
cs <- StateT [t] (ExceptT Error Identity) [t]
forall (m :: * -> *) s. Monad m => StateT s m s
get
  case [t]
cs of
    []   ->  () -> Parser t ()
forall a. a -> StateT [t] (ExceptT Error Identity) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    t
_:[t]
_  ->  String -> Parser t ()
forall t a. String -> Parser t a
errorP String
"eof: not empty input"

sink :: Parser t [t]
sink :: forall t. Parser t [t]
sink = do
  [t]
cs <- Parser t [t]
forall (m :: * -> *) s. Monad m => StateT s m s
get
  [t] -> StateT [t] (ExceptT Error Identity) ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put []
  [t] -> Parser t [t]
forall a. a -> StateT [t] (ExceptT Error Identity) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [t]
cs

satisfy' :: String         -- ^ Parser name to print when error
         -> (t -> String)  -- ^ Function to build error string
         -> (t -> Bool)    -- ^ Predicate to satisfy
         -> Parser t t     -- ^ Result parser
satisfy' :: forall t. String -> (t -> String) -> (t -> Bool) -> Parser t t
satisfy' String
n t -> String
ef t -> Bool
p = do
  t
c <- Parser t t
forall t. Parser t t
token
  String -> Maybe () -> Parser t ()
forall a t. String -> Maybe a -> Parser t a
noteP (String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> String
ef t
c) (Maybe () -> Parser t ())
-> (Bool -> Maybe ()) -> Bool -> Parser t ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Parser t ()) -> Bool -> Parser t ()
forall a b. (a -> b) -> a -> b
$ t -> Bool
p t
c
  t -> Parser t t
forall a. a -> StateT [t] (ExceptT Error Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return t
c

-- | make satisfy parser with monoid-empty error.
satisfy :: (t -> Bool) -> Parser t t
satisfy :: forall t. (t -> Bool) -> Parser t t
satisfy t -> Bool
p = do
  t
c <- Parser t t
forall t. Parser t t
token
  Bool -> StateT [t] (ExceptT Error Identity) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> StateT [t] (ExceptT Error Identity) ())
-> Bool -> StateT [t] (ExceptT Error Identity) ()
forall a b. (a -> b) -> a -> b
$ t -> Bool
p t
c -- expect empty error
  t -> Parser t t
forall a. a -> StateT [t] (ExceptT Error Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return t
c

list :: Eq t => [t] -> Parser t [t]
list :: forall t. Eq t => [t] -> Parser t [t]
list = (t -> StateT [t] (ExceptT Error Identity) t)
-> [t] -> StateT [t] (ExceptT Error Identity) [t]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((t -> Bool) -> StateT [t] (ExceptT Error Identity) t
forall t. (t -> Bool) -> Parser t t
satisfy ((t -> Bool) -> StateT [t] (ExceptT Error Identity) t)
-> (t -> t -> Bool) -> t -> StateT [t] (ExceptT Error Identity) t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> t -> Bool
forall a. Eq a => a -> a -> Bool
(==))