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


import qualified Text.HTML.TagSoup.HT.Position as Position
import qualified Text.HTML.TagSoup.HT.Parser.Status as Status

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 output fail a =
   Cons { run :: Status.T -> fail (a, Status.T, output) }


instance (Monoid output, Monad fail) => Monad (T 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 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 -> a) -> T output fail a
gets f =
   Cons $ \ st -> return (f st, st, mempty)

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


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



nextChar :: (Monoid output, MonadPlus fail) => T output fail Char
nextChar =
   Cons $ \ (Status.Cons pos str) ->
      case str of
         []     -> mzero
         (c:cs) -> return (c, Status.Cons (Position.updateOnChar c pos) cs, mempty)


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

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

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