module HSX.XMLGenerator where
import Control.Monad.Trans
import Control.Monad (liftM)
newtype XMLGenT m a = XMLGenT (m a)
deriving (Monad, Functor, MonadIO)
unXMLGenT :: XMLGenT m a -> m a
unXMLGenT (XMLGenT ma) = ma
instance MonadTrans XMLGenT where
lift = XMLGenT
type Name = (Maybe String, String)
class Monad m => XMLGenerator m where
type XML m
type Child m
type Attribute m
genElement :: Name -> [XMLGenT m (Attribute m)] -> [XMLGenT m [Child m]] -> XMLGenT m (XML m)
genEElement :: Name -> [XMLGenT m (Attribute m)] -> XMLGenT m (XML m)
genEElement n ats = genElement n ats []
class EmbedAsChild a c where
asChild :: a -> c
class EmbedAsAttr a at where
asAttr :: a -> at
data Attr n a = n := a
deriving Show
class XMLGenerator m => SetAttr m t where
setAttr :: t -> XMLGenT m (Attribute m) -> XMLGenT m (XML m)
setAll :: t -> XMLGenT m [Attribute m] -> XMLGenT m (XML m)
setAttr t v = setAll t $ liftM return v
(<@), set :: (SetAttr m t, EmbedAsAttr a (XMLGenT m (Attribute m))) => t -> a -> XMLGenT m (XML m)
set xml at = setAttr xml (asAttr at)
(<@) = set
(<<@) :: (SetAttr m t, EmbedAsAttr a (XMLGenT m (Attribute m))) => t -> [a] -> XMLGenT m (XML m)
xml <<@ ats = setAll xml (mapM asAttr ats)
class XMLGenerator m => AppendChild m t where
appChild :: t -> XMLGenT m (Child m) -> XMLGenT m (XML m)
appAll :: t -> XMLGenT m [Child m] -> XMLGenT m (XML m)
appChild t c = appAll t $ liftM return c
(<:), app :: (AppendChild m t, EmbedAsChild c (XMLGenT m [Child m])) => t -> c -> XMLGenT m (XML m)
app t c = appAll t $ asChild c
(<:) = app
class Show n => IsName n where
toName :: n -> Name
instance IsName Name where
toName = id
instance IsName String where
toName s = (Nothing, s)
instance IsName (String, String) where
toName (ns, s) = (Just ns, s)
class TypeCast a b | a -> b, b -> a where typeCast :: a -> b
class TypeCast' t a b | t a -> b, t b -> a where typeCast' :: t->a->b
class TypeCast'' t a b | t a -> b, t b -> a where typeCast'' :: t->a->b
instance TypeCast' () a b => TypeCast a b where typeCast x = typeCast' () x
instance TypeCast'' t a b => TypeCast' t a b where typeCast' = typeCast''
instance TypeCast'' () a a where typeCast'' _ x = x