module SimpleH.Parser where

import SimpleH.Core hiding (flip)
import SimpleH.Monad
import SimpleH.Traversable
import SimpleH.Lens

newtype ParserT w c m a = ParserT (StateT [c] (ListT (WriterT w m)) a)
                        deriving (Unit,Functor,Applicative,Monoid,Semigroup,
                                  Monad,MonadFix,MonadState [c],MonadWriter w)
type Parser w c a = ParserT w c Id a
deriving instance (Monad m,Monoid w) => MonadError Void (ParserT w c m)

_ParserT :: Iso (ParserT w c m a) (ParserT x d n b) (StateT [c] (ListT (WriterT w m)) a) (StateT [d] (ListT (WriterT x n)) b)
_ParserT = iso ParserT (\(ParserT p) -> p)
_parserT :: (Functor n,Functor m) => Iso (ParserT w c m a) (ParserT x d n b) ([c] -> m (w,[([c],a)])) ([d] -> n (x,[([d],b)]))
_parserT = _mapping (_writerT._listT)._stateT._ParserT
_parser :: Iso (Parser w c a) (Parser x d b) ([c] -> (w,[([c],a)])) ([d] -> (x,[([d],b)]))
_parser = _mapping _Id._parserT

remaining :: (Monad m,Monoid w) => ParserT w c m [c]
remaining = get 
token :: (Monad m,Monoid w) => ParserT w c m c
token = get >>= \s -> case s of [] -> zero ; c:t -> put t >> pure c
many :: (Monoid w,Monad m) => ParserT w c m a -> ParserT w c m [a]
many p = liftA2 (:) p (many p) <+> pure []
many1 :: (Monoid w,Monad m) => ParserT w c m a -> ParserT w c m [a]
many1 p = (:)<$>p<*>many p

satisfy :: (Monoid w, Monad m) => (c -> Bool) -> ParserT w c m c
satisfy p = token <*= (guard . p)
single :: (Eq c, Monoid w, Monad m) => c -> ParserT w c m ()
single c = void (satisfy (c==))

several :: (Eq c, Monoid w, Monad m, Foldable t) => t c -> ParserT w c m ()
several l = traverse_ single l

option :: (Monoid w,Monad m) => a -> ParserT w c m a -> ParserT w c m a
option a p = p+pure a

eoi :: (Monad m,Monoid w) => ParserT w c m ()
eoi = remaining >>= guard.null

sepBy1 ::(Monoid w, Monad m) => ParserT w c m a -> ParserT w c m b -> ParserT w c m [a]
sepBy1 p sep = (:)<$>p<*>many (sep >> p)
sepBy ::(Monoid w, Monad m) => ParserT w c m a -> ParserT w c m b -> ParserT w c m [a]
sepBy p sep = option [] (sepBy1 p sep)

(<+>) :: Semigroup m => m -> m -> m
(<+>) = (+)

oneOf :: (Eq c, Monoid w, Monad m, Foldable t) => t c -> ParserT w c m c
oneOf = satisfy . flip elem
noneOf :: (Eq c, Monoid w, Monad m, Foldable t) => t c -> ParserT w c m c
noneOf = satisfy . map not . flip elem

infixl 1 `sepBy`,`sepBy1`,<+>

chain :: (Semigroup (f b), Applicative f) => f a -> f (a -> b -> b) -> f b -> f b
chain expr op e = fix $ \_chain -> ((&)<$>expr<*>op<*>_chain) + e