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"     $: compileDTDElem de         $: 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 DOCTYPE  = unq "DOCTYPE"
  44 compileDTDElem ELEMENT  = unq "ELEMENT"
  45 compileDTDElem CONTENT  = unq "CONTENT"
  46 compileDTDElem ATTLIST  = unq "ATTLIST"
  47 compileDTDElem ENTITY   = unq "ENTITY"
  48 compileDTDElem PENTITY  = unq "PENTITY"
  49 compileDTDElem NOTATION = unq "NOTATION"
  50 compileDTDElem CONDSECT = unq "CONDSECT"
  51 compileDTDElem NAME     = unq "NAME"
  52 compileDTDElem PEREF    = unq "PEREF"
  53
  54
  55 compileAttributes :: Attributes -> HsExp
  56 compileAttributes = HsList . map compileAttr
  57     where
  58       compileAttr :: (String, String) -> HsExp
  59       compileAttr (k, v) = HsTuple [ litStr k, litStr v ]
  60
  61
  62
  63 xn :: String -> HsExp
  64 --xn = HsVar . Qual (Module "XN") . HsIdent
  65 xn = unq
  66
  67 unq :: String -> HsExp
  68 unq = HsVar . UnQual . HsIdent
  69
  70
  71 litStr :: String -> HsExp
  72 litStr = HsLit . HsString
  73
  74
  75 litInt :: Integral a => a -> HsExp
  76 litInt = HsLit . HsInt . toInteger
  77
  78
  79 infixr 5 $:
  80 ($:) :: HsExp -> HsExp -> HsExp
  81 a $: b = HsApp a b
  82
  83
  84 compileQName :: QName -> HsExp
  85 compileQName qn
  86     = let prefix = namePrefix   qn
  87           local  = localPart    qn
  88           ns     = namespaceUri qn
  89       in
  90         unq "mkQName" $: litStr prefix $: litStr local $: litStr ns