1ee6235 · typeable/xsd-isogen

README.md+3−3

compare with master

unifiedsplit

@@ -5,10 +5,10 @@ Tool to generate xml-isogen descriptions from xsd files

5Usage

6=====

7

8−Use `xsd-isogen in.xsd Generator > out.hs` for queries.

8+Use `xsd-isogen -i in.xsd -m Generator > out.hs` for queries.

9

10−Use `xsd-isogen in.xsd Parser > out.hs` for responses.

10+Use `xsd-isogen -i in.xsd -m Parser > out.hs` for responses.

11

12−Use `xsd-isogen in.xsd Both > out.hs` for common definitions.

12+Use `xsd-isogen -i in.xsd -m Both > out.hs` for common definitions.

13

14If there are conflicting field names in some datatypes, one of the the datatype names gets consecutive numbers starting from 2 appended to it (so that the field name prefix changes) until there are no more conflicts.

src/Main.hs+14−19

@@ -25,19 +25,13 @@ import Debug.Trace

25import System.Environment

26import System.IO

27import Text.XSD

28+import Options

29+import Data.Maybe

28

30

29

31

30makeNamePrefix :: Text -> Text

32makeNamePrefix :: Text -> Text

31makeNamePrefix = T.map C.toLower . T.filter (\c -> C.isUpper c || C.isDigit c)

33makeNamePrefix = T.map C.toLower . T.filter (\c -> C.isUpper c || C.isDigit c)

32

34

33−data GenType = Parser | Generator | Both

34− deriving (Read, Show)

35−

36−genTypeToText :: GenType -> Text

37−genTypeToText Parser = "Parser"

38−genTypeToText Generator = "Generator"

39−genTypeToText Both = "Both"

40−

41type GenMonad = ReaderT DatatypeMap (Writer Text)

35type GenMonad = ReaderT DatatypeMap (Writer Text)

42

36

43class Fields a where

37class Fields a where

@@ -245,13 +239,13 @@ tellGen code comment =

245runGen :: DatatypeMap -> GenMonad a -> Text

239runGen :: DatatypeMap -> GenMonad a -> Text

246runGen dm act = execWriter $ runReaderT act dm

240runGen dm act = execWriter $ runReaderT act dm

247

241

248−generateIsoXml :: GenType -> XSD -> Text

242+generateIsoXml :: Maybe Header -> ModuleName -> GenType -> XSD -> Text

249−generateIsoXml genType (XSD (e,dm)) =

243+generateIsoXml mHeader name genType xsd@(XSD (e,dm)) =

250 let

244 let

251 (dList, el) = untwistDeps e dm

245 (dList, el) = untwistDeps e dm

252− in (header genType <>) . runGen dm $ do

246+ in (header mHeader name genType <>) . runGen dm $ do

253− for_ dList $ \(t,dt) ->

247+ for_ dList $ \(t,dt) -> do

254− generateIsoDatatype genType t dt []

248+ generateIsoDatatype genType (Just t) dt []

255 for_ el (generateIsoRecord genType)

249 for_ el (generateIsoRecord genType)

256

250

257toQualifier :: Int -> Int -> Text

251toQualifier :: Int -> Int -> Text

@@ -262,9 +256,10 @@ toQualifier minOc maxOc

262 | minOc == 1 && maxOc < minOc = error "maxOccurs < minOccurs"

256 | minOc == 1 && maxOc < minOc = error "maxOccurs < minOccurs"

263 | otherwise = "*"

257 | otherwise = "*"

264

258

265−header :: GenType -> Text

259+header :: Maybe Header -> ModuleName -> GenType -> Text

266−header genType = T.unlines $

260+header mHeader name genType = T.unlines $

261+ maybeToList (T.unlines . fmap ("-- " <>) . T.lines <$> mHeader) <>

