module HSX.XMLGenerator where
import Control.Applicative (Applicative, Alternative)
import Control.Monad.Trans (MonadTrans(lift), MonadIO)
import Control.Monad.Cont (MonadCont)
import Control.Monad.Error (MonadError)
import Control.Monad.Reader(MonadReader)
import Control.Monad.Writer(MonadWriter)
import Control.Monad.State (MonadState)
import Control.Monad.RWS (MonadRWS)
import Control.Monad (MonadPlus(..),liftM)
newtype XMLGenT m a = XMLGenT (m a)
deriving (Applicative, Alternative, Monad, Functor, MonadIO, MonadPlus, MonadWriter w, MonadReader r,
MonadState s, MonadRWS r w s, MonadCont, MonadError e)
unXMLGenT :: XMLGenT m a -> m a
unXMLGenT (XMLGenT ma) = ma
mapXMLGenT :: (m a -> n b) -> XMLGenT m a -> XMLGenT n b
mapXMLGenT f (XMLGenT m) = XMLGenT (f m)
instance MonadTrans XMLGenT where
lift = XMLGenT
type Name = (Maybe String, String)
class Monad m => XMLGen m where
type XML m
data Child m
data 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 []
xmlToChild :: XML m -> Child m
pcdataToChild :: String -> Child m
type GenXML m = XMLGenT m (XML m)
type GenXMLList m = XMLGenT m [XML m]
type GenChild m = XMLGenT m (Child m)
type GenChildList m = XMLGenT m [Child m]
type GenAttribute m = XMLGenT m (Attribute m)
type GenAttributeList m = XMLGenT m [Attribute m]
class XMLGen m => EmbedAsChild m c where
asChild :: c -> GenChildList m
#if __GLASGOW_HASKELL__ >= 610
instance (EmbedAsChild m c, m ~ n) => EmbedAsChild m (XMLGenT n c) where
asChild m = asChild =<< m
#else
instance (EmbedAsChild m c, TypeCastM m1 m) => EmbedAsChild m (XMLGenT m1 c) where
asChild (XMLGenT m1a) = do
a <- XMLGenT $ typeCastM m1a
asChild a
#endif
instance EmbedAsChild m c => EmbedAsChild m [c] where
asChild = liftM concat . mapM asChild
instance XMLGen m => EmbedAsChild m (Child m) where
asChild = return . return
#if __GLASGOW_HASKELL__ >= 610
instance (XMLGen m, XML m ~ x) => EmbedAsChild m x where
#else
instance (XMLGen m) => EmbedAsChild m (XML m) where
#endif
asChild = return . return . xmlToChild
instance XMLGen m => EmbedAsChild m String where
asChild = return . return . pcdataToChild
class XMLGen m => EmbedAsAttr m a where
asAttr :: a -> GenAttributeList m
instance (XMLGen m, EmbedAsAttr m a) => EmbedAsAttr m (XMLGenT m a) where
asAttr ma = ma >>= asAttr
instance (EmbedAsAttr m (Attr a v), TypeCastM m1 m) => EmbedAsAttr m (Attr a (XMLGenT m1 v)) where
asAttr (a := (XMLGenT m1a)) = do
v <- XMLGenT $ typeCastM m1a
asAttr (a := v)
instance XMLGen m => EmbedAsAttr m (Attribute m) where
asAttr = return . return
instance EmbedAsAttr m a => EmbedAsAttr m [a] where
asAttr = liftM concat . mapM asAttr
class (XMLGen m,
SetAttr m (XML m),
AppendChild m (XML m),
EmbedAsChild m (XML m),
EmbedAsChild m [XML m],
EmbedAsChild m String,
EmbedAsChild m Char,
EmbedAsAttr m (Attr String String),
EmbedAsAttr m (Attr String Int),
EmbedAsAttr m (Attr String Bool)
) => XMLGenerator m
data Attr n a = n := a
deriving Show
class XMLGen m => SetAttr m elem where
setAttr :: elem -> GenAttribute m -> GenXML m
setAll :: elem -> GenAttributeList m -> GenXML m
setAttr e a = setAll e $ liftM return a
(<@), set :: (SetAttr m elem, EmbedAsAttr m attr) => elem -> attr -> GenXML m
set xml attr = setAll xml (asAttr attr)
(<@) = set
(<<@) :: (SetAttr m elem, EmbedAsAttr m a) => elem -> [a] -> GenXML m
xml <<@ ats = setAll xml (liftM concat $ mapM asAttr ats)
instance (TypeCastM m1 m, SetAttr m x) =>
SetAttr m (XMLGenT m1 x) where
setAll (XMLGenT m1x) ats = (XMLGenT $ typeCastM m1x) >>= (flip setAll) ats
class XMLGen m => AppendChild m elem where
appChild :: elem -> GenChild m -> GenXML m
appAll :: elem -> GenChildList m -> GenXML m
appChild e c = appAll e $ liftM return c
(<:), app :: (AppendChild m elem, EmbedAsChild m c) => elem -> c -> GenXML m
app xml c = appAll xml $ asChild c
(<:) = app
(<<:) :: (AppendChild m elem, EmbedAsChild m c) => elem -> [c] -> GenXML m
xml <<: chs = appAll xml (liftM concat $ mapM asChild chs)
instance (AppendChild m x, TypeCastM m1 m) =>
AppendChild m (XMLGenT m1 x) where
appAll (XMLGenT m1x) chs = (XMLGenT $ typeCastM m1x) >>= (flip appAll) chs
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
class TypeCastM ma mb | ma -> mb, mb -> ma where typeCastM :: ma x -> mb x
class TypeCastM' t ma mb | t ma -> mb, t mb -> ma where typeCastM' :: t -> ma x -> mb x
class TypeCastM'' t ma mb | t ma -> mb, t mb -> ma where typeCastM'' :: t -> ma x -> mb x
instance TypeCastM' () ma mb => TypeCastM ma mb where typeCastM mx = typeCastM' () mx
instance TypeCastM'' t ma mb => TypeCastM' t ma mb where typeCastM' = typeCastM''
instance TypeCastM'' () ma ma where typeCastM'' _ x = x