{-# 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 (Functor (XMLGenT m)
Functor (XMLGenT m)
-> (forall a. a -> XMLGenT m a)
-> (forall a b. XMLGenT m (a -> b) -> XMLGenT m a -> XMLGenT m b)
-> (forall a b c.
    (a -> b -> c) -> XMLGenT m a -> XMLGenT m b -> XMLGenT m c)
-> (forall a b. XMLGenT m a -> XMLGenT m b -> XMLGenT m b)
-> (forall a b. XMLGenT m a -> XMLGenT m b -> XMLGenT m a)
-> Applicative (XMLGenT m)
forall a. a -> XMLGenT m a
forall a b. XMLGenT m a -> XMLGenT m b -> XMLGenT m a
forall a b. XMLGenT m a -> XMLGenT m b -> XMLGenT m b
forall a b. XMLGenT m (a -> b) -> XMLGenT m a -> XMLGenT m b
forall a b c.
(a -> b -> c) -> XMLGenT m a -> XMLGenT m b -> XMLGenT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall {m :: * -> *}. Applicative m => Functor (XMLGenT m)
forall (m :: * -> *) a. Applicative m => a -> XMLGenT m a
forall (m :: * -> *) a b.
Applicative m =>
XMLGenT m a -> XMLGenT m b -> XMLGenT m a
forall (m :: * -> *) a b.
Applicative m =>
XMLGenT m a -> XMLGenT m b -> XMLGenT m b
forall (m :: * -> *) a b.
Applicative m =>
XMLGenT m (a -> b) -> XMLGenT m a -> XMLGenT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> XMLGenT m a -> XMLGenT m b -> XMLGenT m c
<* :: forall a b. XMLGenT m a -> XMLGenT m b -> XMLGenT m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
XMLGenT m a -> XMLGenT m b -> XMLGenT m a
*> :: forall a b. XMLGenT m a -> XMLGenT m b -> XMLGenT m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
XMLGenT m a -> XMLGenT m b -> XMLGenT m b
liftA2 :: forall a b c.
(a -> b -> c) -> XMLGenT m a -> XMLGenT m b -> XMLGenT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> XMLGenT m a -> XMLGenT m b -> XMLGenT m c
<*> :: forall a b. XMLGenT m (a -> b) -> XMLGenT m a -> XMLGenT m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
XMLGenT m (a -> b) -> XMLGenT m a -> XMLGenT m b
pure :: forall a. a -> XMLGenT m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> XMLGenT m a
Applicative, Applicative (XMLGenT m)
Applicative (XMLGenT m)
-> (forall a. XMLGenT m a)
-> (forall a. XMLGenT m a -> XMLGenT m a -> XMLGenT m a)
-> (forall a. XMLGenT m a -> XMLGenT m [a])
-> (forall a. XMLGenT m a -> XMLGenT m [a])
-> Alternative (XMLGenT m)
forall a. XMLGenT m a
forall a. XMLGenT m a -> XMLGenT m [a]
forall a. XMLGenT m a -> XMLGenT m a -> XMLGenT m a
forall (f :: * -> *).
Applicative f
-> (forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
forall {m :: * -> *}. Alternative m => Applicative (XMLGenT m)
forall (m :: * -> *) a. Alternative m => XMLGenT m a
forall (m :: * -> *) a.
Alternative m =>
XMLGenT m a -> XMLGenT m [a]
forall (m :: * -> *) a.
Alternative m =>
XMLGenT m a -> XMLGenT m a -> XMLGenT m a
many :: forall a. XMLGenT m a -> XMLGenT m [a]
$cmany :: forall (m :: * -> *) a.
Alternative m =>
XMLGenT m a -> XMLGenT m [a]
some :: forall a. XMLGenT m a -> XMLGenT m [a]
$csome :: forall (m :: * -> *) a.
Alternative m =>
XMLGenT m a -> XMLGenT m [a]
<|> :: forall a. XMLGenT m a -> XMLGenT m a -> XMLGenT m a
$c<|> :: forall (m :: * -> *) a.
Alternative m =>
XMLGenT m a -> XMLGenT m a -> XMLGenT m a
empty :: forall a. XMLGenT m a
$cempty :: forall (m :: * -> *) a. Alternative m => XMLGenT m a
Alternative, Applicative (XMLGenT m)
Applicative (XMLGenT m)
-> (forall a b. XMLGenT m a -> (a -> XMLGenT m b) -> XMLGenT m b)
-> (forall a b. XMLGenT m a -> XMLGenT m b -> XMLGenT m b)
-> (forall a. a -> XMLGenT m a)
-> Monad (XMLGenT m)
forall a. a -> XMLGenT m a
forall a b. XMLGenT m a -> XMLGenT m b -> XMLGenT m b
forall a b. XMLGenT m a -> (a -> XMLGenT m b) -> XMLGenT m b
forall {m :: * -> *}. Monad m => Applicative (XMLGenT m)
forall (m :: * -> *) a. Monad m => a -> XMLGenT m a
forall (m :: * -> *) a b.
Monad m =>
XMLGenT m a -> XMLGenT m b -> XMLGenT m b
forall (m :: * -> *) a b.
Monad m =>
XMLGenT m a -> (a -> XMLGenT m b) -> XMLGenT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> XMLGenT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> XMLGenT m a
>> :: forall a b. XMLGenT m a -> XMLGenT m b -> XMLGenT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
XMLGenT m a -> XMLGenT m b -> XMLGenT m b
>>= :: forall a b. XMLGenT m a -> (a -> XMLGenT m b) -> XMLGenT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
XMLGenT m a -> (a -> XMLGenT m b) -> XMLGenT m b
Monad, (forall a b. (a -> b) -> XMLGenT m a -> XMLGenT m b)
-> (forall a b. a -> XMLGenT m b -> XMLGenT m a)
-> Functor (XMLGenT m)
forall a b. a -> XMLGenT m b -> XMLGenT m a
forall a b. (a -> b) -> XMLGenT m a -> XMLGenT m b
forall (m :: * -> *) a b.
Functor m =>
a -> XMLGenT m b -> XMLGenT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> XMLGenT m a -> XMLGenT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> XMLGenT m b -> XMLGenT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> XMLGenT m b -> XMLGenT m a
fmap :: forall a b. (a -> b) -> XMLGenT m a -> XMLGenT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> XMLGenT m a -> XMLGenT m b
Functor, Monad (XMLGenT m)
Monad (XMLGenT m)
-> (forall a. IO a -> XMLGenT m a) -> MonadIO (XMLGenT m)
forall a. IO a -> XMLGenT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall {m :: * -> *}. MonadIO m => Monad (XMLGenT m)
forall (m :: * -> *) a. MonadIO m => IO a -> XMLGenT m a
liftIO :: forall a. IO a -> XMLGenT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> XMLGenT m a
MonadIO, Monad (XMLGenT m)
Alternative (XMLGenT m)
Alternative (XMLGenT m)
-> Monad (XMLGenT m)
-> (forall a. XMLGenT m a)
-> (forall a. XMLGenT m a -> XMLGenT m a -> XMLGenT m a)
-> MonadPlus (XMLGenT m)
forall a. XMLGenT m a
forall a. XMLGenT m a -> XMLGenT m a -> XMLGenT m a
forall {m :: * -> *}. MonadPlus m => Monad (XMLGenT m)
forall {m :: * -> *}. MonadPlus m => Alternative (XMLGenT m)
forall (m :: * -> *) a. MonadPlus m => XMLGenT m a
forall (m :: * -> *) a.
MonadPlus m =>
XMLGenT m a -> XMLGenT m a -> XMLGenT m a
forall (m :: * -> *).
Alternative m
-> Monad m
-> (forall a. m a)
-> (forall a. m a -> m a -> m a)
-> MonadPlus m
mplus :: forall a. XMLGenT m a -> XMLGenT m a -> XMLGenT m a
$cmplus :: forall (m :: * -> *) a.
MonadPlus m =>
XMLGenT m a -> XMLGenT m a -> XMLGenT m a
mzero :: forall a. XMLGenT m a
$cmzero :: forall (m :: * -> *) a. MonadPlus m => XMLGenT m a
MonadPlus, MonadWriter w, MonadReader r,
            MonadState s, MonadRWS r w s, Monad (XMLGenT m)
Monad (XMLGenT m)
-> (forall a b. ((a -> XMLGenT m b) -> XMLGenT m a) -> XMLGenT m a)
-> MonadCont (XMLGenT m)
forall a b. ((a -> XMLGenT m b) -> XMLGenT m a) -> XMLGenT m a
forall (m :: * -> *).
Monad m -> (forall a b. ((a -> m b) -> m a) -> m a) -> MonadCont m
forall {m :: * -> *}. MonadCont m => Monad (XMLGenT m)
forall (m :: * -> *) a b.
MonadCont m =>
((a -> XMLGenT m b) -> XMLGenT m a) -> XMLGenT m a
callCC :: forall a b. ((a -> XMLGenT m b) -> XMLGenT m a) -> XMLGenT m a
$ccallCC :: forall (m :: * -> *) a b.
MonadCont m =>
((a -> XMLGenT m b) -> XMLGenT m a) -> XMLGenT m a
MonadCont, MonadError e)

-- | un-lift.

unXMLGenT :: XMLGenT m a -> m a
unXMLGenT :: forall (m :: * -> *) a. XMLGenT m a -> m a
unXMLGenT   (XMLGenT m a
ma) =  m a
ma

-- | map the inner monad

mapXMLGenT :: (m a -> n b) -> XMLGenT m a -> XMLGenT n b
mapXMLGenT :: forall (m :: * -> *) a (n :: * -> *) b.
(m a -> n b) -> XMLGenT m a -> XMLGenT n b
mapXMLGenT m a -> n b
f (XMLGenT m a
m) = n b -> XMLGenT n b
forall (m :: * -> *) a. m a -> XMLGenT m a
XMLGenT (m a -> n b
f m a
m)

instance MonadTrans XMLGenT where
 lift :: forall (m :: * -> *) a. Monad m => m a -> XMLGenT m a
lift = m a -> XMLGenT m a
forall (m :: * -> *) a. m a -> XMLGenT m a
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 Name (StringType m)
n [XMLGenT m [AttributeType m]]
ats = Name (StringType m)
-> [XMLGenT m [AttributeType m]]
-> [XMLGenT m [ChildType m]]
-> XMLGenT m (XMLType m)
forall (m :: * -> *).
XMLGen m =>
Name (StringType m)
-> [XMLGenT m [AttributeType m]]
-> [XMLGenT m [ChildType m]]
-> XMLGenT m (XMLType m)
genElement Name (StringType m)
n [XMLGenT m [AttributeType m]]
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 :: XMLGenT n c -> GenChildList m
asChild XMLGenT n c
m = c -> GenChildList n
forall (m :: * -> *) c. EmbedAsChild m c => c -> GenChildList m
asChild (c -> GenChildList n) -> XMLGenT n c -> GenChildList n
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< XMLGenT n c
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 :: [c] -> GenChildList m
asChild = ([[ChildType m]] -> [ChildType m])
-> XMLGenT m [[ChildType m]] -> GenChildList m
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[ChildType m]] -> [ChildType m]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (XMLGenT m [[ChildType m]] -> GenChildList m)
-> ([c] -> XMLGenT m [[ChildType m]]) -> [c] -> GenChildList m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c -> GenChildList m) -> [c] -> XMLGenT m [[ChildType m]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM c -> GenChildList m
forall (m :: * -> *) c. EmbedAsChild m c => c -> GenChildList m
asChild

instance XMLGen m => EmbedAsChild m (ChildType m) where
 asChild :: ChildType m -> GenChildList m
asChild = [ChildType m] -> GenChildList m
forall (m :: * -> *) a. Monad m => a -> m a
return ([ChildType m] -> GenChildList m)
-> (ChildType m -> [ChildType m]) -> ChildType m -> GenChildList m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChildType m -> [ChildType m]
forall (m :: * -> *) a. Monad m => a -> m a
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 :: x -> GenChildList m
asChild = [ChildType m] -> GenChildList m
forall (m :: * -> *) a. Monad m => a -> m a
return ([ChildType m] -> GenChildList m)
-> (x -> [ChildType m]) -> x -> GenChildList m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChildType m -> [ChildType m]
forall (m :: * -> *) a. Monad m => a -> m a
return (ChildType m -> [ChildType m])
-> (x -> ChildType m) -> x -> [ChildType m]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> ChildType m
forall (m :: * -> *). XMLGen m => XMLType m -> ChildType m
xmlToChild

instance XMLGen m => EmbedAsChild m () where
 asChild :: () -> GenChildList m
asChild ()
_ = [ChildType m] -> GenChildList m
forall (m :: * -> *) a. Monad m => a -> m a
return []

data Attr n a = n := a
  deriving Int -> Attr n a -> ShowS
[Attr n a] -> ShowS
Attr n a -> String
(Int -> Attr n a -> ShowS)
-> (Attr n a -> String) -> ([Attr n a] -> ShowS) -> Show (Attr n a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall n a. (Show n, Show a) => Int -> Attr n a -> ShowS
forall n a. (Show n, Show a) => [Attr n a] -> ShowS
forall n a. (Show n, Show a) => Attr n a -> String
showList :: [Attr n a] -> ShowS
$cshowList :: forall n a. (Show n, Show a) => [Attr n a] -> ShowS
show :: Attr n a -> String
$cshow :: forall n a. (Show n, Show a) => Attr n a -> String
showsPrec :: Int -> Attr n a -> ShowS
$cshowsPrec :: forall n a. (Show n, Show a) => Int -> Attr n a -> ShowS
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 :: XMLGenT m a -> GenAttributeList m
asAttr XMLGenT m a
ma = XMLGenT m a
ma XMLGenT m a -> (a -> GenAttributeList m) -> GenAttributeList m
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> GenAttributeList m
forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr

instance (EmbedAsAttr m (Attr a v), TypeCastM m1 m) => EmbedAsAttr m (Attr a (XMLGenT m1 v)) where
 asAttr :: Attr a (XMLGenT m1 v) -> GenAttributeList m
asAttr (a
a := (XMLGenT m1 v
m1a)) = do
            v
v <- m v -> XMLGenT m v
forall (m :: * -> *) a. m a -> XMLGenT m a
XMLGenT (m v -> XMLGenT m v) -> m v -> XMLGenT m v
forall a b. (a -> b) -> a -> b
$ m1 v -> m v
forall (ma :: * -> *) (mb :: * -> *) x.
TypeCastM ma mb =>
ma x -> mb x
typeCastM m1 v
m1a
            Attr a v -> GenAttributeList m
forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr (a
a a -> v -> Attr a v
forall n a. n -> a -> Attr n a
:= v
v)

instance XMLGen m => EmbedAsAttr m (AttributeType m) where
 asAttr :: AttributeType m -> GenAttributeList m
asAttr = [AttributeType m] -> GenAttributeList m
forall (m :: * -> *) a. Monad m => a -> m a
return ([AttributeType m] -> GenAttributeList m)
-> (AttributeType m -> [AttributeType m])
-> AttributeType m
-> GenAttributeList m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttributeType m -> [AttributeType m]
forall (m :: * -> *) a. Monad m => a -> m a
return

instance EmbedAsAttr m a => EmbedAsAttr m [a] where
 asAttr :: [a] -> GenAttributeList m
asAttr = ([[AttributeType m]] -> [AttributeType m])
-> XMLGenT m [[AttributeType m]] -> GenAttributeList m
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[AttributeType m]] -> [AttributeType m]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (XMLGenT m [[AttributeType m]] -> GenAttributeList m)
-> ([a] -> XMLGenT m [[AttributeType m]])
-> [a]
-> GenAttributeList m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> GenAttributeList m) -> [a] -> XMLGenT m [[AttributeType m]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> GenAttributeList m
forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
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 elem
e GenAttribute m
a = elem -> GenAttributeList m -> GenXML m
forall (m :: * -> *) elem.
SetAttr m elem =>
elem -> GenAttributeList m -> GenXML m
setAll elem
e (GenAttributeList m -> GenXML m) -> GenAttributeList m -> GenXML m
forall a b. (a -> b) -> a -> b
$ (AttributeType m -> [AttributeType m])
-> GenAttribute m -> GenAttributeList m
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM AttributeType m -> [AttributeType m]
forall (m :: * -> *) a. Monad m => a -> m a
return GenAttribute m
a

-- | prepend @attr@ to the list of attributes for the @elem@

(<@), set :: (SetAttr m elem, EmbedAsAttr m attr) => elem -> attr -> GenXML m
set :: forall (m :: * -> *) elem attr.
(SetAttr m elem, EmbedAsAttr m attr) =>
elem -> attr -> GenXML m
set elem
xml attr
attr = elem -> GenAttributeList m -> GenXML m
forall (m :: * -> *) elem.
SetAttr m elem =>
elem -> GenAttributeList m -> GenXML m
setAll elem
xml (attr -> GenAttributeList m
forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr attr
attr)
<@ :: forall (m :: * -> *) elem attr.
(SetAttr m elem, EmbedAsAttr m attr) =>
elem -> attr -> GenXML m
(<@) = elem -> attr -> GenXML m
forall (m :: * -> *) elem attr.
(SetAttr m elem, EmbedAsAttr m attr) =>
elem -> attr -> GenXML m
set

-- | prepend the list of @attr@ to the attributes for the @elem@

(<<@) :: (SetAttr m elem, EmbedAsAttr m attr) => elem -> [attr] -> GenXML m
elem
xml <<@ :: forall (m :: * -> *) elem attr.
(SetAttr m elem, EmbedAsAttr m attr) =>
elem -> [attr] -> GenXML m
<<@ [attr]
ats = elem -> GenAttributeList m -> GenXML m
forall (m :: * -> *) elem.
SetAttr m elem =>
elem -> GenAttributeList m -> GenXML m
setAll elem
xml (([[AttributeType m]] -> [AttributeType m])
-> XMLGenT m [[AttributeType m]] -> GenAttributeList m
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[AttributeType m]] -> [AttributeType m]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (XMLGenT m [[AttributeType m]] -> GenAttributeList m)
-> XMLGenT m [[AttributeType m]] -> GenAttributeList m
forall a b. (a -> b) -> a -> b
$ (attr -> GenAttributeList m)
-> [attr] -> XMLGenT m [[AttributeType m]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM attr -> GenAttributeList m
forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr [attr]
ats)

instance (TypeCastM m1 m, SetAttr m x) =>
        SetAttr m (XMLGenT m1 x) where
 setAll :: XMLGenT m1 x -> GenAttributeList m -> GenXML m
setAll (XMLGenT m1 x
m1x) GenAttributeList m
ats = (m x -> XMLGenT m x
forall (m :: * -> *) a. m a -> XMLGenT m a
XMLGenT (m x -> XMLGenT m x) -> m x -> XMLGenT m x
forall a b. (a -> b) -> a -> b
$ m1 x -> m x
forall (ma :: * -> *) (mb :: * -> *) x.
TypeCastM ma mb =>
ma x -> mb x
typeCastM m1 x
m1x) XMLGenT m x -> (x -> GenXML m) -> GenXML m
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((x -> GenAttributeList m -> GenXML m)
-> GenAttributeList m -> x -> GenXML m
forall a b c. (a -> b -> c) -> b -> a -> c
flip x -> GenAttributeList m -> GenXML m
forall (m :: * -> *) elem.
SetAttr m elem =>
elem -> GenAttributeList m -> GenXML m
setAll) GenAttributeList m
ats

-------------------------------------

-- Appending children


class XMLGen m => AppendChild m elem where
 appChild :: elem -> GenChild m     -> GenXML m
 appAll   :: elem -> GenChildList m -> GenXML m
 appChild elem
e GenChild m
c = elem -> GenChildList m -> GenXML m
forall (m :: * -> *) elem.
AppendChild m elem =>
elem -> GenChildList m -> GenXML m
appAll elem
e (GenChildList m -> GenXML m) -> GenChildList m -> GenXML m
forall a b. (a -> b) -> a -> b
$ (ChildType m -> [ChildType m]) -> GenChild m -> GenChildList m
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ChildType m -> [ChildType m]
forall (m :: * -> *) a. Monad m => a -> m a
return GenChild m
c

-- | append child to the children of @elem@

(<:), app :: (AppendChild m elem, EmbedAsChild m c) => elem -> c -> GenXML m
app :: forall (m :: * -> *) elem c.
(AppendChild m elem, EmbedAsChild m c) =>
elem -> c -> GenXML m
app elem
xml c
c = elem -> GenChildList m -> GenXML m
forall (m :: * -> *) elem.
AppendChild m elem =>
elem -> GenChildList m -> GenXML m
appAll elem
xml (GenChildList m -> GenXML m) -> GenChildList m -> GenXML m
forall a b. (a -> b) -> a -> b
$ c -> GenChildList m
forall (m :: * -> *) c. EmbedAsChild m c => c -> GenChildList m
asChild c
c
<: :: forall (m :: * -> *) elem c.
(AppendChild m elem, EmbedAsChild m c) =>
elem -> c -> GenXML m
(<:) = elem -> c -> GenXML m
forall (m :: * -> *) elem c.
(AppendChild m elem, EmbedAsChild m c) =>
elem -> c -> GenXML m
app

-- | append children to the children of @elem@

(<<:) :: (AppendChild m elem, EmbedAsChild m c) => elem -> [c] -> GenXML m
elem
xml <<: :: forall (m :: * -> *) elem c.
(AppendChild m elem, EmbedAsChild m c) =>
elem -> [c] -> GenXML m
<<: [c]
chs = elem -> GenChildList m -> GenXML m
forall (m :: * -> *) elem.
AppendChild m elem =>
elem -> GenChildList m -> GenXML m
appAll elem
xml (([[ChildType m]] -> [ChildType m])
-> XMLGenT m [[ChildType m]] -> GenChildList m
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[ChildType m]] -> [ChildType m]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (XMLGenT m [[ChildType m]] -> GenChildList m)
-> XMLGenT m [[ChildType m]] -> GenChildList m
forall a b. (a -> b) -> a -> b
$ (c -> GenChildList m) -> [c] -> XMLGenT m [[ChildType m]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM c -> GenChildList m
forall (m :: * -> *) c. EmbedAsChild m c => c -> GenChildList m
asChild [c]
chs)

instance (AppendChild m x, TypeCastM m1 m) =>
        AppendChild m (XMLGenT m1 x) where
 appAll :: XMLGenT m1 x -> GenChildList m -> GenXML m
appAll (XMLGenT m1 x
m1x) GenChildList m
chs = (m x -> XMLGenT m x
forall (m :: * -> *) a. m a -> XMLGenT m a
XMLGenT (m x -> XMLGenT m x) -> m x -> XMLGenT m x
forall a b. (a -> b) -> a -> b
$ m1 x -> m x
forall (ma :: * -> *) (mb :: * -> *) x.
TypeCastM ma mb =>
ma x -> mb x
typeCastM m1 x
m1x) XMLGenT m x -> (x -> GenXML m) -> GenXML m
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((x -> GenChildList m -> GenXML m)
-> GenChildList m -> x -> GenXML m
forall a b c. (a -> b -> c) -> b -> a -> c
flip x -> GenChildList m -> GenXML m
forall (m :: * -> *) elem.
AppendChild m elem =>
elem -> GenChildList m -> GenXML m
appAll) GenChildList m
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 :: String -> Name String
toName String
s = (Maybe String
forall a. Maybe a
Nothing, String
s)

-- | Strings can represent names, meaning a simple name with no domain.

instance IsName String Text where
    toName :: String -> Name Text
toName String
s = (Maybe Text
forall a. Maybe a
Nothing, String -> Text
Text.pack String
s)

-- | Names can represent names, of course.

instance (Show a) => IsName (Name a) a where
    toName :: Name a -> Name a
toName = Name a -> Name a
forall a. a -> a
id

-- | Pairs of strings can represent names, meaning a name qualified with a domain.

instance IsName (String, String) Text where
    toName :: (String, String) -> Name Text
toName (String
ns, String
s) = (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
ns, String -> Text
Text.pack String
s)

-- | Strings can represent names, meaning a simple name with no domain.

instance IsName Text Text where
 toName :: Text -> Name Text
toName Text
s = (Maybe Text
forall a. Maybe a
Nothing, Text
s)

-- | strings can represent names, meaning a simple name with no domain.

instance IsName Strict.Text Text where
 toName :: Text -> Name Text
toName Text
s = (Maybe Text
forall a. Maybe a
Nothing, Text -> Text
Text.fromStrict Text
s)

-- | Pairs of strings can represent names, meaning a name qualified with a domain.

instance IsName (Text, Text) Text where
 toName :: (Text, Text) -> Name Text
toName (Text
ns, Text
s) = (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
ns, Text
s)

-- | Pairs of strings can represent names, meaning a name qualified with a domain.

instance IsName (Strict.Text, Strict.Text) Text where
 toName :: (Text, Text) -> Name Text
toName (Text
ns, Text
s) = (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
Text.fromStrict Text
ns, Text -> Text
Text.fromStrict Text
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 :: a -> b
typeCast a
x = () -> a -> b
forall t a b. TypeCast' t a b => t -> a -> b
typeCast' () a
x
instance TypeCast'' t a b => TypeCast' t a b where typeCast' :: t -> a -> b
typeCast' = t -> a -> b
forall t a b. TypeCast'' t a b => t -> a -> b
typeCast''
instance TypeCast'' () a a where typeCast'' :: () -> a -> a
typeCast'' ()
_ a
x  = a
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 :: forall x. ma x -> mb x
typeCastM ma x
mx = () -> ma x -> mb x
forall t (ma :: * -> *) (mb :: * -> *) x.
TypeCastM' t ma mb =>
t -> ma x -> mb x
typeCastM' () ma x
mx
instance TypeCastM'' t ma mb => TypeCastM' t ma mb where typeCastM' :: forall x. t -> ma x -> mb x
typeCastM' = t -> ma x -> mb x
forall t (ma :: * -> *) (mb :: * -> *) x.
TypeCastM'' t ma mb =>
t -> ma x -> mb x
typeCastM''
instance TypeCastM'' () ma ma where typeCastM'' :: forall x. () -> ma x -> ma x
typeCastM'' ()
_ ma x
x  = ma x
x