module Text.HTML.Tagchup.Parser.Core (
   T,
   nextChar, withDefault, withDefault',
   run, gets, tell, censor, mfix,
   allowFail, allowFail', allowEmit,
   module Data.Functor.Identity,
   ) where


import qualified Text.HTML.Tagchup.Parser.Status as Status
import qualified Text.HTML.Tagchup.Parser.Stream as Stream
import Data.Tuple.HT (mapSnd, )

import qualified Control.Monad.Trans.State as State

import Control.Monad.Trans.Writer (WriterT(..), mapWriterT, tell, censor, )
import Control.Monad.Trans.State (StateT(..), mapStateT, )
import Control.Monad.Fix (mfix)
import Data.Functor.Identity (Identity(..), )
import Control.Monad.Trans.Class (lift, )
import Control.Monad (liftM, )

import Data.Monoid (Monoid, mempty, )


{-
We need to declare whether parts of the parser
can or cannot fail and can or cannot emit something through the writer.
This way we can get rid of the former functions 'force' and 'ignoreEmit'
which generate errors at run-time
if the assumptions of non-failing or non-emission were wrong.
Now, since we declare this properties in types,
runtime errors cannot happen.

The downside is that we cannot easily extend that scheme
to embedded monads that are sources of Chars.
@StateT s Maybe@ and @MaybeT (State s)@ significantly differ
in case of parser failures.
The first one "resets" its state
(more precisely, you would use 'mplus' to give alternative parsers a try,
and 'mplus' would keep the original state),
and the second one stays with the updated state.
The second one would be close to @MaybeT (ReaderT Handle IO)@
which would allow to use @hGetChar@ as character source,
but for IO functions we had to maintain a list of characters
that might have to be re-parsed by a parser alternative.
-}
type T input output fail = WriterT output (StateT (Status.T input) fail)


run :: Monad fail =>
   T input output fail a -> Status.T input -> fail (a, Status.T input, output)
run :: forall (fail :: * -> *) input output a.
Monad fail =>
T input output fail a -> T input -> fail (a, T input, output)
run T input output fail a
p =
   forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\((a
a,output
w),T input
st) -> (a
a,T input
st,output
w)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT T input output fail a
p)


nextChar :: (Monoid output, Stream.C input) =>
   T input output Maybe Char
nextChar :: forall output input.
(Monoid output, C input) =>
T input output Maybe Char
nextChar =
   forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall stream. C stream => StateT stream Maybe Char
Stream.getChar


gets :: (Monoid output, Monad fail) =>
   (Status.T input -> a) -> T input output fail a
gets :: forall output (fail :: * -> *) input a.
(Monoid output, Monad fail) =>
(T input -> a) -> T input output fail a
gets = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets

-- this replaces 'ignoreEmit'
allowEmit ::
   (Monad fail, Monoid output) =>
   T input () fail a -> T input output fail a
allowEmit :: forall (fail :: * -> *) output input a.
(Monad fail, Monoid output) =>
T input () fail a -> T input output fail a
allowEmit =
   forall (m :: * -> *) a w (n :: * -> *) b w'.
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
mapWriterT (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd (forall a b. a -> b -> a
const forall a. Monoid a => a
mempty)))

allowFail' ::
   StateT s Identity a -> StateT s Maybe a
allowFail' :: forall s a. StateT s Identity a -> StateT s Maybe a
allowFail' =
   forall (m :: * -> *) a s (n :: * -> *) b.
(m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
mapStateT (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
runIdentity)

-- this replaces 'force'
allowFail :: T input output Identity a -> T input output Maybe a
allowFail :: forall input output a.
T input output Identity a -> T input output Maybe a
allowFail =
   forall (m :: * -> *) a w (n :: * -> *) b w'.
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
mapWriterT forall s a. StateT s Identity a -> StateT s Maybe a
allowFail'

withDefault' ::
   StateT s Maybe a ->
   StateT s Identity a ->
   StateT s Identity a
withDefault' :: forall s a.
StateT s Maybe a -> StateT s Identity a -> StateT s Identity a
withDefault' StateT s Maybe a
p StateT s Identity a
q =
   forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT forall a b. (a -> b) -> a -> b
$ \s
st ->
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT s Identity a
q s
st) forall a. a -> Identity a
Identity (forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT s Maybe a
p s
st)

withDefault ::
   T input output Maybe a ->
   T input output Identity a ->
   T input output Identity a
withDefault :: forall input output a.
T input output Maybe a
-> T input output Identity a -> T input output Identity a
withDefault T input output Maybe a
p T input output Identity a
q =
   forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT forall a b. (a -> b) -> a -> b
$ forall s a.
StateT s Maybe a -> StateT s Identity a -> StateT s Identity a
withDefault' (forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT T input output Maybe a
p) (forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT T input output Identity a
q)