{-#LANGUAGE GeneralizedNewtypeDeriving #-}
{-#LANGUAGE FlexibleInstances #-}
{-#LANGUAGE UndecidableInstances #-}
{-#LANGUAGE MultiParamTypeClasses #-}
{-#LANGUAGE FunctionalDependencies #-}
{-#LANGUAGE StandaloneDeriving #-}
{-#LANGUAGE TypeFamilies #-}
module Text.Tamper.Internal
( runTamperT
, TamperT
, nodeWithContent
, simpleNode
, attr
, (!)
, Attributable
, text, comment, cdata, preEscaped
)
where

import Data.Monoid
import Data.String
import Control.Monad
import Control.Monad.State
import Control.Monad.Writer
import Control.Monad.Reader
import qualified Text.Tamper.DOM as DOM
import Control.Applicative ( (<$>) )

newtype TamperT t m a = TamperT { unTamperT :: StateT (DOM.NodeList t) m a }
    deriving (Monad, Functor)

-- | Note that this instance declaration is actually a lie: the `a` value
-- cannot be used, but is required to avoid ambiguous instances.
instance (IsString t, Monad m, a ~ ()) => IsString (TamperT t m a) where
    fromString str = do
        simpleNode . DOM.textNode . fromString $ str

instance (MonadState s m) => (MonadState s) (TamperT t m) where
    get = TamperT $ lift get
    put x = TamperT $ lift (put x)

deriving instance (MonadWriter s m) => (MonadWriter s) (TamperT t m)

deriving instance (MonadReader s m) => (MonadReader s) (TamperT t m)

runTamperT :: (Monad m) => TamperT t m a -> m (a, DOM.NodeList t)
runTamperT (TamperT a) = do
    (a, s) <- runStateT a mempty
    return (a, DOM.nodeList . reverse . DOM.unNodeList $ s)

text :: Monad m => t -> TamperT t m ()
text t = simpleNode $ DOM.textNode t

comment :: Monad m => t -> TamperT t m ()
comment t = simpleNode $ DOM.commentNode t

cdata :: Monad m => t -> TamperT t m ()
cdata t = simpleNode $ DOM.cdataNode t

preEscaped :: Monad m => t -> TamperT t m ()
preEscaped t = simpleNode $ DOM.rawHtmlNode t

simpleNode :: Monad m => DOM.Node t -> TamperT t m ()
simpleNode node =
    TamperT $ modify (DOM.singletonNodeList node <>)

nodeWithContent :: Monad m => DOM.Node t -> TamperT t m a -> TamperT t m a
nodeWithContent node inner = do
    (result, innerNodes) <- TamperT $ lift $ runTamperT inner
    let node' = DOM.appendChildren innerNodes node
    simpleNode node'
    return result

attr :: (Monad m, Functor m, Ord t) => TamperT t m a -> t -> t -> TamperT t m a
attr a name value = TamperT $ do
    result <- unTamperT a
    nodes <- DOM.unNodeList <$> get
    let nodes' = case nodes of
                    x:xs -> DOM.setAttr name value x:xs
                    xs -> xs
    put $ DOM.nodeList nodes'
    return result

class Attributable t a | a -> t where
    (!) :: a -> (t, t) -> a

instance (Ord t, Monad m, Functor m) => Attributable t (TamperT t m ()) where
    (!) a (name, value) = attr a name value

instance (Ord t, Monad m, Functor m) => Attributable t (TamperT t m a -> TamperT t m a) where
    (!) f (name, value) children = attr (f children) name value