    {-# LANGUAGE CPP, TypeFamilies, MultiParamTypeClasses, FunctionalDependencies,
          FlexibleContexts, FlexibleInstances, UndecidableInstances,
          TypeSynonymInstances, GeneralizedNewtypeDeriving #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  HSX.XMLGenerator
    -- Copyright   :  (c) Niklas Broberg 2008-2013
    -- License     :  BSD-style (see the file LICENSE.txt)
    --
    -- Maintainer  :  Niklas Broberg <niklas.broberg@gmail.com>
    -- Stability   :  experimental
    -- Portability :  requires newtype deriving and MPTCs with fundeps and type families
    --
    -- The class and monad transformer that forms the basis of the literal XML
    -- syntax translation. Literal tags will be translated into functions of
    -- the GenerateXML class, and any instantiating monads with associated XML
    -- types can benefit from that syntax.
    -----------------------------------------------------------------------------
    module HSP.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)
    import Data.Text.Lazy      (Text)
    import qualified Data.Text.Lazy as Text
    import qualified Data.Text      as Strict

    ----------------------------------------------
    -- General XML Generation

    -- | The monad transformer that allows a monad to generate XML values.
    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)

    -- | un-lift.
    unXMLGenT :: XMLGenT m a -> m a
    unXMLGenT   (XMLGenT ma) =  ma

    -- | map the inner monad
    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 a = (Maybe a, a)

    -- | Generate XML values in some XMLGenerator monad.
    class Monad m => XMLGen m where
     type XMLType m
     type StringType m
     data ChildType m
     data AttributeType m
     genElement    :: Name (StringType m) -> [XMLGenT m [AttributeType m]] -> [XMLGenT m [ChildType m]] -> XMLGenT m (XMLType m)
     genEElement   :: Name (StringType m) -> [XMLGenT m [AttributeType m]]                              -> XMLGenT m (XMLType m)
     genEElement n ats = genElement n ats []
     xmlToChild    :: XMLType m    -> ChildType m
     pcdataToChild :: StringType m -> ChildType m

    -- | Type synonyms to avoid writing out the XMLnGenT all the time
    type GenXML m           = XMLGenT m (XMLType m)
    type GenXMLList m       = XMLGenT m [XMLType m]
    type GenChild m         = XMLGenT m (ChildType m)
    type GenChildList m     = XMLGenT m [ChildType m]
    type GenAttribute m     = XMLGenT m (AttributeType m)
    type GenAttributeList m = XMLGenT m [AttributeType m]

    -- | Embed values as child nodes of an XML element. The parent type will be clear
    -- from the context so it is not mentioned.
    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 (ChildType m) where
     asChild = return . return

    #if __GLASGOW_HASKELL__ >= 610
    instance (XMLGen m,  XMLType m ~ x) => EmbedAsChild m x where
    #else
    instance (XMLGen m) => EmbedAsChild m (XMLType m) where
    #endif
     asChild = return . return . xmlToChild

    instance XMLGen m => EmbedAsChild m () where
     asChild _ = return []

    data Attr n a = n := a
      deriving Show

    -- | Similarly embed values as attributes of an XML element.
    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 (AttributeType m) where
     asAttr = return . return

    instance EmbedAsAttr m a => EmbedAsAttr m [a] where
     asAttr = liftM concat . mapM asAttr

    -- This is certainly true, but we want the various generators to explicitly state it,
    -- in order to get the error messages right.
    class ( XMLGen m
          , SetAttr m (XMLType m)
          , AppendChild m (XMLType m)
          , EmbedAsChild m (XMLType m)
          , EmbedAsChild m [XMLType m]
          , EmbedAsChild m Text
          , EmbedAsChild m Char -- for overlap purposes
          , EmbedAsChild m ()
          , EmbedAsAttr m (Attr Text Text)
          , EmbedAsAttr m (Attr Text Int)
          , EmbedAsAttr m (Attr Text Bool)
          ) => XMLGenerator m

    -------------------------------------
    -- Setting attributes

    -- | Set attributes on XML elements
    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

    -- | prepend @attr@ to the list of attributes for the @elem@
    (<@), set :: (SetAttr m elem, EmbedAsAttr m attr) => elem -> attr -> GenXML m
    set xml attr = setAll xml (asAttr attr)
    (<@) = set

    -- | prepend the list of @attr@ to the attributes for the @elem@
    (<<@) :: (SetAttr m elem, EmbedAsAttr m attr) => elem -> [attr] -> 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

    -------------------------------------
    -- Appending children

    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

    -- | append child to the children of @elem@
    (<:), app :: (AppendChild m elem, EmbedAsChild m c) => elem -> c -> GenXML m
    app xml c = appAll xml $ asChild c
    (<:) = app

    -- | append children to the children of @elem@
    (<<:) :: (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

    -------------------------------------
    -- Names

    -- | Names can be simple or qualified with a domain. We want to conveniently
    -- use both simple strings or pairs wherever a 'Name' is expected.
    class Show n => IsName n s where
        toName :: n -> Name s

    -- | Strings can represent names, meaning a simple name with no domain.
    instance IsName String String where
        toName s = (Nothing, s)

    -- | Strings can represent names, meaning a simple name with no domain.
    instance IsName String Text where
        toName s = (Nothing, Text.pack s)

    -- | Names can represent names, of course.
    instance (Show a) => IsName (Name a) a where
        toName = id

    -- | Pairs of strings can represent names, meaning a name qualified with a domain.
    instance IsName (String, String) Text where
        toName (ns, s) = (Just $ Text.pack ns, Text.pack s)

    -- | Strings can represent names, meaning a simple name with no domain.
    instance IsName Text Text where
     toName s = (Nothing, s)

    -- | strings can represent names, meaning a simple name with no domain.
    instance IsName Strict.Text Text where
     toName s = (Nothing, Text.fromStrict s)

    -- | Pairs of strings can represent names, meaning a name qualified with a domain.
    instance IsName (Text, Text) Text where
     toName (ns, s) = (Just $ ns, s)

    -- | Pairs of strings can represent names, meaning a name qualified with a domain.
    instance IsName (Strict.Text, Strict.Text) Text where
     toName (ns, s) = (Just $ Text.fromStrict ns, Text.fromStrict s)

    ---------------------------------------
    -- TypeCast, in lieu of ~ constraints

    -- literally lifted from the HList library
    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