Start working on XSD gen from imports and refs

.gitignore

@@ -0,0 +1 @@
+.stack-work

HaXml.cabal

@@ -133,7 +133,7 @@ Executable XsdToHaskell
   Hs-Source-Dirs: src/tools
   cpp-options: -DVERSION="\"1.25.3\""
   Main-Is: XsdToHaskell.hs
-  build-depends: base, HaXml, pretty, polyparse, directory
+  build-depends: base, HaXml, pretty, polyparse, directory, filepath, containers
 
 Executable FpMLToHaskell
   GHC-Options: -Wall

src/Text/XML/HaXml.hs

@@ -33,5 +33,5 @@ import Text.PrettyPrint.HughesPJ  (render)
 
 -- | The version of the library.
 version :: String
-version  = VERSION
+version = "X" -- VERSION
 		-- expect cpp to fill in value

src/Text/XML/HaXml/Schema/Environment.hs

@@ -3,14 +3,16 @@ module Text.XML.HaXml.Schema.Environment
   ( module Text.XML.HaXml.Schema.Environment
   ) where
 
-import Text.XML.HaXml.Types (QName(..),Name(..),Namespace(..))
-import Text.XML.HaXml.Schema.XSDTypeModel
-import Text.XML.HaXml.Schema.NameConversion (wordsBy)
-import Text.XML.HaXml.Schema.Parse (targetPrefix)
+import           Text.XML.HaXml.Schema.NameConversion (wordsBy)
+import           Text.XML.HaXml.Schema.Parse          (targetPrefix)
+import           Text.XML.HaXml.Schema.XSDTypeModel
+import           Text.XML.HaXml.Types                 (Name (..),
+                                                       Namespace (..),
+                                                       QName (..))
 
