From: PHO <pho@cielonegro.org>
Date: Wed, 11 Feb 2009 03:56:22 +0000 (+0900)
Subject: Succeeded to compile examples/tiny.xml
X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=5ccdec1d86b750444704312526a44eb68972027b;p=hxt-compile.git

Succeeded to compile examples/tiny.xml
---

diff --git a/Main.hs b/Main.hs
index d82a4bd..8466f76 100644
--- a/Main.hs
+++ b/Main.hs
@@ -1,4 +1,30 @@
 module Main where
 
+import           Language.Haskell.Pretty
+import           Language.Haskell.Syntax
+import           Text.XML.HXT.Compilation
+import           Text.XML.HXT.Arrow
+import qualified System.IO.UTF8 as Uio
+
+
 main :: IO ()
-main = return ()
+main = do let fpath = "examples/tiny.xml"
+
+          [hsMod] <- runX ( setErrorMsgHandler False fail
+                            >>>
+                            constA fpath
+                            >>>
+                            readFromDocument [ (a_validate        , v_0)
+                                             , (a_check_namespaces, v_1)
+                                             ]
+                            >>>
+                            ( constA (Module "Foo")
+                              &&&
+                              constA (HsIdent "foo")
+                              &&&
+                              compileDocument
+                            )
+                            >>>
+                            wrapIntoModule
+                          )
+          Uio.putStrLn (prettyPrint hsMod)
diff --git a/Text/XML/HXT/Compilation.hs b/Text/XML/HXT/Compilation.hs
index 9b2f105..cbcf396 100644
--- a/Text/XML/HXT/Compilation.hs
+++ b/Text/XML/HXT/Compilation.hs
@@ -1,4 +1,31 @@
 module Text.XML.HXT.Compilation
