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         unq "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) = unq "mkText"        $: litStr s
  31 compileXNode (XCharRef   n) = unq "mkCharRef"     $: litInt n
  32 compileXNode (XEntityRef s) = unq "mkEntityRef"   $: litStr s
  33 compileXNode (XCmt       s) = unq "mkCmt"         $: litStr s
  34 compileXNode (XCdata     s) = unq "mkCdata"       $: litStr s
  35 compileXNode (XPi    qn ts) = unq "mkPi"          $: HsParen (compileQName qn) $: compileXmlTrees ts
  36 compileXNode (XTag   qn ts) = unq "mkElementNode" $: HsParen (compileQName qn) $: compileXmlTrees ts
  37 compileXNode (XDTD   de as) = unq "mkDTDNode"     $: compileDTDElem de         $: compileAttributes as
  38 compileXNode (XAttr     qn) = unq "mkAttrNode"    $: HsParen (compileQName qn)
  39 compileXNode (XError  n  s) = unq "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 unq :: String -> HsExp
  63 unq = HsVar . UnQual . HsIdent
  64
  65
  66 litStr :: String -> HsExp
  67 litStr = HsLit . HsString
  68
  69
  70 litInt :: Integral a => a -> HsExp
  71 litInt = HsLit . HsInt . toInteger
  72
  73
  74 infixr 5 $:
  75 ($:) :: HsExp -> HsExp -> HsExp
  76 a $: b = HsApp a b
  77
  78
  79 compileQName :: QName -> HsExp
  80 compileQName qn
  81     = let prefix = namePrefix   qn
  82           local  = localPart    qn
  83           ns     = namespaceUri qn
  84       in
  85         unq "mkQName" $: litStr prefix $: litStr local $: litStr ns