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


import qualified Text.XML.Basic.Position as Position
import qualified Text.HTML.TagSoup.HT.Parser.Status as Status
import qualified Text.HTML.TagSoup.HT.Parser.Stream as Stream

{-
If we want to stay independent from transformers package
we have to define Stream without StateT.
-}
import Control.Monad.Trans.State (runStateT, )

import Control.Monad (MonadPlus, mzero, mplus, liftM, )
import Control.Monad.Fix (MonadFix, mfix, fix, )

import Data.Monoid (Monoid, mempty, mappend, )


newtype Identity a = Identity {runIdentity :: a}

instance Monad Identity where
   return = Identity
   m >>= k = k $ runIdentity m

instance MonadFix Identity where
   mfix f = Identity $ fix (runIdentity . f)

{- |
This type is essentially equivalent to @RWST () output Status.T fail a@,
but its monadic combinator @>>=@ is defined more lazily.
See Parser.MTL.
-}
newtype T input output fail a =
   Cons { run :: Status.T input -> fail (a, Status.T input, output) }


instance (Monoid output, Monad fail) => Monad (T input output fail) where
   return a = Cons $ \s -> return (a, s, mempty)
   m >>= k  = Cons $ \s -> do
	   ~(a, s', w)  <- run m s
	   ~(b, s'',w') <- run (k a) s'
	   return (b, s'', mappend w w')
   fail msg = Cons $ \_ -> fail msg

instance (Monoid output, MonadPlus fail) => MonadPlus (T input output fail) where
   mzero       = Cons $ \_ -> mzero
   m `mplus` n = Cons $ \s -> run m s `mplus` run n s


{- |
Cf. 'Control.Monad.State.gets'
-}
gets :: (Monoid output, Monad fail) =>
   (Status.T input -> a) -> T input output fail a
gets f =
   Cons $ \ st -> return (f st, st, mempty)

{- |
Cf. 'Control.Monad.Writer.tell'
-}
tell :: (Monad fail) => output -> T input output fail ()
tell ws = Cons $ \ st -> return ((),st,ws)


instance (Monoid output, MonadFix fail) => MonadFix (T input output fail) where
   mfix f = Cons $ \ st -> mfix $ \ ~(a, _, _) -> run (f a) st



nextChar ::
   (Monoid output, Stream.C input) =>
   T input output Maybe Char
nextChar =
   Cons $ \ (Status.Cons pos str) ->
      do (c,cs) <- runStateT Stream.getChar str
         return (c, Status.Cons (Position.updateOnChar c pos) cs, mempty)


-- this replaces 'ignoreEmit'
allowEmit ::
   Monad fail =>
   T input () fail a -> T input [w] fail a
allowEmit p =
   Cons $ liftM (\ ~(a,s,_) -> (a,s,mempty)) . run p

-- this replaces 'force'
allowFail :: T input output Identity a -> T input output Maybe a
allowFail p =
   Cons $ return . runIdentity . run p

withDefault ::
   T input output Maybe a ->
   T input output Identity a ->
   T input output Identity a
withDefault p q =
   Cons $ \s -> maybe (run q s) Identity (run p s)