b35a07a...master · typeable/xml-isogen

.gitignore+2−1

@@ -3,7 +3,8 @@ dist

33.stack-work

44.cabal-sandbox/

55cabal.sandbox.config

6−

6+dist-newstyle/

7+default.nix

78# vim backup and swap files

89*~

910.*.swp

CHANGELOG.md+1

@@ -1,6 +1,7 @@

11HEAD

22------

33

4+* Add lenient parsers support (#29)

45* Rename Both to ParserAndGenerator (#27)

56* Add Nillable newtype (#24)

67* Include digits in the auto-gerenated prefix (#22)

README.md+10

@@ -280,3 +280,13 @@ then the following XML will be generated:

280280 ns:nil="true"

281281/>

282282```

283+

284+## Development

285+

286+To start working with `xml-isogen` using nix use:

287+

288+```

289+nix-shell --packages cabal2nix --run "cabal2nix ." > default.nix

290+nix-shell

291+cabal v2-build

292+```

ghc-802.yaml+4

@@ -1,3 +1,7 @@

1+nix:

2+ packages:

3+ - zlib

4+

15resolver: lts-9.21

26

37packages:

ghc-822.yaml+4

@@ -1 +1,5 @@

1+nix:

2+ packages:

3+ - zlib

4+

15resolver: lts-11.22

ghc-844.yaml+4

@@ -1,3 +1,7 @@

1+nix:

2+ packages:

3+ - zlib

4+

15resolver: lts-12.16

26extra-deps:

37- dom-parser-3.1.0

shell.nixnew file+17

@@ -0,0 +1,17 @@

1+{ nixpkgs ? import <nixpkgs> {}, compiler ? "default" }:

2+

3+let

4+

5+ inherit (nixpkgs) pkgs;

6+

7+ f = import ./default.nix;

8+

9+ haskellPackages = if compiler == "default"

10+ then pkgs.haskellPackages

11+ else pkgs.haskell.packages.${compiler};

12+

13+ drv = haskellPackages.callPackage f {};

14+

15+in

16+

17+ if pkgs.lib.inNixShell then drv.env else drv

src/Data/THGen/Orphans.hs+3−1

@@ -1,8 +1,10 @@

1+{-# OPTIONS_GHC -fno-warn-orphans #-}

2+

13module Data.THGen.Orphans

24where

35

4−import qualified Data.Text as Text

56import Data.Scientific

7+import qualified Data.Text as Text

68import Text.XML.Writer

79

810instance ToXML Scientific where

src/Data/THGen/XML/Internal.hs+57−16

@@ -5,7 +5,7 @@

55module Data.THGen.XML.Internal where

66

77import Control.DeepSeq

8−import Control.Lens hiding (repeated, enum, (&))

8+import Control.Lens hiding (repeated, enum, (&), Strict)

99import Control.Lens.Internal.FieldTH (makeFieldOpticsForDec)

1010import qualified Data.Char as C

1111import Data.List.NonEmpty (NonEmpty)

@@ -15,7 +15,7 @@ import Data.THGen.Compat as THC

1515import Data.THGen.Enum

1616import qualified Data.Text as T

1717import GHC.Generics (Generic)

18−import Language.Haskell.TH as TH

18+import Language.Haskell.TH as TH hiding (Strict)

1919import Prelude hiding ((+), (*), (^))

2020import qualified Text.XML as X

2121import Text.XML.DOM.Parser hiding (parseContent)

@@ -23,8 +23,22 @@ import Text.XML.DOM.Parser.Internal.Content

2323import Text.XML.ParentAttributes

2424import qualified Text.XML.Writer as XW

2525

26+data ParserMode

27+ = Strict

28+ | Lenient

2629

27−data GenType = Parser | Generator | ParserAndGenerator

30+data GenType

31+ = Parser

32+ | Generator

33+ | ParserAndGenerator

34+ | LenientParser

35+ | LenientParserAndGenerator

36+

37+isLenientType :: GenType -> Bool

38+isLenientType = \case

39+ LenientParser -> True

40+ LenientParserAndGenerator -> True

41+ _ -> False

2842

2943data XmlFieldPlural

3044 = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)

@@ -146,7 +160,7 @@ instance Description ExhaustivenessName IsoXmlDescEnum where

146160 exhaustivenessName =:= (IsoXmlDescEnum genType descEnumCons) =

147161 isoXmlGenerateEnum genType exhaustivenessName (reverse descEnumCons)

148162

149−instance IsString (TH.TypeQ -> IsoXmlDescPreField) where

163+instance (m ~ Q) => IsString (m TH.Type -> IsoXmlDescPreField) where

150164 fromString = IsoXmlDescPreField

151165

152166instance IsString IsoXmlDescPreField where

@@ -154,10 +168,10 @@ instance IsString IsoXmlDescPreField where

154168 where

155169 ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper (xmlLocalName name))

156170

157−instance IsString (TH.TypeQ -> IsoXmlDescPreAttribute) where

171+instance (m ~ Q) => IsString (m TH.Type -> IsoXmlDescPreAttribute) where

158172 fromString = IsoXmlDescPreAttribute

159173

160−instance IsString (TH.TypeQ -> IsoXmlDescPreContent) where

174+instance (m ~ Q) => IsString (m Type -> IsoXmlDescPreContent) where

161175 fromString = IsoXmlDescPreContent

162176

163177instance IsString IsoXmlDescPreAttribute where

@@ -211,11 +225,14 @@ isoXmlGenerateEnum genType (ExhaustivenessName strName' exh) enumCons = do

211225 (return [])

212226 [t|ToXmlAttribute $(TH.conT name)|]

213227 [funSimple 'toXmlAttribute [e|T.pack . show|]]

214− genFromDomInst = do

228+ genFromDomInst mode = do

215229 TH.instanceD

216230 (return [])

217231 [t|FromDom $(TH.conT name)|]

218− [funSimple 'fromDom [e|parseContent readContent|]]

232+ [case mode of

233+ Strict -> funSimple 'fromDom [e|parseContent readContent|]

234+ Lenient -> funSimple 'fromDom [e|ignoreBlank $ parseContent readContent|]

235+ ]

219236 genFromAttributeInst = do

220237 TH.instanceD

221238 (return [])

@@ -227,13 +244,24 @@ isoXmlGenerateEnum genType (ExhaustivenessName strName' exh) enumCons = do

227244 toXmlAttributeInst <- genToXmlAttributeInst

228245 return $ enumDecls ++ [toXmlInst, toXmlAttributeInst]

229246 Parser -> do

230− fromDomInst <- genFromDomInst

247+ fromDomInst <- genFromDomInst Strict

248+ fromAttributeInst <- genFromAttributeInst

249+ return $ enumDecls ++ [fromDomInst, fromAttributeInst]

250+ LenientParser -> do

251+ fromDomInst <- genFromDomInst Lenient

231252 fromAttributeInst <- genFromAttributeInst

232253 return $ enumDecls ++ [fromDomInst, fromAttributeInst]

233254 ParserAndGenerator -> do

234255 toXmlInst <- genToXmlInst

235256 toXmlAttributeInst <- genToXmlAttributeInst

236− fromDomInst <- genFromDomInst

257+ fromDomInst <- genFromDomInst Strict

258+ fromAttributeInst <- genFromAttributeInst

259+ return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,

260+ fromDomInst, fromAttributeInst]

261+ LenientParserAndGenerator -> do

262+ toXmlInst <- genToXmlInst

263+ toXmlAttributeInst <- genToXmlAttributeInst

264+ fromDomInst <- genFromDomInst Lenient

237265 fromAttributeInst <- genFromAttributeInst

238266 return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,

239267 fromDomInst, fromAttributeInst]

@@ -256,11 +284,14 @@ isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts

256284 IsoXmlDescField fieldPlural rawName fieldType = descField

257285 fieldStrName = xmlLocalName rawName

258286 fName = TH.mkName (fieldName fieldStrName)

259− fType = case fieldPlural of

287+ fType' = case fieldPlural of

260288 XmlFieldPluralMandatory -> fieldType

261289 XmlFieldPluralOptional -> [t| Maybe $fieldType |]

262290 XmlFieldPluralRepeated -> [t| [$fieldType] |]

263291 XmlFieldPluralMultiplied -> [t| NonEmpty $fieldType |]

292+ fType = if isLenientType genType

293+ then [t| Maybe $fType' |]

294+ else fType'

264295 in if isNewtype

265296 then THC.varStrictType fName (THC.nonStrictType fType)

266297 else THC.varStrictType fName (THC.strictType fType)

@@ -295,7 +326,7 @@ isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts

295326 [ ]

296327

297328 let

298− genFromDomInst = do

329+ genFromDomInst mode = do

299330 let

300331 exprHeader = [e|pure $(TH.conE name)|]

301332 exprRecordParts = do

@@ -309,8 +340,9 @@ isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts

309340 fieldParse = case fieldPlural of

310341 XmlFieldPluralMandatory -> [e|inElem|]

311342 _ -> [e|inElemTrav|]

312− in

313− [e|$fieldParse $exprFieldStrName fromDom|]

343+ in case mode of

344+ Strict -> [e|$fieldParse $exprFieldStrName fromDom|]

345+ Lenient -> [e|$fieldParse $exprFieldStrName (ignoreBlank fromDom)|]

314346 IsoXmlDescRecordAttribute descAttribute ->

315347 let

316348 IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute

@@ -396,12 +428,21 @@ isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts

396428 return $ [termDecl] ++ lensDecls ++

397429 [toXmlInst, toXmlParentAttributesInst, nfDataInst]

398430 Parser -> do

399− fromDomInst <- genFromDomInst

431+ fromDomInst <- genFromDomInst Strict

432+ return $ [termDecl] ++ lensDecls ++ [fromDomInst, nfDataInst]

433+ LenientParser -> do

434+ fromDomInst <- genFromDomInst Lenient

400435 return $ [termDecl] ++ lensDecls ++ [fromDomInst, nfDataInst]

401436 ParserAndGenerator -> do

402437 toXmlInst <- genToXmlInst

403438 toXmlParentAttributesInst <- genToXmlParentAttributeInst

404− fromDomInst <- genFromDomInst

439+ fromDomInst <- genFromDomInst Strict

440+ return $ [termDecl] ++ lensDecls ++

441+ [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]

442+ LenientParserAndGenerator -> do

443+ toXmlInst <- genToXmlInst

444+ toXmlParentAttributesInst <- genToXmlParentAttributeInst

445+ fromDomInst <- genFromDomInst Lenient

405446 return $ [termDecl] ++ lensDecls ++

406447 [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]

407448

src/Text/XML/Nillable.hs+21−11

@@ -1,23 +1,33 @@

1+{-# LANGUAGE MonoLocalBinds #-}

12{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE MonoLocalBinds #-}

3−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

43

5−module Text.XML.Nillable

6−where

4+module Text.XML.Nillable where

75

8−import Control.DeepSeq

9−import Text.XML.DOM.Parser

10−import Text.XML.Writer

11−import Text.XML.ParentAttributes

6+import Control.DeepSeq

7+import Control.Lens

8+import Text.XML.DOM.Parser

9+import Text.XML.ParentAttributes

10+import Text.XML.Writer

1211

1312-- | Type that can have explicit null value

1413--

1514-- Null value is indicated by "nil"="true" attribute.

1615newtype Nillable a = Nillable (Maybe a)

17− deriving (Eq, Show, Ord, Read, NFData, ToXML)

16+ deriving

17+ ( Eq, Show, Ord, Read, NFData, ToXML

18+ , Functor, Applicative, Monad, Foldable, Traversable)

19+

20+_Nillable :: Prism' (Nillable a) a

21+_Nillable = coerced . _Just

22+

23+nNill :: Nillable a

24+nNill = Nillable Nothing

25+

26+nJust :: a -> Nillable a

27+nJust = Nillable . Just

1828

1929instance ToXmlParentAttributes a => ToXmlParentAttributes (Nillable a) where

20− toXmlParentAttributes (Nillable Nothing) =

30+ toXmlParentAttributes (Nillable Nothing) =

2131 [("{http://www.w3.org/2001/XMLSchema-instance}nil", "true")]

2232 toXmlParentAttributes (Nillable (Just a)) = toXmlParentAttributes a

2333

@@ -28,4 +38,4 @@ instance FromDom a => FromDom (Nillable a) where

2838 Right

2939 case nil of

3040 Just "true" -> return (Nillable Nothing)

31− _ -> Nillable . Just <$> fromDom

41+ _ -> Nillable . Just <$> fromDom

stack-10.0.yamlnew file+8

@@ -0,0 +1,8 @@

1+nix:

2+ packages:

3+ - zlib

4+

5+resolver: lts-10.0

6+extra-deps:

7+- dom-parser-3.0.0

8+- generic-arbitrary-0.1.0

stack-18.18.yamlnew file+9

@@ -0,0 +1,9 @@

1+nix:

2+ packages:

3+ - zlib

4+

5+resolver: lts-18.18

6+extra-deps:

7+- git: https://github.com/typeable/dom-parser.git

8+ commit: 7d556ba528bfa216e99714f8a0d4d00f452803a9

9+- xml-lens-0.3.1

stack-19.6.yamlnew file+9

@@ -0,0 +1,9 @@

1+nix:

2+ packages:

3+ - zlib

4+

5+resolver: lts-19.6

6+extra-deps:

7+- git: https://github.com/typeable/dom-parser.git

8+ commit: 7d556ba528bfa216e99714f8a0d4d00f452803a9

9+- xml-lens-0.3.1

stack.yaml+8−3

@@ -1,4 +1,9 @@

1−resolver: lts-10.0

1+nix:

2+ packages:

3+ - zlib

4+

5+resolver: lts-20.16

26extra-deps:

3−- dom-parser-3.0.0

4−- generic-arbitrary-0.1.0

7+ - git: https://github.com/typeable/dom-parser.git

8+ commit: 7d556ba528bfa216e99714f8a0d4d00f452803a9

9+ - xml-lens-0.3.1

xml-isogen.cabal+6−2

@@ -1,5 +1,5 @@

11name: xml-isogen

2−version: 0.3.1

2+version: 0.3.2

33synopsis: Generate XML-isomorphic types

44description:

55 TemplateHaskell generators for XML-isomorphic data types, including

@@ -42,18 +42,22 @@ library

4242 , deepseq

4343 , lens >= 4.13

4444 , mtl >= 2.2

45+ , scientific

4546 , semigroups >= 0.18

4647 , template-haskell >= 2.10

4748 , text >= 1.2

4849 , xml-conduit >= 1.0

4950 , xml-conduit-writer >= 0.1

50− , scientific

51+

52+ ghc-options: -Wall

5153

5254 hs-source-dirs: src

5355

5456 default-language: Haskell2010

5557 default-extensions: CPP

58+ , DeriveTraversable

5659 , FlexibleInstances

60+ , GeneralizedNewtypeDeriving

5761 , LambdaCase

5862 , TemplateHaskell

5963 , TupleSections