Text/XML/HXT/Compilation.hs

   1 module Text.XML.HXT.Compilation
   2     ( compileDocument
   3     , wrapIntoModule
   4     )
   5     where
   6
   7 import           Language.Haskell.Syntax
   8 import           Text.XML.HXT.Arrow
   9 import           Text.XML.HXT.Compilation.XmlTree
  10
  11
  12 compileDocument :: ArrowXml a => a XmlTree (HsQualType, HsExp)
  13 compileDocument = uniqueNamespacesFromDeclAndQNames
  14                   >>>
  15                   filterOutRootAttrs
  16                   >>>
  17                   ( constA (HsQualType [] (HsTyCon (UnQual (HsIdent "XmlTree"))))
  18                     &&&
  19                     arr compileXmlTree
  20                   )
  21
  22
  23 filterOutRootAttrs :: ArrowXml a => a XmlTree XmlTree
  24 filterOutRootAttrs = processTopDownUntil (clearAttrs `when` isRoot)
  25     where
  26       clearAttrs = processAttrl none
  27
  28
  29 wrapIntoModule :: Arrow a => a (Module, ([HsImportDecl], (HsName, (HsQualType, HsExp)))) HsModule
  30 wrapIntoModule = proc (modName, (extImports, (symName, (symType, symExp)))) ->
  31                  do let hsModule = HsModule undefined modName (Just exports) imports decls
  32                         exports  = [HsEVar (UnQual symName)]
  33                         imports  = [ HsImportDecl undefined (Module "Text.XML.HXT.DOM.Interface") False Nothing Nothing
  34                                    , HsImportDecl undefined (Module "Text.XML.HXT.DOM.XmlNode"  ) False Nothing Nothing
  35                                    ] ++ extImports
  36                         decls    = [ HsTypeSig undefined [symName] symType
  37                                    , HsFunBind [HsMatch undefined symName [] (HsUnGuardedRhs symExp) []]
  38                                    ]
  39                     returnA -< hsModule