-import qualified Data.Map as Map
-import Data.Map (Map)
-import Data.List (foldl')
+import           Data.List                            (foldl')
+import           Data.Map                             (Map)
+import qualified Data.Map                             as Map
 
 -- Some things we probably want to do.
 -- * Build Maps from :
@@ -42,20 +44,21 @@ import Data.List (foldl')
 -- Likewise, the mappings from supertype->subtype (env_extendty) and for
 -- substitution groups (env_substGrp) also need to be global.
 
-data Environment =  Environment
-    { env_type      :: Map QName (Either SimpleType ComplexType)
+data Environment = Environment
+  { env_type      :: Map QName (Either SimpleType ComplexType)
                                  -- ^ type definitions in scope
-    , env_allTypes  :: Map QName (Either SimpleType ComplexType)
+  , env_allTypes  :: Map QName (Either SimpleType ComplexType)
                                  -- ^ all type definitions, regardless of scope
-    , env_element   :: Map QName ElementDecl
-    , env_attribute :: Map QName AttributeDecl
-    , env_group     :: Map QName Group
-    , env_attrgroup :: Map QName AttrGroup
-    , env_namespace :: Map String{-URI-} String{-Prefix-}
-    , env_extendty  :: Map QName [(QName,FilePath)] -- ^ supertype -> subtypes
-    , env_substGrp  :: Map QName [(QName,FilePath)] -- ^ substitution groups
-    , env_typeloc   :: Map QName FilePath           -- ^ where type is defined
-    }
+  , env_element   :: Map QName ElementDecl
+  , env_attribute :: Map QName AttributeDecl
+  , env_group     :: Map QName Group
+  , env_attrgroup :: Map QName AttrGroup
+  , env_namespace :: Map String String {-URI-}
+     {-Prefix-}
+  , env_extendty  :: Map QName [(QName, FilePath)] -- ^ supertype -> subtypes
+  , env_substGrp  :: Map QName [(QName, FilePath)] -- ^ substitution groups
+  , env_typeloc   :: Map QName FilePath -- ^ where type is defined
+  } deriving (Show)
 
 -- | An empty environment of XSD type mappings.
 emptyEnv :: Environment

src/Text/XML/HaXml/Wrappers.hs

@@ -31,7 +31,7 @@ fix2Args :: IO (String,String)
 fix2Args = do
   args <- getArgs
   when ("--version" `elem` args) $ do
-      putStrLn $ "part of HaXml-" ++ VERSION
+      putStrLn $ "part of HaXml-X" -- ++ VERSION
       exitWith ExitSuccess
   when ("--help" `elem` args) $ do
       putStrLn $ "See http://projects.haskell.org/HaXml"

src/tools/XsdToHaskell.hs

@@ -7,29 +7,33 @@ module Main where
 -- definitions, you should import Xsd2Haskell wherever you intend
 -- to read and write XML files with your Haskell programs.
 
-import System.Environment
-import System.Exit
-import System.IO
-import Control.Monad
+import           Control.Monad
+import qualified Data.Map                               as Map
+import           Data.Maybe
+import           Data.Monoid
+import           System.Environment
+import           System.Exit
+import           System.FilePath
+import           System.IO
 --import Data.Either
 
 --import Text.XML.HaXml.Wrappers   (fix2Args)
-import Text.XML.HaXml            (version)
-import Text.XML.HaXml.Types
-import Text.XML.HaXml.Namespaces (resolveAllNames,qualify
-                                 ,nullNamespace)
-import Text.XML.HaXml.Parse      (xmlParse')
-import Text.XML.HaXml.Util       (docContent)
-import Text.XML.HaXml.Posn       (posInNewCxt)
+import           Text.XML.HaXml                         (version)
+import           Text.XML.HaXml.Namespaces              (nullNamespace, qualify,
+                                                         resolveAllNames)
+import           Text.XML.HaXml.Parse                   (xmlParse')
+import           Text.XML.HaXml.Posn                    (posInNewCxt)
+import           Text.XML.HaXml.Types
+import           Text.XML.HaXml.Util                    (docContent)
 
-import Text.XML.HaXml.Schema.Parse
-import Text.XML.HaXml.Schema.Environment
-import Text.XML.HaXml.Schema.NameConversion
-import Text.XML.HaXml.Schema.TypeConversion
-import Text.XML.HaXml.Schema.PrettyHaskell
+import           Text.ParserCombinators.Poly
+import           Text.PrettyPrint.HughesPJ              (render, vcat)
+import           Text.XML.HaXml.Schema.Environment
 import qualified Text.XML.HaXml.Schema.HaskellTypeModel as Haskell
-import Text.ParserCombinators.Poly
-import Text.PrettyPrint.HughesPJ (render,vcat)
+import           Text.XML.HaXml.Schema.NameConversion
+import           Text.XML.HaXml.Schema.Parse
+import           Text.XML.HaXml.Schema.PrettyHaskell
+import           Text.XML.HaXml.Schema.TypeConversion
 
 -- sucked in from Text.XML.HaXml.Wrappers to avoid dependency on T.X.H.Html
 fix2Args :: IO (String,String)
@@ -52,33 +56,77 @@ fix2Args = do
 
 main ::IO ()
 main =
-  fix2Args >>= \(inf,outf)->
-  ( if inf=="-" then getContents
-    else readFile inf )           >>= \thiscontent->
-  ( if outf=="-" then return stdout
-    else openFile outf WriteMode ) >>= \o->
-  let d@Document{} = resolveAllNames qualify
-                     . either (error . ("not XML:\n"++)) id
-                     . xmlParse' inf
-                     $ thiscontent
-  in do
-    case runParser schema [docContent (posInNewCxt inf Nothing) d] of
-        (Left msg,_) ->    hPutStrLn stderr msg
-        (Right v,[]) -> do hPutStrLn stdout $ "Parse Success!"
-                           hPutStrLn stdout $ "\n-----------------\n"
-                           hPutStrLn stdout $ show v
-                           hPutStrLn stdout $ "\n-----------------\n"
-                           let decls = convert (mkEnvironment inf v emptyEnv) v
-                               haskl = Haskell.mkModule inf v decls
-                               doc   = ppModule simpleNameConverter haskl
-                           hPutStrLn o $ render doc
-        (Right v,_)  -> do hPutStrLn stdout $ "Parse incomplete!"
-                           hPutStrLn stdout $ "\n-----------------\n"
-                           hPutStrLn stdout $ show v
-                           hPutStrLn stdout $ "\n-----------------\n"
-    hFlush o
+  fix2Args >>= \(inf, outf) ->
+    (if inf == "-"
+       then getContents
+       else readFile inf) >>= \thiscontent ->
+      (if outf == "-"
+         then return stdout
+         else openFile outf WriteMode) >>= \o ->
+        let d@Document {} =
+              resolveAllNames qualify .
+              either (error . ("not XML:\n" ++)) id . xmlParse' inf $
+              thiscontent
+        in do case runParser schema [docContent (posInNewCxt inf Nothing) d] of
+                (Left msg, _) -> hPutStrLn stderr msg
+                (Right v, []) -> do
+                  hPutStrLn stdout "Parse Success!"
+                  hPutStrLn stdout "\n-----------------\n"
+                  hPutStrLn stdout $ show v
+                  hPutStrLn stdout "\n-----------------\n"
+                  let imports = gatherImports v
+                  putStrLn "Going into imports:"
+                  importsEnv <-
+                    forM imports $ \(i, mname) -> do
+                      print (i, mname)
+                      let baseDir = takeDirectory inf
+                          fp = baseDir </> i
+                      putStrLn $ "Parsing " <> fp
+                      d <-
+                        resolveAllNames qualify .
+                        either (error "failed to parse import") id .
+                        xmlParse' fp <$>
+                        readFile fp
+                      let (Right r, []) =
+                            runParser
+                              schema
+                              [docContent (posInNewCxt fp Nothing) d]
+                          env = (mkEnvironment fp r emptyEnv)
+                          (uri, nsName) = (head (Map.toList (env_namespace env)))
+                          ns = Namespace (case (fromMaybe nsName mname) of
+                                              "xs" -> "xml"
+                                              v    -> v) uri
+                      print ("Namespace: ", ns)
+                      let env' =
+                            env
+                            { env_attribute =
+                                Map.fromList
+                                  (map
+                                     (\(N n, v) -> (QN ns n, v))
+                                     (Map.toList (env_attribute env)))
+                            }
+                    -- print env'
+                      return env'
+                  let decls =
+                        convert
+                          (mkEnvironment
+                             inf
+                             v
+                             (foldl combineEnv emptyEnv importsEnv))
+                          v
+                  print decls
+                  putStrLn "-------"
+                  let haskl = Haskell.mkModule inf v decls
+                      doc = ppModule simpleNameConverter haskl
+                  hPutStrLn o $ render doc
+                (Right v, _) -> do
+                  hPutStrLn stdout "Parse incomplete!"
+                  hPutStrLn stdout "\n-----------------\n"
+                  hPutStrLn stdout $ show v
+                  hPutStrLn stdout "\n-----------------\n"
+              hFlush o
+
 
-
 --do hPutStrLn o $ "Document contains XSD for target namespace "++
 --                 targetNamespace e
   {-
@@ -116,7 +164,7 @@ targetNamespace :: Element i -> String
 targetNamespace (Elem qn attrs _) =
     if qn /= xsdSchema then "ERROR! top element not an xsd:schema tag"
     else case lookup (N "targetNamespace") attrs of
-           Nothing -> "ERROR! no targetNamespace specified"
+           Nothing  -> "ERROR! no targetNamespace specified"
            Just atv -> show atv
 
 xsdSchema :: QName

stack.yaml

@@ -0,0 +1,66 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# http://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+# resolver: ghcjs-0.1.0_ghc-7.10.2
+# resolver:
+#  name: custom-snapshot
+#  location: "./custom-snapshot.yaml"
+resolver: lts-8.18
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+# - location:
+#    git: https://github.com/commercialhaskell/stack.git
+#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#   extra-dep: true
+#  subdirs:
+#  - auto-update
+#  - wai
+#
+# A package marked 'extra-dep: true' will only be built if demanded by a
+# non-dependency (i.e. a user package), and its test suites and benchmarks
+# will not be run. This is useful for tweaking upstream packages.
+packages:
+- '.'
+# Dependency packages to be pulled from upstream that are not in the resolver
+# (e.g., acme-missiles-0.3)
+extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+flags: {}
+
+# Extra package databases containing global packages
+extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=1.4"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor