module Text.HTML.TagSoup.HT.Parser.Combinator (
   Parser.T, Full, Emitting, Fallible, Plain,
   char, dropSpaces, eof, getPos,
   many, many1, many1Satisfy, manySatisfy, readUntil,
   satisfy, string,
   emit,
   eval, write, gets, mfix,
   withDefault, allowFail, allowEmit,
   Identity, runIdentity, )
  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.Parser.Custom as Parser
-- import Text.HTML.TagSoup.HT.Parser.MTL as Parser

import Control.Monad (liftM, liftM2, )
import Control.Monad.Fix (mfix, )
-- import Control.Monad.Trans (lift, )

import Data.Monoid (Monoid)

import Data.Char (isSpace)



type Full     w = Parser.T [w] Maybe
type Fallible   = Parser.T ()  Maybe
type Emitting w = Parser.T [w] Identity
type Plain      = Parser.T ()  Identity


write :: Monad fail =>
   FilePath -> Parser.T [w] fail () -> String -> fail [w]
write fileName p =
   liftM (\ ~(_,_,ws) -> ws) .
   run p .
   Status.Cons (Position.initialize fileName)

eval ::  Monad fail =>
   FilePath -> Parser.T [w] fail a -> String -> fail a
eval fileName p =
   liftM (\ ~(x,_,_) -> x) .
   run p .
   Status.Cons (Position.initialize fileName)



eof ::
   (Monoid output, Monad fail) =>
   Parser.T output fail Bool
eof = gets (null . Status.source)

getPos ::
   (Monoid output, Monad fail) =>
   Parser.T output fail Position.T
getPos = gets Status.sourcePos

satisfy :: Monoid output => (Char -> Bool) -> Parser.T output Maybe Char
satisfy p =
   do c <- nextChar
      if p c
        then return c
        else fail "character not matched"

-- | does never fail
many :: Monoid output => Parser.T output Maybe a -> Parser.T output Identity [a]
many x =
   {- It is better to have 'force' at the place it is,
      instead of writing it to the recursive call,
      because 'x' can cause an infinite loop. -}
   withDefault (many1 x) (return [])

many1 :: Monoid output => Parser.T output Maybe a -> Parser.T output Maybe [a]
many1 x = liftM2 (:) x (allowFail $ many x)

manySatisfy :: (Char -> Bool) -> Parser.T [w] Identity String
manySatisfy =
   allowEmit . many . satisfy

many1Satisfy :: (Char -> Bool) -> Parser.T [w] Maybe String
many1Satisfy =
   allowEmit . many1 . satisfy

dropSpaces :: Parser.T [w] Identity ()
dropSpaces =
   manySatisfy isSpace >> return ()


char :: Monoid output => Char -> Parser.T output Maybe Char
char c = satisfy (c==)

string :: String -> Parser.T [w] Maybe String
string = allowEmit . mapM char


readUntil :: String -> Parser.T [w] Identity (Bool,String)
readUntil pattern =
   let recurse =
          foldr withDefault (return (False,[])) $
          liftM (const (True,[])) (mapM char pattern) :
          (do c <- nextChar
              ~(found,str) <- allowFail recurse
              return (found,c:str)) :
          []
   in  allowEmit recurse
{-
runStateT (readUntil "-->") (Position.initialize "input", "<!-- comment --> other stuff")
-}



emit :: Monad fail => w -> Parser.T [w] fail ()
emit w = tell [w]