XMLGenerator.hs

{-# 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

----------------------------------------------
-- 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)

-- | 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)

---------------------------------------
-- 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