267− [ "module Dummy where"

262+ [ "module " <> name <> " where"

268 , ""

263 , ""

269 , "import Control.DeepSeq"

264 , "import Control.DeepSeq"

270 , "import Data.THGen.XML"

265 , "import Data.THGen.XML"

@@ -450,10 +445,10 @@ generateIsoField

450

445

451main :: IO ()

446main :: IO ()

452main = do

447main = do

453− (inFile:mode:_) <- getArgs

448+ Options{..} <- getOptions

454− xml <- BL.readFile inFile

449+ xml <- BL.readFile oInput

455 let

450 let

456 xsd = case parseXSD def xml of

451 xsd = case parseXSD def xml of

457 Right xsd' -> xsd'

452 Right xsd' -> xsd'

458 Left e -> error $ show e

453 Left e -> error $ show e

459− T.hPutStrLn stdout $ generateIsoXml (read mode) xsd

454+ T.hPutStrLn stdout $ generateIsoXml oHeader oModule oMode xsd

src/Options.hsnew file+80

@@ -0,0 +1,80 @@

1+module Options

2+ ( Options(..)

3+ , optionsParser

4+ , getOptions

5+ , GenType(..)

6+ , genTypeToText

7+ , ModuleName

8+ , Header

9+ ) where

10+

11+import Data.Text (Text)

12+import qualified Data.Text as T

13+import Data.Version (showVersion)

14+import Options.Applicative

15+import Paths_xsd_isogen (version)

16+import Data.List

17+

18+

19+data GenType = Parser | Generator | Both

20+ deriving (Read, Show, Bounded, Enum)

21+

22+genTypeToText :: GenType -> Text

23+genTypeToText Parser = "Parser"

24+genTypeToText Generator = "Generator"

25+genTypeToText Both = "Both"

26+

27+type ModuleName = Text

28+type Header = Text

29+

30+data Options = Options

31+ { oHeader :: Maybe Header

32+ , oMode :: GenType

33+ , oInput :: FilePath

34+ , oModule :: ModuleName

35+ }

36+

37+optionsParser :: Parser Options

38+optionsParser = Options

39+ <$> ( flag' Nothing

40+ ( long "no-header"

41+ <> help "Do not place a header at the top of the file."

42+ ) <|> Just <$> strOption

43+ ( long "header"

44+ <> help "A custom header to be placed at the top of the file."

45+ <> value ("This file was generated by xsd-isogen version "

46+ <> T.pack (showVersion version)

47+ <> "\nhttps://github.com/dredozubov/xsd-isogen")

48+ )

49+ )

50+ <*> option auto

51+ ( long "mode"

52+ <> short 'm'

53+ <> value Both

54+ <> help ("Whether to generate both parsers and generators. One of: "

55+ <> (mconcat . intersperse ", " . fmap show

56+ $ [minBound @GenType .. maxBound]) <> ".")

57+ )

58+ <*> strOption

59+ ( long "input"

60+ <> short 'i'

61+ <> help "Path to the input .xsd file."

62+ )

63+ <*> strOption

64+ ( long "name"

65+ <> short 'n'

66+ <> help "Specify the name of the generated module."

67+ <> value "Dummy"

68+ )

69+

70+

71+getOptions :: IO Options

72+getOptions = execParser $ info (optionsParser <**> helper)

73+ $ fullDesc

74+ <> header

75+ ( "xsd-isogen version " <> showVersion version

76+ <> " (https://github.com/dredozubov/xsd-isogen)"

77+ )

78+ <> progDesc ( "A tool for generating xml-isogen-compatible "

79+ <> "(https://github.com/typeable/xml-isogen) .hs files from .xsd files."

80+ )

stack.yamlnew file+67

@@ -0,0 +1,67 @@

1+# This file was automatically generated by 'stack init'

2+#

3+# Some commonly used options have been documented as comments in this file.

4+# For advanced use and comprehensive documentation of the format, please see:

5+# https://docs.haskellstack.org/en/stable/yaml_configuration/

6+

7+# Resolver to choose a 'specific' stackage snapshot or a compiler version.

8+# A snapshot resolver dictates the compiler version and the set of packages

9+# to be used for project dependencies. For example:

10+#

11+# resolver: lts-3.5

12+# resolver: nightly-2015-09-21

13+# resolver: ghc-7.10.2

14+#

15+# The location of a snapshot can be provided as a file or url. Stack assumes

16+# a snapshot provided as a file might change, whereas a url resource does not.

17+#

18+# resolver: ./custom-snapshot.yaml

19+# resolver: https://example.com/snapshots/2018-01-01.yaml

20+resolver: lts-14.21

21+

22+# User packages to be built.

23+# Various formats can be used as shown in the example below.

24+#

25+# packages:

26+# - some-directory

27+# - https://example.com/foo/bar/baz-0.0.2.tar.gz

28+# subdirs:

29+# - auto-update

30+# - wai

31+packages:

32+- .

33+- dist-newstyle/src/xsd-parser-4708f64ddc20d345

34+# Dependency packages to be pulled from upstream that are not in the resolver.

35+# These entries can reference officially published versions as well as

36+# forks / in-progress versions pinned to a git hash. For example:

37+#

38+# extra-deps:

39+# - acme-missiles-0.3

40+# - git: https://github.com/commercialhaskell/stack.git

41+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

42+#

43+# extra-deps: []

44+

45+# Override default flag values for local packages and extra-deps

46+# flags: {}

47+

48+# Extra package databases containing global packages

49+# extra-package-dbs: []

50+

51+# Control whether we use the GHC we find on the path

52+# system-ghc: true

53+#

54+# Require a specific version of stack, using version ranges

55+# require-stack-version: -any # Default

56+# require-stack-version: ">=2.1"

57+#

58+# Override the architecture used by stack, especially useful on Windows

59+# arch: i386

60+# arch: x86_64

61+#

62+# Extra directories used by stack for building

63+# extra-include-dirs: [/path/to/dir]

64+# extra-lib-dirs: [/path/to/dir]

65+#

66+# Allow a newer minor version of GHC than the snapshot specifies

67+# compiler-check: newer-minor

xsd-isogen.cabal+8−4

@@ -10,26 +10,27 @@ synopsis: Generate xml-isogen DSL from xsd files

10homepage: github.com/dredozubov/xsd-isogen

11-- bug-reports:

12license: BSD-3-Clause

13−license-file: LICENSE

13+-- license-file: LICENSE

14author: Denis Redozubov

15maintainer: denis.redozubov@gmail.com

16-- copyright:

17category: Text

18−extra-source-files: CHANGELOG.md

18+-- extra-source-files: CHANGELOG.md

19

20executable xsd-isogen

21 main-is: Main.hs

22− -- other-modules:

22+ other-modules: Options

23 -- other-extensions:

24 build-depends: base ^>=4.12.0.0

25 , bytestring

26 , containers

27 , data-default

28 , mtl

29+ , optparse-applicative

29 , text

30 , text

31+ , unordered-containers

30 , writer-cps-mtl

32 , writer-cps-mtl

31 , xsd-parser

33 , xsd-parser

32− , unordered-containers

33 hs-source-dirs: src

34 hs-source-dirs: src

34 default-language: Haskell2010

35 default-language: Haskell2010

35 ghc-options: -fwarn-unused-binds

36 ghc-options: -fwarn-unused-binds

@@ -43,3 +44,6 @@ executable xsd-isogen

43 , -Widentities

44 , -Widentities

44 , -Wredundant-constraints

45 , -Wredundant-constraints

45 , -Wmissing-export-lists

46 , -Wmissing-export-lists

47+ default-extensions: TypeApplications

48+ , OverloadedStrings

49+ , RecordWildCards