Text/XML/HXT/Compilation/XmlTree.hs

   1 module Text.XML.HXT.Compilation.XmlTree
   2     ( compileXmlTree
   3     , compileXmlTrees
   4     , compileXNode
   5     , compileDTDElem
   6     , compileAttributes
   7     , compileQName
   8     )
   9     where
  10
  11 import           Language.Haskell.Syntax
  12 import           Text.XML.HXT.DOM.QualifiedName
  13 import           Text.XML.HXT.DOM.XmlNode
  14 import           Text.XML.HXT.DOM.TypeDefs
  15
  16
  17 compileXmlTree :: XmlTree -> HsExp
  18 compileXmlTree t
  19     = let node     = compileXNode (getNode t)
  20           children = HsList (map compileXmlTree (getChildren t))
  21       in
  22         xn "mkTree" $: HsParen node $: children
  23
  24
  25 compileXmlTrees :: XmlTrees -> HsExp
  26 compileXmlTrees = HsList . map compileXmlTree
  27
  28
  29 compileXNode :: XNode -> HsExp
  30 compileXNode (XText      s) = xn "mkText"        $: litStr s
  31 compileXNode (XCharRef   n) = xn "mkCharRef"     $: litInt n
  32 compileXNode (XEntityRef s) = xn "mkEntityRef"   $: litStr s
  33 compileXNode (XCmt       s) = xn "mkCmt"         $: litStr s
  34 compileXNode (XCdata     s) = xn "mkCdata"       $: litStr s
  35 compileXNode (XPi    qn ts) = xn "mkPi"          $: HsParen (compileQName   qn) $: compileXmlTrees ts
  36 compileXNode (XTag   qn ts) = xn "mkElementNode" $: HsParen (compileQName   qn) $: compileXmlTrees ts
  37 compileXNode (XDTD   de as) = xn "mkDTDNode"     $: HsParen (compileDTDElem de) $: HsParen (compileAttributes as)
  38 compileXNode (XAttr     qn) = xn "mkAttrNode"    $: HsParen (compileQName   qn)
  39 compileXNode (XError  n  s) = xn "mkError"       $: litInt n $: litStr s
  40
  41
  42 compileDTDElem :: DTDElem -> HsExp
  43 compileDTDElem = error "compileDTDElem: FIXME: not implemented"
  44
  45
  46 compileAttributes :: Attributes -> HsExp
  47 compileAttributes = error "compileAttributes: FIXME: not implemented"
  48
  49
  50 xn :: String -> HsExp
  51 xn = HsVar . Qual (Module "XN") . HsIdent
  52
  53 unq :: String -> HsExp
  54 unq = HsVar . UnQual . HsIdent
  55
  56
  57 litStr :: String -> HsExp
  58 litStr = HsLit . HsString
  59
  60
  61 litInt :: Integral a => a -> HsExp
  62 litInt = HsLit . HsInt . toInteger
  63
  64
  65 infixr 5 $:
  66 ($:) :: HsExp -> HsExp -> HsExp
  67 a $: b = HsApp a b
  68
  69
  70 compileQName :: QName -> HsExp
  71 compileQName qn
  72     = let prefix = namePrefix   qn
  73           local  = localPart    qn
  74           ns     = namespaceUri qn
  75       in
  76         unq "mkQName" $: litStr prefix $: litStr local $: litStr ns