-    (
+    ( compileDocument
+    , wrapIntoModule
     )
     where
+
+import           Language.Haskell.Syntax
+import           Text.XML.HXT.Arrow
+import           Text.XML.HXT.Compilation.XmlTree
+
+
+compileDocument :: ArrowXml a => a XmlTree (HsQualType, HsExp)
+compileDocument = uniqueNamespacesFromDeclAndQNames
+                  >>>
+                  ( constA (HsQualType [] (HsTyCon (UnQual (HsIdent "XmlTree"))))
+                    &&&
+                    arr compileXmlTree
+                  )
+
+
+wrapIntoModule :: Arrow a => a (Module, (HsName, (HsQualType, HsExp))) HsModule
+wrapIntoModule = proc (modName, (symName, (symType, symExp))) ->
+                 do let hsModule = HsModule undefined modName (Just exports) imports decls
+                        exports  = [HsEVar (UnQual symName)]
+                        imports  = [ HsImportDecl undefined (Module "Text.XML.HXT.Arrow") False Nothing Nothing
+                                   , HsImportDecl undefined (Module "Text.XML.HXT.DOM.XmlNode") True (Just (Module "XN")) Nothing
+                                   ]
+                        decls    = [ HsTypeSig undefined [symName] symType
+                                   , HsFunBind [HsMatch undefined symName [] (HsUnGuardedRhs symExp) []]
+                                   ]
+                    returnA -< hsModule
diff --git a/Text/XML/HXT/Compilation/XmlTree.hs b/Text/XML/HXT/Compilation/XmlTree.hs
index 7884c77..37bb842 100644
--- a/Text/XML/HXT/Compilation/XmlTree.hs
+++ b/Text/XML/HXT/Compilation/XmlTree.hs
@@ -1,5 +1,10 @@
 module Text.XML.HXT.Compilation.XmlTree
     ( compileXmlTree
+    , compileXmlTrees
+    , compileXNode
+    , compileDTDElem
+    , compileAttributes
+    , compileQName
     )
     where
 
@@ -9,16 +14,16 @@ import           Text.XML.HXT.DOM.XmlNode
 import           Text.XML.HXT.DOM.TypeDefs
 
 
-compileXmlTrees :: XmlTrees -> HsExp
-compileXmlTrees = HsList . map compileXmlTree
-
-
 compileXmlTree :: XmlTree -> HsExp
 compileXmlTree t
     = let node     = compileXNode (getNode t)
           children = HsList (map compileXmlTree (getChildren t))
       in
-        xn "mkTree" $: node $: children
+        xn "mkTree" $: HsParen node $: children
+
+
+compileXmlTrees :: XmlTrees -> HsExp
+compileXmlTrees = HsList . map compileXmlTree
 
 
 compileXNode :: XNode -> HsExp
@@ -27,11 +32,11 @@ compileXNode (XCharRef   n) = xn "mkCharRef"     $: litInt n
 compileXNode (XEntityRef s) = xn "mkEntityRef"   $: litStr s
 compileXNode (XCmt       s) = xn "mkCmt"         $: litStr s
 compileXNode (XCdata     s) = xn "mkCdata"       $: litStr s
-compileXNode (XPi    qn ts) = xn "mkPi"          $: compileQName   qn $: compileXmlTrees ts
-compileXNode (XTag   qn ts) = xn "mkElementNode" $: compileQName   qn $: compileXmlTrees ts
-compileXNode (XDTD   de as) = xn "mkDTDNode"     $: compileDTDElem de $: compileAttributes as
-compileXNode (XAttr     qn) = xn "mkAttrNode"    $: compileQName   qn
-compileXNode (XError  n  s) = xn "mkError"       $: litInt n          $: litStr s
+compileXNode (XPi    qn ts) = xn "mkPi"          $: HsParen (compileQName   qn) $: compileXmlTrees ts
+compileXNode (XTag   qn ts) = xn "mkElementNode" $: HsParen (compileQName   qn) $: compileXmlTrees ts
+compileXNode (XDTD   de as) = xn "mkDTDNode"     $: HsParen (compileDTDElem de) $: HsParen (compileAttributes as)
+compileXNode (XAttr     qn) = xn "mkAttrNode"    $: HsParen (compileQName   qn)
+compileXNode (XError  n  s) = xn "mkError"       $: litInt n $: litStr s
 
 
 compileDTDElem :: DTDElem -> HsExp
@@ -45,6 +50,9 @@ compileAttributes = error "compileAttributes: FIXME: not implemented"
 xn :: String -> HsExp
 xn = HsVar . Qual (Module "XN") . HsIdent
 
+unq :: String -> HsExp
+unq = HsVar . UnQual . HsIdent
+
 
 litStr :: String -> HsExp
 litStr = HsLit . HsString
@@ -54,11 +62,11 @@ litInt :: Integral a => a -> HsExp
 litInt = HsLit . HsInt . toInteger
 
 
-infixl $:
+infixr 5 $:
 ($:) :: HsExp -> HsExp -> HsExp
-($:) = HsApp
+a $: b = HsApp a b
 
 
 compileQName :: QName -> HsExp
 compileQName (QN prefix local ns)
-    = xn "mkQName" $: litStr prefix $: litStr local $: litStr ns
+    = unq "mkQName" $: litStr prefix $: litStr local $: litStr ns
diff --git a/examples/tiny.xml b/examples/tiny.xml
new file mode 100644
index 0000000..1080534
--- /dev/null
+++ b/examples/tiny.xml
@@ -0,0 +1,4 @@
+<?xml version="1.0" encoding="utf-8"?>
+<foo>
+  <bar>baz</bar>
+</foo>
diff --git a/hxt-compile.cabal b/hxt-compile.cabal
index e8ba617..255be89 100644
--- a/hxt-compile.cabal
+++ b/hxt-compile.cabal
@@ -9,14 +9,21 @@ Maintainer:          PHO <pho at cielonegro.org>
 Cabal-Version:       >= 1.2
 Build-Type:          Simple
 
+Extra-Source-Files:
+    examples/tiny.xml
+
 Library
     Build-Depends:
-        base, haskell-src, hxt
+        base, haskell-src, hxt, utf8-string
     Exposed-Modules:
         Text.XML.HXT.Compilation
         Text.XML.HXT.Compilation.XmlTree
+    Extensions:
+        Arrows
     GHC-Options:     -Wall
 
 Executable hxt-compile
     Main-Is:         Main.hs
+    Extensions:
+        Arrows
     GHC-Options:     -Wall