module HSP.IdentityT
( evalIdentityT
, IdentT
, IdentityT(..)
) where
import Control.Applicative (Applicative((<*>), pure))
import Control.Monad (MonadPlus)
import Control.Monad.Writer (MonadWriter)
import Control.Monad.Reader (MonadReader)
import Control.Monad.State (MonadState)
import Control.Monad.RWS (MonadRWS)
import Control.Monad.Trans (MonadTrans(lift), MonadIO(liftIO))
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import HSP
import qualified HSX.XMLGenerator as HSX
newtype IdentityT m a = IdentityT { runIdentityT :: m a }
deriving (Functor, Monad, MonadWriter w, MonadReader r, MonadState s, MonadRWS r w s, MonadIO, MonadPlus)
instance (Applicative f) => Applicative (IdentityT f) where
pure = IdentityT . pure
(IdentityT f) <*> (IdentityT a) = IdentityT (f <*> a)
instance MonadTrans IdentityT where
lift = IdentityT
instance (Monad m, Functor m) => HSX.XMLGenerator (IdentityT m)
instance (Functor m, Monad m) => HSX.XMLGen (IdentityT m) where
type HSX.XML (IdentityT m) = XML
newtype HSX.Child (IdentityT m) = IChild { unIChild :: XML }
newtype HSX.Attribute (IdentityT m) = IAttr { unIAttr :: Attribute }
genElement n attrs children = HSX.XMLGenT $
do attrs' <- HSX.unXMLGenT (fmap (map unIAttr . concat) (sequence attrs))
children' <- HSX.unXMLGenT (fmap (map unIChild . concat) (sequence children))
return (Element (toName n) attrs' children')
xmlToChild = IChild
pcdataToChild = HSX.xmlToChild . pcdata
instance (Monad m, Functor m) => IsAttrValue (IdentityT m) T.Text where
toAttrValue = toAttrValue . T.unpack
instance (Monad m, Functor m) => IsAttrValue (IdentityT m) TL.Text where
toAttrValue = toAttrValue . TL.unpack
instance (Monad m, Functor m) => HSX.EmbedAsAttr (IdentityT m) Attribute where
asAttr = return . (:[]) . IAttr
instance (Monad m, Functor m) => HSX.EmbedAsAttr (IdentityT m) (Attr String Char) where
asAttr (n := c) = asAttr (n := [c])
instance (Monad m, Functor m) => HSX.EmbedAsAttr (IdentityT m) (Attr String String) where
asAttr (n := str) = asAttr $ MkAttr (toName n, pAttrVal str)
instance (Monad m, Functor m) => HSX.EmbedAsAttr (IdentityT m) (Attr String Bool) where
asAttr (n := True) = asAttr $ MkAttr (toName n, pAttrVal "true")
asAttr (n := False) = asAttr $ MkAttr (toName n, pAttrVal "false")
instance (Monad m, Functor m) => HSX.EmbedAsAttr (IdentityT m) (Attr String Int) where
asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal (show i))
instance (Monad m, Functor m, IsName n) => (EmbedAsAttr (IdentityT m) (Attr n TL.Text)) where
asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ TL.unpack a)
instance (Monad m, Functor m, IsName n) => (EmbedAsAttr (IdentityT m) (Attr n T.Text)) where
asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ T.unpack a)
instance (Monad m, Functor m) => EmbedAsChild (IdentityT m) Char where
asChild = XMLGenT . return . (:[]) . IChild . pcdata . (:[])
instance (Monad m, Functor m) => EmbedAsChild (IdentityT m) String where
asChild = XMLGenT . return . (:[]) . IChild . pcdata
instance (Monad m, Functor m) => EmbedAsChild (IdentityT m) (IdentityT m String) where
asChild c =
do c' <- lift c
lift . return . (:[]) . IChild . pcdata $ c'
instance (Monad m, Functor m) => (EmbedAsChild (IdentityT m) TL.Text) where
asChild = asChild . TL.unpack
instance (Monad m, Functor m) => (EmbedAsChild (IdentityT m) T.Text) where
asChild = asChild . T.unpack
instance (Monad m, Functor m) => EmbedAsChild (IdentityT m) XML where
asChild = XMLGenT . return . (:[]) . IChild
instance (Monad m, Functor m) => EmbedAsChild (IdentityT m) () where
asChild () = return []
instance (Monad m, Functor m) => AppendChild (IdentityT m) XML where
appAll xml children = do
chs <- children
case xml of
CDATA _ _ -> return xml
Element n as cs -> return $ Element n as (cs ++ (map stripChild chs))
stripAttr :: (Monad m, Functor m) => HSX.Attribute (IdentityT m) -> Attribute
stripAttr (IAttr a) = a
stripChild :: (Monad m, Functor m) => HSX.Child (IdentityT m) -> XML
stripChild (IChild c) = c
instance (Monad m, Functor m) => SetAttr (IdentityT m) XML where
setAll xml hats = do
attrs <- hats
case xml of
CDATA _ _ -> return xml
Element n as cs -> return $ Element n (foldr insert as (map stripAttr attrs)) cs
insert :: Attribute -> Attributes -> Attributes
insert = (:)
evalIdentityT :: (Functor m, Monad m) => XMLGenT (IdentityT m) XML -> m XML
evalIdentityT = runIdentityT . HSX.unXMLGenT
type IdentT m = XMLGenT (IdentityT m) XML