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