module Text.HTML.TagSoup.HT.Parser.MTL (
   T,
   nextChar, withDefault,
   run, gets, tell, mfix,
   allowFail, allowEmit,
   module Control.Monad.Identity,
   ) where


import qualified Text.HTML.TagSoup.HT.Position as Position
import qualified Text.HTML.TagSoup.HT.Parser.Status as Status
import Text.HTML.TagSoup.HT.Utility (mapSnd, )

import Control.Monad.Writer (WriterT(..), mapWriterT, tell, lift, liftM, )
import Control.Monad.State (StateT(..), mapStateT, gets, )
import Control.Monad.Fix (mfix)
import Control.Monad.Identity (Identity(..), )

import Data.Monoid (Monoid)


{-
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.
-}
type T output fail = WriterT output (StateT Status.T fail)


run :: Monad fail =>
   T output fail a -> Status.T -> fail (a, Status.T, output)
run p =
   liftM (\((a,w),st) -> (a,st,w)) . runStateT (runWriterT p)


nextChar :: Monoid output => T output Maybe Char
nextChar =
   lift $
   StateT $ \ (Status.Cons pos str) ->
      case str of
         []     -> Nothing
         (c:cs) -> Just (c, Status.Cons (Position.updateOnChar c pos) cs)



-- this replaces 'ignoreEmit'
allowEmit ::
   Monad fail =>
   T () fail a -> T [w] fail a
allowEmit =
   mapWriterT (fmap (mapSnd (const [])))

allowFail' ::
   StateT s Identity a -> StateT s Maybe a
allowFail' =
   mapStateT (Just . runIdentity)

-- this replaces 'force'
allowFail :: T output Identity a -> T output Maybe a
allowFail =
   mapWriterT allowFail'

withDefault' ::
   StateT s Maybe a ->
   StateT s Identity a ->
   StateT s Identity a
withDefault' p q =
   StateT $ \st ->
      maybe (runStateT q st) Identity (runStateT p st)

withDefault ::
   T output Maybe a ->
   T output Identity a ->
   T output Identity a
withDefault p q =
   WriterT $ withDefault' (runWriterT p) (runWriterT q)