]> gitweb @ CieloNegro.org - hxt-compile.git/blob - Text/XML/HXT/Compilation.hs
01e13e28b48ead8dd963a5cc6f4220ea75d49e4f
[hxt-compile.git] / 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                   ( constA (HsQualType [] (HsTyCon (UnQual (HsIdent "XmlTree"))))
16                     &&&
17                     arr compileXmlTree
18                   )
19
20
21 wrapIntoModule :: Arrow a => a (Module, ([HsImportDecl], (HsName, (HsQualType, HsExp)))) HsModule
22 wrapIntoModule = proc (modName, (extImports, (symName, (symType, symExp)))) ->
23                  do let hsModule = HsModule undefined modName (Just exports) imports decls
24                         exports  = [HsEVar (UnQual symName)]
25                         imports  = [ HsImportDecl undefined (Module "Text.XML.HXT.Arrow") False Nothing Nothing
26                                    , HsImportDecl undefined (Module "Text.XML.HXT.DOM.XmlNode") True (Just (Module "XN")) Nothing
27                                    ] ++ extImports
28                         decls    = [ HsTypeSig undefined [symName] symType
29                                    , HsFunBind [HsMatch undefined symName [] (HsUnGuardedRhs symExp) []]
30                                    ]
31                     returnA -< hsModule