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 ( (<$>), Applicative )
newtype TamperT t m a = TamperT { unTamperT :: StateT (DOM.NodeList t) m a }
deriving (Monad, Functor, Applicative)
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