From 5c24d571e237d26d15b71d342722f7321fc0509a Mon Sep 17 00:00:00 2001 From: yamadapc Date: Mon, 12 Jun 2017 11:07:48 -0300 Subject: [PATCH 1/3] Add .stack-work to .gitignore --- .gitignore | 1 + 1 file changed, 1 insertion(+) create mode 100644 .gitignore diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..8ee1bf9 --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +.stack-work From 06c250bda42091baa5369cdb89ba7a410686b197 Mon Sep 17 00:00:00 2001 From: yamadapc Date: Tue, 13 Jun 2017 16:20:04 -0300 Subject: [PATCH 2/3] Start working on XSD gen from imports and refs Also needs to follow groups and everything else that isn't supported atm. --- HaXml.cabal | 2 +- src/Text/XML/HaXml/Schema/Environment.hs | 41 +++---- src/tools/XsdToHaskell.hs | 138 +++++++++++++++-------- stack.yaml | 66 +++++++++++ 4 files changed, 182 insertions(+), 65 deletions(-) create mode 100644 stack.yaml diff --git a/HaXml.cabal b/HaXml.cabal index a505790..4fe4491 100644 --- a/HaXml.cabal +++ b/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 diff --git a/src/Text/XML/HaXml/Schema/Environment.hs b/src/Text/XML/HaXml/Schema/Environment.hs index 9d0653d..80a9969 100644 --- a/src/Text/XML/HaXml/Schema/Environment.hs +++ b/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 diff --git a/src/tools/XsdToHaskell.hs b/src/tools/XsdToHaskell.hs index 64581e8..0d05d72 100644 --- a/src/tools/XsdToHaskell.hs +++ b/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 diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..298b56e --- /dev/null +++ b/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 \ No newline at end of file From b46984755fc9b3c177efc6e161ef76dd141e76d9 Mon Sep 17 00:00:00 2001 From: yamadapc Date: Wed, 14 Jun 2017 18:53:10 -0300 Subject: [PATCH 3/3] Remove CPP VERSION statements to build on windows --- src/Text/XML/HaXml.hs | 2 +- src/Text/XML/HaXml/Wrappers.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Text/XML/HaXml.hs b/src/Text/XML/HaXml.hs index d106240..473597a 100644 --- a/src/Text/XML/HaXml.hs +++ b/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 diff --git a/src/Text/XML/HaXml/Wrappers.hs b/src/Text/XML/HaXml/Wrappers.hs index 1d4daaf..5fbb44b 100644 --- a/src/Text/XML/HaXml/Wrappers.hs +++ b/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"