{-# OPTIONS_GHC -fglasgow-exts #-}
{-# OPTIONS_GHC -fallow-overlapping-instances #-}
{-# OPTIONS_GHC -fallow-undecidable-instances #-}

module HJScript.XMLGenerator (
        ToChildNodes(..), ToAttributeNode(..),
        
        genElement, genEElement, asChild, asAttr, Attr(..)
        ) where

import qualified HSX.XMLGenerator as HSX (XMLGenerator(..))
import HSX.XMLGenerator hiding (XMLGenerator(..))
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.XMLGenerator HJScript' where
 type HSX.XML       HJScript' = XML
 type HSX.Child     HJScript' = Child
 type HSX.Attribute HJScript' = Attribute
 genElement = element
 genEElement = eElement

element :: Name -> [(HJScript Attribute)] -> [(HJScript [Child])] -> 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 <- toChildNodes xmls
  ats  <- mapM toAttributeNode atts
  mapM (\attr  -> elem # setAttributeNode attr) ats
  mapM (\child -> elem # appendChild child) cxml
  return elem

eElement :: Name -> [(HJScript Attribute)] -> HJScript (Exp ElementNode)
eElement n attrs = element n attrs []

class ToChildNodes a where
 toChildNodes :: a -> HJScript [Child]

instance ToChildNodes a => EmbedAsChild a (HJScript [Child]) where
 asChild = toChildNodes

instance ToChildNodes Child where
 toChildNodes node = return [node]

instance ToChildNodes XML where
 toChildNodes xml = return [castToNode xml]

instance ToChildNodes a => ToChildNodes [a] where
 toChildNodes as = do
   xss <- mapM toChildNodes as
   return $ concat xss

instance ToChildNodes JString where
 toChildNodes str = return [castToNode $ document # createTextNode str]
 
instance ToChildNodes String where
 toChildNodes = toChildNodes . string

instance (ToChildNodes x, TypeCast (m x) (HJScript' x)) => ToChildNodes (XMLGenT m x) where
 toChildNodes (XMLGenT x) = (XMLGenT $ typeCast x) >>= toChildNodes


class ToAttributeNode a where
 toAttributeNode :: a -> HJScript Attribute

instance ToAttributeNode a => EmbedAsAttr a (HJScript Attribute) where
 asAttr = toAttributeNode

instance ToAttributeNode Attribute where
 toAttributeNode = return

instance (IsName n, IsAttrNodeValue a) => ToAttributeNode (Attr n a) where
 toAttributeNode (k := a) = do
   let (ns,ln) = toName k
       name    = (maybe id (\x y -> y ++ ':':x) ns) ln
   v  <- toAttrNodeValue a
   an <- fmap val $ varWith $ document # createAttribute (string name)
   an # value .=. v
   return an

instance ToAttributeNode a => ToAttributeNode (HJScript a) where
 toAttributeNode = (>>= toAttributeNode)


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) as
        return ev

instance TypeCast (m x) (HJScript' XML) => 
        SetAttr HJScript' (XMLGenT m x) where
 setAll (XMLGenT hjen) ats = (XMLGenT $ typeCast hjen) >>= (flip setAll) ats


instance AppendChild HJScript' XML where
 appAll en cns = do
        ev <- inVar en
        cs <- cns
        mapM (\child -> ev # appendChild child) cs
        return ev

instance TypeCast (m x) (HJScript' XML) =>
        AppendChild HJScript' (XMLGenT m x) where
 appAll (XMLGenT hjen) chs = (XMLGenT $ typeCast hjen) >>= (flip appAll) chs