0cb0fa4...master · typeable/xml-isogen

git.iko.soy/typeable/xml-isogen

on master help sign in

.gitignore+2−1

since splitsnapshots

unifiedsplit

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

3.stack-work

4.cabal-sandbox/

5cabal.sandbox.config

6−

6+dist-newstyle/

7+default.nix

7# vim backup and swap files

8# vim backup and swap files

8*~

9*~

9.*.swp

10.*.swp

CHANGELOG.md+1

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

1HEAD

2------

4+* Add lenient parsers support (#29)

4* Rename Both to ParserAndGenerator (#27)

5* Rename Both to ParserAndGenerator (#27)

5* Add Nillable newtype (#24)

6* Add Nillable newtype (#24)

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

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

README.md+10

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

280 ns:nil="true"

281/>

282```

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+```

shell.nixnew file+17

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

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

3+let

5+ inherit (nixpkgs) pkgs;

7+ f = import ./default.nix;

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/XML/Internal.hs+57−16

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

5module Data.THGen.XML.Internal where

7import Control.DeepSeq

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

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

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

10import qualified Data.Char as C

11import Data.List.NonEmpty (NonEmpty)

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

15import Data.THGen.Enum

16import qualified Data.Text as T

17import GHC.Generics (Generic)

18−import Language.Haskell.TH as TH

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

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

20import qualified Text.XML as X

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

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

23import Text.XML.ParentAttributes

24import qualified Text.XML.Writer as XW

26+data ParserMode

27+ = Strict

28+ | Lenient

30+data GenType

31+ = Parser

32+ | Generator

27−data GenType = Parser | Generator | ParserAndGenerator

33+ | ParserAndGenerator

34+ | LenientParser

35+ | LenientParserAndGenerator

36+

37+isLenientType :: GenType -> Bool

38+isLenientType = \case

39+ LenientParser -> True

40+ LenientParserAndGenerator -> True

41+ _ -> False

29data XmlFieldPlural

43data XmlFieldPlural

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

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

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

146 exhaustivenessName =:= (IsoXmlDescEnum genType descEnumCons) =

160 exhaustivenessName =:= (IsoXmlDescEnum genType descEnumCons) =

147 isoXmlGenerateEnum genType exhaustivenessName (reverse descEnumCons)

161 isoXmlGenerateEnum genType exhaustivenessName (reverse descEnumCons)

148

162

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

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

150 fromString = IsoXmlDescPreField

164 fromString = IsoXmlDescPreField

151

165

152instance IsString IsoXmlDescPreField where

166instance IsString IsoXmlDescPreField where

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

154 where

168 where

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

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

156

170

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

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

158 fromString = IsoXmlDescPreAttribute

172 fromString = IsoXmlDescPreAttribute

159

173

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

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

161 fromString = IsoXmlDescPreContent

175 fromString = IsoXmlDescPreContent

162

176

163instance IsString IsoXmlDescPreAttribute where

177instance IsString IsoXmlDescPreAttribute where

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

211 (return [])

225 (return [])

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

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

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

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

214− genFromDomInst = do

228+ genFromDomInst mode = do

215 TH.instanceD

229 TH.instanceD

216 (return [])

230 (return [])

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

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

232+ [case mode of

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

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

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

235+ ]

219 genFromAttributeInst = do

236 genFromAttributeInst = do

220 TH.instanceD

237 TH.instanceD

221 (return [])

238 (return [])

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

227 toXmlAttributeInst <- genToXmlAttributeInst

244 toXmlAttributeInst <- genToXmlAttributeInst

228 return $ enumDecls ++ [toXmlInst, toXmlAttributeInst]

245 return $ enumDecls ++ [toXmlInst, toXmlAttributeInst]

229 Parser -> do

246 Parser -> do

230− fromDomInst <- genFromDomInst

247+ fromDomInst <- genFromDomInst Strict

248+ fromAttributeInst <- genFromAttributeInst

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

250+ LenientParser -> do

251+ fromDomInst <- genFromDomInst Lenient

231 fromAttributeInst <- genFromAttributeInst

252 fromAttributeInst <- genFromAttributeInst

232 return $ enumDecls ++ [fromDomInst, fromAttributeInst]

253 return $ enumDecls ++ [fromDomInst, fromAttributeInst]

233 ParserAndGenerator -> do

254 ParserAndGenerator -> do

234 toXmlInst <- genToXmlInst

255 toXmlInst <- genToXmlInst

235 toXmlAttributeInst <- genToXmlAttributeInst

256 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

237 fromAttributeInst <- genFromAttributeInst

265 fromAttributeInst <- genFromAttributeInst

238 return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,

266 return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,

239 fromDomInst, fromAttributeInst]

267 fromDomInst, fromAttributeInst]

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

256 IsoXmlDescField fieldPlural rawName fieldType = descField

284 IsoXmlDescField fieldPlural rawName fieldType = descField

257 fieldStrName = xmlLocalName rawName

285 fieldStrName = xmlLocalName rawName

258 fName = TH.mkName (fieldName fieldStrName)

286 fName = TH.mkName (fieldName fieldStrName)

259− fType = case fieldPlural of

287+ fType' = case fieldPlural of

260 XmlFieldPluralMandatory -> fieldType

288 XmlFieldPluralMandatory -> fieldType

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

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

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

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

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

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

292+ fType = if isLenientType genType

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

294+ else fType'

264 in if isNewtype

295 in if isNewtype

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

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

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

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

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

295 [ ]

326 [ ]

296

327

297 let

328 let

298− genFromDomInst = do

329+ genFromDomInst mode = do

299 let

330 let

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

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

301 exprRecordParts = do

332 exprRecordParts = do

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

309 fieldParse = case fieldPlural of

340 fieldParse = case fieldPlural of

310 XmlFieldPluralMandatory -> [e|inElem|]

341 XmlFieldPluralMandatory -> [e|inElem|]

311 _ -> [e|inElemTrav|]

342 _ -> [e|inElemTrav|]

312− in

343+ in case mode of

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

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

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

314 IsoXmlDescRecordAttribute descAttribute ->

346 IsoXmlDescRecordAttribute descAttribute ->

315 let

347 let

316 IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute

348 IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute

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

396 return $ [termDecl] ++ lensDecls ++

428 return $ [termDecl] ++ lensDecls ++

397 [toXmlInst, toXmlParentAttributesInst, nfDataInst]

429 [toXmlInst, toXmlParentAttributesInst, nfDataInst]

398 Parser -> do

430 Parser -> do

399− fromDomInst <- genFromDomInst

431+ fromDomInst <- genFromDomInst Strict

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

433+ LenientParser -> do

434+ fromDomInst <- genFromDomInst Lenient

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

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

401 ParserAndGenerator -> do

436 ParserAndGenerator -> do

402 toXmlInst <- genToXmlInst

437 toXmlInst <- genToXmlInst

403 toXmlParentAttributesInst <- genToXmlParentAttributeInst

438 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

405 return $ [termDecl] ++ lensDecls ++

446 return $ [termDecl] ++ lensDecls ++

406 [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]

447 [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]

407

448

stack-10.0.yamlnew file+8

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

1+nix:

2+ packages:

3+ - zlib

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

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

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+4−3

@@ -2,7 +2,8 @@ nix:

2 packages:

3 - zlib

5−resolver: lts-10.0

5+resolver: lts-20.16

6extra-deps:

7−- dom-parser-3.0.0

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

8−- generic-arbitrary-0.1.0

8+ commit: 7d556ba528bfa216e99714f8a0d4d00f452803a9

9+ - xml-lens-0.3.1

xml-isogen.cabal+2−2

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

1name: xml-isogen

2−version: 0.3.1

2+version: 0.3.2

3synopsis: Generate XML-isomorphic types

4description:

5 TemplateHaskell generators for XML-isomorphic data types, including

@@ -42,12 +42,12 @@ library

42 , deepseq

43 , lens >= 4.13

44 , mtl >= 2.2

45+ , scientific

45 , semigroups >= 0.18

46 , semigroups >= 0.18

46 , template-haskell >= 2.10

47 , template-haskell >= 2.10

47 , text >= 1.2

48 , text >= 1.2

48 , xml-conduit >= 1.0

49 , xml-conduit >= 1.0

49 , xml-conduit-writer >= 0.1

50 , xml-conduit-writer >= 0.1

50− , scientific

52 ghc-options: -Wall