{-# LANGUAGE OverlappingInstances, UndecidableInstances #-}
module HJScript.XMLGenerator (
--        ToChildNodes(..), ToAttributeNode(..),
        
        genElement, genEElement, asChild, asAttr, Attr(..)
        ) where

--import qualified HSX.XMLGenerator as HSX (XMLGen(..))
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'

--------------------------------------------
-- EmbedAsChild and EmbedAsAttr

instance EmbedAsChild HJScript' Child where
 asChild = asChild . HJSChild

instance EmbedAsChild HJScript' JString where
 asChild jstr = asChild $ castToNode $ document # createTextNode jstr

--instance EmbedAsChild HJScript' String where
-- asChild = asChild . string

instance EmbedAsChild HJScript' Char where
 asChild = asChild . (:[])

-- This instance should already be there, probably doesn't work due
-- to type families not being fully supported yet.
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)

-----------------------------------
-- SetAttr and AppendChild.

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