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
        xn "mkTree" $: HsParen node $: children


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


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


compileDTDElem :: DTDElem -> HsExp
compileDTDElem = error "compileDTDElem: FIXME: not implemented"


compileAttributes :: Attributes -> HsExp
compileAttributes = error "compileAttributes: FIXME: not implemented"


xn :: String -> HsExp
xn = HsVar . Qual (Module "XN") . HsIdent

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