-- |A module providing simple Parser combinator functionality. Useful
-- for small parsing tasks such as identifier parsing or command-line
-- argument parsing
module SimpleH.Parser (
  module SimpleH,
  -- * The ParserT Type
  ParserT(..),Parser,ParserA(..),_ParserA,
  -- ** The Stream class
  Stream(..),empty,
  -- ** Converting to/from Parsers
  parserT,parser,runParser,pureParser,
  
  -- * Basic utilities
  (<+>),(>*>),token,satisfy,remaining,oneOf,noneOf,single,several,eoi,
  
  -- * Basic combinators
  many,many1,sepBy,sepBy1,
  chainl,chainr                          
  ) where

import SimpleH

import qualified Data.ByteString as BS

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

_ParserT :: Iso (ParserT w s m a) (ParserT x t n b) (StateT s (ListT (WriterT w m)) a) (StateT t (ListT (WriterT x n)) b)
_ParserT = iso ParserT (\(ParserT p) -> p)
parserT :: (Functor n,Functor m) => Iso (ParserT w s m a) (ParserT x t n b) (s -> m (w,[(s,a)])) (t -> n (x,[(t,b)]))
parserT = _mapping (_writerT._listT).stateT._ParserT
parser :: Iso (Parser w s a) (Parser x t b) (s -> (w,[(s,a)])) (t -> (x,[(t,b)]))
parser = _mapping _Id.parserT
runParser :: Parser Void s a -> s -> [(s,a)]
runParser p = snd . (p^..parser)
pureParser :: (Monoid w,Monad m) => (a -> [b]) -> ParserT w a m b
pureParser p = (\a -> pure (zero,[(a,b) | b <- p a]))^.parserT

-- |The @(+)@ operator with lower priority
(<+>) :: Semigroup m => m -> m -> m
(<+>) = (+)
(>*>) :: (Monoid w, Monad m) => ParserT w a m b -> ParserT w b m c -> ParserT w a m c
(>*>) = (>>>)^..(_ParserA<.>_ParserA<.>_ParserA)

newtype ParserA w m s a = ParserA (ParserT w s m a)
_ParserA :: Iso (ParserA w m s a) (ParserA w' m' s' a') (ParserT w s m a) (ParserT w' s' m' a')
_ParserA = iso ParserA (\(ParserA p) -> p)
parserA :: Iso (ParserA w m s a) (ParserA w' m' s' a') (StateA (ListT (WriterT w m)) s a) (StateA (ListT (WriterT w' m')) s' a') 
parserA = from stateA._ParserT._ParserA
instance (Monoid w,Monad m) => Category (ParserA w m) where
  id = ParserA get
  (.) = (.)^.(parserA<.>parserA<.>parserA)
instance (Monoid w,Monad m) => Split (ParserA w m) where
  (<#>) = (<#>)^.(parserA<.>parserA<.>parserA)
instance (Monoid w,Monad m) => Choice (ParserA w m) where
  (<|>) = (<|>)^.(parserA<.>parserA<.>parserA)
instance (Monoid w,Monad m) => Arrow (ParserA w m) where
  arr f = arr f^.parserA

-- |The remaining Stream to parse
remaining :: (Monad m,Monoid w) => ParserT w s m s
remaining = get
-- |Consume a token from the Stream
token :: (Monad m,Monoid w,Stream c s) => ParserT w s m c
{-# SPECIALIZE token :: (Monad m,Monoid w) => ParserT w [c] m c #-}
token = get >>= \s -> case uncons s of
  Nothing -> zero
  Just (c,t) -> put t >> pure c

-- |Parse zero, one or more successive occurences of a parser.
many :: (Monoid w,Monad m) => ParserT w c m a -> ParserT w c m [a]
many p = liftA2 (:) p (many p) <+> pure []
-- |Parse one or more successiveé occurences of a parser.
many1 :: (Monoid w,Monad m) => ParserT w c m a -> ParserT w c m [a]
many1 p = (:)<$>p<*>many p

-- |Consume a token and succeed if it verifies a predicate
satisfy :: (Monoid w, Monad m, Stream c s) => (c -> Bool) -> ParserT w s m c
{-# SPECIALIZE satisfy :: (Monoid w, Monad m) => (c -> Bool) -> ParserT w [c] m c #-}
satisfy p = token <*= guard . p
-- |Consume a single fixed token or fail.
single :: (Eq c, Monoid w, Monad m, Stream c s) => c -> ParserT w s m ()
single = void . satisfy . (==)

-- |Consume a structure of characters or fail
several :: (Eq c, Monoid w, Monad m, Foldable t, Stream c s) => t c -> ParserT w s m ()
{-# SPECIALIZE several :: (Eq c, Monoid w, Monad m) => [c] -> ParserT w [c] m () #-}
several l = traverse_ single l

-- |Try to consume a parser. Return a default value when it fails.
option :: (Monoid w,Monad m) => a -> ParserT w s m a -> ParserT w s m a
option a p = p+pure a

-- |Succeed only if we are at the End Of Input.
eoi :: (Monad m,Monoid w,Stream c s) => ParserT w s m ()
eoi = remaining >>= guard.empty

-- |Parse one or more successive occurences of a parser separated by
-- occurences of a second parser.
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)
-- |Parse zero or more successive occurences of a parser separated by
-- occurences of a second parser.
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)

-- |Parse a member of a set of values
oneOf :: (Eq c, Monoid w, Monad m, Foldable t, Stream c s) => t c -> ParserT w s m c
oneOf = satisfy . flip elem
-- |Parse anything but a member of a set
noneOf :: (Eq c, Monoid w, Monad m, Foldable t, Stream c s) => t c -> ParserT w s m c
noneOf = satisfy . map not . flip elem

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

-- |Chain an operator with an initial value and several tail values.
chainr :: (Monoid w,Stream c s,Monad m) => ParserT w s m a -> ParserT w s m (b -> a -> a) -> ParserT w s m b -> ParserT w s m a
chainr expr op e = compose<$>many (op<**>e)<*>expr
-- |Chain an operator with an initial value
chainl :: (Monoid w,Stream c s,Monad m) => ParserT w s m a -> ParserT w s m (a -> b -> a) -> ParserT w s m b -> ParserT w s m a
chainl expr op e = compose<$>many (flip<$>op<*>e)<**>expr


class Stream c s | s -> c where
  uncons :: s -> Maybe (c,s)
  cons :: c -> s -> s
instance Stream a [a] where
  uncons [] = Nothing
  uncons (x:xs) = Just (x,xs)
  cons = (:)

-- |Test if a Stream is empty
empty :: Stream c s => s -> Bool
empty = maybe True (const False) . uncons

class Serializable t where
  encode :: t -> BS.ByteString
  decode :: Parser String BS.ByteString t
instance Serializable BS.ByteString where
  encode = id
  decode = get