content: {-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, TypeFamilies, GeneralizedNewtypeDeriving #-}
  {-# OPTIONS_GHC -fno-warn-orphans  #-}
  module T4809_IdentityT
      ( evalIdentityT
      , IdentityT(..)
      , XML(..)
      ) where
  
  import Control.Applicative (Applicative, Alternative)
  import Control.Monad        (MonadPlus)
  import Control.Monad.Trans  (MonadTrans(lift), MonadIO(liftIO))
  import T4809_XMLGenerator (XMLGenT(..), EmbedAsChild(..), Name)
  import qualified T4809_XMLGenerator as HSX
  
  data XML
    = Element Name [Int] [XML] | CDATA Bool String
      deriving Show
  
  -- * IdentityT Monad Transformer
  
  newtype IdentityT m a = IdentityT { runIdentityT :: m a }
      deriving (Functor, Applicative, Alternative, Monad, MonadIO, MonadPlus)
  
  instance MonadTrans IdentityT where
      lift = IdentityT
  
  evalIdentityT :: (Functor m, Monad m) => XMLGenT (IdentityT m) XML -> m XML
  evalIdentityT = runIdentityT . HSX.unXMLGenT
  
  -- * HSX.XMLGenerator for IdentityT
  
  instance (Functor m, Monad m) => HSX.XMLGen (IdentityT m) where
      type XML (IdentityT m) = XML
      newtype Child (IdentityT m) = IChild { unIChild :: XML }
      genElement n _attrs children = HSX.XMLGenT $ 
                                    do children' <- HSX.unXMLGenT (fmap (map unIChild . concat) (sequence children))
                                       return (Element n [] children')
  
  instance (Monad m, MonadIO m, Functor m) => EmbedAsChild (IdentityT m) String where
      asChild s = 
          do liftIO $ putStrLn "EmbedAsChild (IdentityT m) String"
             XMLGenT . return . (:[]) . IChild . CDATA True $ s
  