-- |This module provides, @instance 'XMLGenerator' ('ServerPartT' m)@
{-# LANGUAGE CPP, MultiParamTypeClasses, TypeSynonymInstances, FlexibleContexts, FlexibleInstances, TypeFamilies, OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module HSP.ServerPartT () where

import Control.Monad              (liftM)
import Data.Monoid                ((<>))
import qualified Data.Text        as T
import qualified Data.Text.Lazy   as TL
import HSP.XML
import HSP.XMLGenerator
import Happstack.Server (ServerPartT)

instance (Monad m) => XMLGen (ServerPartT m) where
    type XMLType (ServerPartT m) = XML
    type StringType (ServerPartT m) = TL.Text
    newtype ChildType (ServerPartT m) = SChild { forall (m :: * -> *). ChildType (ServerPartT m) -> XML
unSChild :: XML }
    newtype AttributeType (ServerPartT m) = SAttr { forall (m :: * -> *). AttributeType (ServerPartT m) -> Attribute
unSAttr :: Attribute }
    genElement :: Name (StringType (ServerPartT m))
-> [XMLGenT (ServerPartT m) [AttributeType (ServerPartT m)]]
-> [XMLGenT (ServerPartT m) [ChildType (ServerPartT m)]]
-> XMLGenT (ServerPartT m) (XMLType (ServerPartT m))
genElement Name (StringType (ServerPartT m))
n [XMLGenT (ServerPartT m) [AttributeType (ServerPartT m)]]
attrs [XMLGenT (ServerPartT m) [ChildType (ServerPartT m)]]
children =
        do [Attribute]
attribs <- forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). AttributeType (ServerPartT m) -> Attribute
unSAttr forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr [XMLGenT (ServerPartT m) [AttributeType (ServerPartT m)]]
attrs
           [XML]
