module HJScript.XMLGenerator (
genElement, genEElement, asChild, asAttr, Attr(..)
) where
import qualified HSX.XMLGenerator as HSX (XMLGen(..))
import HSX.XMLGenerator hiding (XMLGen(..))
import HSX.XMLGenerator (genElement, genEElement)
import HJScript.Monad
import HJScript.Lang
import HJScript.DOM.Node
import HJScript.DOM.AttributeNode
import HJScript.DOM.ElementNode
import HJScript.DOM.TextNode
import HJScript.DOM.Document
type XML = Exp ElementNode
type Child = Exp Node
type Attribute = Exp AttributeNode
instance HSX.XMLGen HJScript' where
type HSX.XML HJScript' = XML
newtype HSX.Child HJScript' = HJSChild Child
newtype HSX.Attribute HJScript' = HJSAttr Attribute
genElement = element
genEElement = eElement
xmlToChild = HJSChild . castToNode
pcdataToChild str = HJSChild . castToNode $ document # createTextNode (string str)
element :: (EmbedAsChild HJScript' c,
EmbedAsAttr HJScript' a)
=> Name -> [a] -> [c] -> HJScript XML
element (ns, ln) atts xmls = do
let name = (maybe id (\x y -> y ++ ':':x) ns) ln
elem <- fmap val $ varWith $ document # createElement (string name)
cxml <- fmap concat $ mapM asChild xmls
ats <- fmap concat $ mapM asAttr atts
mapM (\attr -> elem # setAttributeNode attr) $ map stripAttr ats
mapM (\child -> elem # appendChild child) $ map stripChild cxml
return elem
eElement :: EmbedAsAttr HJScript' a => Name -> [a] -> HJScript XML
eElement n attrs = element n attrs ([] :: [Child])
instance XMLGenerator HJScript'
instance EmbedAsChild HJScript' Child where
asChild = asChild . HJSChild
instance EmbedAsChild HJScript' JString where
asChild jstr = asChild $ castToNode $ document # createTextNode jstr
instance EmbedAsChild HJScript' Char where
asChild = asChild . (:[])
instance EmbedAsChild HJScript' XML where
asChild = return . return . HSX.xmlToChild
instance EmbedAsAttr HJScript' Attribute where
asAttr = asAttr . HJSAttr
instance (IsName n, IsAttrNodeValue a) => EmbedAsAttr HJScript' (Attr n a) where
asAttr (k := a) = asAttr $ do
let (ns, ln) = toName k
name = (maybe id (\x y -> y ++ ':':x) ns) ln
v <- toAttrNodeValue a
an <- inVar $ document # createAttribute (string name)
an # value .=. v
return an
class IsAttrNodeValue a where
toAttrNodeValue :: a -> HJScript JString
instance JShow a => IsAttrNodeValue a where
toAttrNodeValue = return . jshow
instance IsAttrNodeValue a => IsAttrNodeValue (HJScript a) where
toAttrNodeValue = (>>= toAttrNodeValue)
instance SetAttr HJScript' XML where
setAll en ats = do
ev <- inVar en
as <- ats
mapM (\attr -> ev # setAttributeNode attr) (map stripAttr as)
return ev
instance AppendChild HJScript' XML where
appAll en cns = do
ev <- inVar en
cs <- cns
mapM (\child -> ev # appendChild child) (map stripChild cs)
return ev
stripAttr (HJSAttr a) = a
stripChild (HJSChild c) = c