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' (StateT [c] (ListT (WriterT w m)) a) (ParserT w c m a)
_ParserT = iso ParserT (\(ParserT p) -> p)
_parserT :: Functor m => Iso' ([c] -> m (w,[([c],a)])) (ParserT w c m a)
_parserT = _mapping (_writerT._listT)._stateT._ParserT
_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 p = token <*= (guard . p)
single c = void (satisfy (c==))

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 Void
eoi = remaining >>= guard.null

sepBy1 p sep = (:)<$>p<*>many (sep >> p)
sepBy p sep = option [] (sepBy1 p sep)
(<+>) = (+)
oneOf = satisfy . elem
noneOf = satisfy . map not . elem

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

chain expr op e = chain where chain = (expr<**>op<*>chain) + e