childer <- ([XML] -> [XML]
flattenCDATA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). ChildType (ServerPartT m) -> XML
unSChild) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM`forall (m :: * -> *) c. EmbedAsChild m c => c -> GenChildList m
asChild [XMLGenT (ServerPartT m) [ChildType (ServerPartT m)]]
children
           forall (m :: * -> *) a. Monad m => a -> m a
return (Name Text -> [Attribute] -> [XML] -> XML
Element
                              (forall n s. IsName n s => n -> Name s
toName Name (StringType (ServerPartT m))
n)
                              [Attribute]
attribs
                              [XML]
childer
                             )
    xmlToChild :: XMLType (ServerPartT m) -> ChildType (ServerPartT m)
xmlToChild = forall (m :: * -> *). XML -> ChildType (ServerPartT m)
SChild
    pcdataToChild :: StringType (ServerPartT m) -> ChildType (ServerPartT m)
pcdataToChild = forall (m :: * -> *). XMLGen m => XMLType m -> ChildType m
xmlToChild forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> XML
pcdata

flattenCDATA :: [XML] -> [XML]
flattenCDATA :: [XML] -> [XML]
flattenCDATA [XML]
cxml =
                case [XML] -> [XML] -> [XML]
flP [XML]
cxml [] of
                 [] -> []
                 [CDATA Bool
_ Text
""] -> []
                 [XML]
xs -> [XML]
xs
    where
        flP :: [XML] -> [XML] -> [XML]
        flP :: [XML] -> [XML] -> [XML]
flP [] [XML]
bs = forall a. [a] -> [a]
reverse [XML]
bs
        flP [XML
x] [XML]
bs = forall a. [a] -> [a]
reverse (XML
xforall a. a -> [a] -> [a]
:[XML]
bs)
        flP (XML
x:XML
y:[XML]
xs) [XML]
bs = case (XML
x,XML
y) of
                           (CDATA Bool
e1 Text
s1, CDATA Bool
e2 Text
s2) | Bool
e1 forall a. Eq a => a -> a -> Bool
== Bool
e2 -> [XML] -> [XML] -> [XML]
flP (Bool -> Text -> XML
CDATA Bool
e1 (Text
s1forall a. Semigroup a => a -> a -> a
<>Text
s2) forall a. a -> [a] -> [a]
: [XML]
xs) [XML]
bs
                           (XML, XML)
_ -> [XML] -> [XML] -> [XML]
flP (XML
yforall a. a -> [a] -> [a]
:[XML]
xs) (XML
xforall a. a -> [a] -> [a]
:[XML]
bs)

{-
instance (Monad m) => IsAttrValue (ServerPartT m) T.Text where
    toAttrValue = toAttrValue . T.unpack

instance (Monad m) => IsAttrValue (ServerPartT m) TL.Text where
    toAttrValue = toAttrValue . TL.unpack
-}
instance (Functor m, Monad m) => EmbedAsAttr (ServerPartT m) Attribute where
    asAttr :: Attribute -> GenAttributeList (ServerPartT m)
asAttr = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Attribute -> AttributeType (ServerPartT m)
SAttr

instance (Functor m, Monad m, IsName n TL.Text) => EmbedAsAttr (ServerPartT m) (Attr n Char) where
    asAttr :: Attr n Char -> GenAttributeList (ServerPartT m)
asAttr (n
n := Char
c)  = forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr (n
n forall n a. n -> a -> Attr n a
:= [Char
c])

instance (Functor m, Monad m, IsName n TL.Text) => EmbedAsAttr (ServerPartT m) (Attr n String) where
    asAttr :: Attr n [Char] -> GenAttributeList (ServerPartT m)
asAttr (n
n := [Char]
str)  = forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr forall a b. (a -> b) -> a -> b
$ (Name Text, AttrValue) -> Attribute
MkAttr (forall n s. IsName n s => n -> Name s
toName n
n, Text -> AttrValue
pAttrVal forall a b. (a -> b) -> a -> b
$ [Char] -> Text
TL.pack [Char]
str)

instance (Functor m, Monad m, IsName n TL.Text) => EmbedAsAttr (ServerPartT m) (Attr n Bool) where
    asAttr :: Attr n Bool -> GenAttributeList (ServerPartT m)
asAttr (n
n := Bool
True)  = forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr forall a b. (a -> b) -> a -> b
$ (Name Text, AttrValue) -> Attribute
MkAttr (forall n s. IsName n s => n -> Name s
toName n
n, Text -> AttrValue
pAttrVal Text
"true")
    asAttr (n
n := Bool
False) = forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr forall a b. (a -> b) -> a -> b
$ (Name Text, AttrValue) -> Attribute
MkAttr (forall n s. IsName n s => n -> Name s
toName n
n, Text -> AttrValue
pAttrVal Text
"false")

instance (Functor m, Monad m, IsName n TL.Text) => EmbedAsAttr (ServerPartT m) (Attr n Int) where
    asAttr :: Attr n Int -> GenAttributeList (ServerPartT m)
asAttr (n
n := Int
i)  = forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr forall a b. (a -> b) -> a -> b
$ (Name Text, AttrValue) -> Attribute
MkAttr (forall n s. IsName n s => n -> Name s
toName n
n, Text -> AttrValue
pAttrVal ([Char] -> Text
TL.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Int
i))

instance (Functor m, Monad m, IsName n TL.Text) => (EmbedAsAttr (ServerPartT m) (Attr n TL.Text)) where
    asAttr :: Attr n Text -> GenAttributeList (ServerPartT m)
asAttr (n
n := Text
a) = forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr forall a b. (a -> b) -> a -> b
$ (Name Text, AttrValue) -> Attribute
MkAttr (forall n s. IsName n s => n -> Name s
toName n
n, Text -> AttrValue
pAttrVal forall a b. (a -> b) -> a -> b
$ Text
a)

instance (Functor m, Monad m, IsName n TL.Text) => (EmbedAsAttr (ServerPartT m) (Attr n T.Text)) where
    asAttr :: Attr n Text -> GenAttributeList (ServerPartT m)
asAttr (n
n := Text
a) = forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr forall a b. (a -> b) -> a -> b
$ (Name Text, AttrValue) -> Attribute
MkAttr (forall n s. IsName n s => n -> Name s
toName n
n, Text -> AttrValue
pAttrVal forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.fromStrict Text
a)

instance (Functor m, Monad m) => EmbedAsChild (ServerPartT m) Char where
    asChild :: Char -> GenChildList (ServerPartT m)
asChild = forall (m :: * -> *) a. m a -> XMLGenT m a
XMLGenT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). XML -> ChildType (ServerPartT m)
SChild forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> XML
pcdata forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
TL.singleton

instance (Functor m, Monad m) => EmbedAsChild (ServerPartT m) String where
    asChild :: [Char] -> GenChildList (ServerPartT m)
asChild = forall (m :: * -> *) a. m a -> XMLGenT m a
XMLGenT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). XML -> ChildType (ServerPartT m)
SChild forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> XML
pcdata forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
TL.pack

instance (Functor m, Monad m) => EmbedAsChild (ServerPartT m) Int where
    asChild :: Int -> GenChildList (ServerPartT m)
asChild = forall (m :: * -> *) a. m a -> XMLGenT m a
XMLGenT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). XML -> ChildType (ServerPartT m)
SChild forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> XML
pcdata forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
TL.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show

instance (Functor m, Monad m) => EmbedAsChild (ServerPartT m) Integer where
    asChild :: Integer -> GenChildList (ServerPartT m)
asChild = forall (m :: * -> *) a. m a -> XMLGenT m a
XMLGenT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). XML -> ChildType (ServerPartT m)
SChild forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> XML
pcdata forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
TL.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show

instance (Functor m, Monad m) => EmbedAsChild (ServerPartT m) XML where
    asChild :: XML -> GenChildList (ServerPartT m)
asChild = forall (m :: * -> *) a. m a -> XMLGenT m a
XMLGenT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). XML -> ChildType (ServerPartT m)
SChild

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

instance (Functor m, Monad m) => (EmbedAsChild (ServerPartT m) TL.Text) where
    asChild :: Text -> GenChildList (ServerPartT m)
asChild = forall (m :: * -> *) c. EmbedAsChild m c => c -> GenChildList m
asChild forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
TL.unpack

instance (Functor m, Monad m) => (EmbedAsChild (ServerPartT m) T.Text) where
    asChild :: Text -> GenChildList (ServerPartT m)
asChild = forall (m :: * -> *) c. EmbedAsChild m c => c -> GenChildList m
asChild forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack

instance (Functor m, Monad m) => AppendChild (ServerPartT m) XML where
 appAll :: XML -> GenChildList (ServerPartT m) -> GenXML (ServerPartT m)
appAll XML
xml GenChildList (ServerPartT m)
children = do
        [ChildType (ServerPartT m)]
chs <- GenChildList (ServerPartT m)
children
        case XML
xml of
         CDATA Bool
_ Text
_       -> forall (m :: * -> *) a. Monad m => a -> m a
return XML
xml
         Element Name Text
n [Attribute]
as [XML]
cs -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name Text -> [Attribute] -> [XML] -> XML
Element Name Text
n [Attribute]
as ([XML]
cs forall a. [a] -> [a] -> [a]
++ (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). ChildType (ServerPartT m) -> XML
unSChild [ChildType (ServerPartT m)]
chs))

instance (Functor m, Monad m) => SetAttr (ServerPartT m) XML where
 setAll :: XML -> GenAttributeList (ServerPartT m) -> GenXML (ServerPartT m)
setAll XML
xml GenAttributeList (ServerPartT m)
hats = do
        [AttributeType (ServerPartT m)]
attrs <- GenAttributeList (ServerPartT m)
hats
        case XML
xml of
         CDATA Bool
_ Text
_       -> forall (m :: * -> *) a. Monad m => a -> m a
return XML
xml
         Element Name Text
n [Attribute]
as [XML]
cs -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name Text -> [Attribute] -> [XML] -> XML
Element Name Text
n (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (:) [Attribute]
as (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). AttributeType (ServerPartT m) -> Attribute
unSAttr [AttributeType (ServerPartT m)]
attrs)) [XML]
cs

instance (Functor m, Monad m) => XMLGenerator (ServerPartT m)