module HJScript.XMLGenerator (
genElement, genEElement, asChild, asAttr, Attr(..)
) where
import HSX.XMLGenerator
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 XMLGen HJScript' where
type XMLType HJScript' = XML
newtype ChildType HJScript' = HJSChild Child
newtype AttributeType 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 . 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