module Text.XML.HXT.Compilation.XmlTree
    ( compileXmlTree
    , compileXmlTrees
    , compileXNode
    , compileDTDElem
    , compileAttributes
    , compileQName
    )
    where

import           Language.Haskell.Syntax
import           Text.XML.HXT.DOM.QualifiedName
import           Text.XML.HXT.DOM.XmlNode
import           Text.XML.HXT.DOM.TypeDefs


compileXmlTree :: XmlTree -> HsExp
compileXmlTree t
    = let node     = compileXNode (getNode t)
          children = HsList (map compileXmlTree (getChildren t))
      in
        unq "mkTree" $: HsParen node $: children


compileXmlTrees :: XmlTrees -> HsExp
compileXmlTrees = HsList . map compileXmlTree


compileXNode :: XNode -> HsExp
compileXNode (XText      s) = unq "mkText"        $: litStr s
compileXNode (XCharRef   n) = unq "mkCharRef"     $: litInt n
compileXNode (XEntityRef s) = unq "mkEntityRef"   $: litStr s
compileXNode (XCmt       s) = unq "mkCmt"         $: litStr s
compileXNode (XCdata     s) = unq "mkCdata"       $: litStr s
compileXNode (XPi    qn ts) = unq "mkPi"          $: HsParen (compileQName qn) $: compileXmlTrees ts
compileXNode (XTag   qn ts) = unq "mkElementNode" $: HsParen (compileQName qn) $: compileXmlTrees ts
compileXNode (XDTD   de as) = unq "mkDTDNode"     $: compileDTDElem de         $: compileAttributes as
compileXNode (XAttr     qn) = unq "mkAttrNode"    $: HsParen (compileQName qn)
compileXNode (XError  n  s) = unq "mkError"       $: litInt n $: litStr s


compileDTDElem :: DTDElem -> HsExp
compileDTDElem DOCTYPE  = unq "DOCTYPE"
compileDTDElem ELEMENT  = unq "ELEMENT"
compileDTDElem CONTENT  = unq "CONTENT"
compileDTDElem ATTLIST  = unq "ATTLIST"
compileDTDElem ENTITY   = unq "ENTITY"
compileDTDElem PENTITY  = unq "PENTITY"
compileDTDElem NOTATION = unq "NOTATION"
compileDTDElem CONDSECT = unq "CONDSECT"
compileDTDElem NAME     = unq "NAME"
compileDTDElem PEREF    = unq "PEREF"


compileAttributes :: Attributes -> HsExp
compileAttributes = HsList . map compileAttr
    where
      compileAttr :: (String, String) -> HsExp
      compileAttr (k, v) = HsTuple [ litStr k, litStr v ]


unq :: String -> HsExp
unq = HsVar . UnQual . HsIdent


litStr :: String -> HsExp
litStr = HsLit . HsString


litInt :: Integral a => a -> HsExp
litInt = HsLit . HsInt . toInteger


infixr 5 $:
($:) :: HsExp -> HsExp -> HsExp
a $: b = HsApp a b


compileQName :: QName -> HsExp
compileQName qn
    = let prefix = namePrefix   qn
          local  = localPart    qn
          ns     = namespaceUri qn
      in
        unq "mkQName" $: litStr prefix $: litStr local $: litStr ns