56f7eaa..master · typeable/xml-isogen

git.iko.soy/typeable/xml-isogen

17 files changed+502−65

unifiedsplit

.gitignore+5 CHANGELOG.md+5 README.md+284−1 ghc-802.yaml+4 ghc-822.yaml+4 ghc-844.yaml+4 shell.nix+17 src/Data/THGen/Orphans.hs+11 src/Data/THGen/XML.hs+6−3 src/Data/THGen/XML/Internal.hs+75−53 src/Text/XML/Nillable.hs+41 stack-10.0.yaml+8 stack-18.18.yaml+9 stack-19.6.yaml+9 stack.yaml+8−3 test/TestDefs.hs+4−4 xml-isogen.cabal+8−1

.gitignore+5

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

33.stack-work

44.cabal-sandbox/

55cabal.sandbox.config

6+dist-newstyle/

7+default.nix

8+# vim backup and swap files

9+*~

10+.*.swp

CHANGELOG.md+5

@@ -1,6 +1,11 @@

11HEAD

22------

4+* Add lenient parsers support (#29)

5+* Rename Both to ParserAndGenerator (#27)

6+* Add Nillable newtype (#24)

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

490.3.0

510------

611

README.md+284−1

@@ -6,4 +6,287 @@ TemplateHaskell generators for XML-isomorphic data types, including

66instances for parsing and rendering. A convenient DSL to define those

77types.

9−This is similar to XSD but is Haskell-specific.

9+Essentially it's a haskell DSL which allows its users to generate XML parsers and generators for haskell datatypes.

10+See also [xsd-isogen](https://github.com/typeable/xsd-isogen)

11+

12+## Tutorial

13+

14+Lets go through series of examples. First things first:

15+

16+```haskell

17+{-# LANGUAGE TemplateHaskell #-}

18+{-# LANGUAGE OverloadedStrings #-}

19+{-# LANGUAGE DeriveGeneric #-}

20+

21+module Tutorial

22+where

23+

24+import Prelude hiding ((^))

25+import Control.DeepSeq -- from deepseq

26+import Data.Text

27+import Data.THGen.XML -- from xml-isogen

28+import Text.XML.Writer -- from xml-conduit-writer

29+import Text.XML.DOM.Parser -- from dom-parser

30+```

31+

32+### Records

33+

34+Lets say we want to parse and/or generate an XML file of the following form:

35+

36+```XML

37+<?xml version="1.0" encoding="UTF-8"?>

38+<person>

39+ <name>

40+ John

41+ </name>

42+ <email>

43+ john@example.com

44+ </email>

45+</person>

46+```

47+

48+Person has a name and an email, and email could be omitted. With `xml-isogen` it's

49+enough to write the following definition:

50+

51+```haskell

52+"Person" =:= record ParserAndGenerator

53+ ! "name" [t|Text|]

54+ ? "email" [t|Text|]

55+```

56+

57+At this point you can load the module into `ghci` and check what was generated for us

58+so far:

59+

60+```

61+*Tutorial> :browse

62+data XmlPerson

63+ = XmlPerson {_xpName :: !Text, _xpEmail :: !(Maybe Text)}

64+xpEmail ::

65+ lens-4.18.1:Control.Lens.Type.Lens' XmlPerson (Maybe Text)

66+xpName :: lens-4.18.1:Control.Lens.Type.Lens' XmlPerson Text

67+```

68+

69+We have a data type `XmlPerson` with two fields and two lenses. Note that the

70+fields have a prefix built of an underscore and all upper case characters

71+and digits of the type name.

72+

73+

74+Lets take a closer look at `XmlPerson`:

75+

76+```

77+*Tutorial> :i XmlPerson

78+data XmlPerson

79+ = XmlPerson {_xpName :: !Text, _xpEmail :: !(Maybe Text)}

80+ -- Defined at Tutorial.hs:13:1

81+instance Show XmlPerson -- Defined at Tutorial.hs:13:1

82+instance Eq XmlPerson -- Defined at Tutorial.hs:13:1

83+instance FromDom XmlPerson -- Defined at Tutorial.hs:13:1

84+instance ToXML XmlPerson -- Defined at Tutorial.hs:13:1

85+

86+```

87+

88+We have

89+[FromDom](https://hackage.haskell.org/package/dom-parser-3.1.0/docs/Text-XML-DOM-Parser-FromDom.html#t:FromDom)

90+and

91+[ToXML](https://hackage.haskell.org/package/xml-conduit-writer-0.1.1.2/docs/Text-XML-Writer.html#t:ToXML)

92+instance generated for us. That's because

93+we instructed `xml-isogen` to generate them using the `ParserAndGenerator` noun. You can specify

94+also `Parser` or `Generator` if you want only one of them.

95+

96+The `_xpEmail` field is optional; that's because we prefixed it with `?` modifier.

97+Here is the list of possible modifiers that affect types:

98+

99+Modifier | Description | Generated Type

100+--- | --- | ---

101+`!` | required | `a`

102+`?` | optional | `Maybe a`

103+`*` | repeated | `[a]`

104+`+` | nonempty | `NonEmpty a`

105+

106+### Supported types

107+

108+Fields in a record may have any types as long as they are instances of `Eq`, `Show`,

109+`NFData`, `FromDom` (for the parser) and `ToXml` (for the generator). Remember

110+though that TemplateHaskell requires types to be available before they are used

111+in a splice.

112+

113+You can omit field types altogether, in that case the type will be assumed to be a

114+capitalized field name with an `Xml` prefix.

115+It's your responsibility to make sure that type exists.

116+Example:

117+

118+```haskell

119+newtype XmlEmail = XmlEmail Text

120+ deriving (Eq, Show, NFData, ToXML)

121+

122+instance FromDom XmlEmail where

123+ fromDom = XmlEmail <$> fromDom

124+

125+"Example1" =:= record Parser

126+ ! "email" -- will have type XmlEmail

127+```

128+

129+### Enumerations

130+

131+Often XML element can contain only limited number of possible values. Lets define

132+a type `Status` that can have only values `Active`, `Pending` or `Deleted`:

133+

134+```haskell

135+"Status" =:= enum ParserAndGenerator

136+ & "Active"

137+ & "Pending"

138+ & "Deleted"

139+```

140+

141+This definition will generate the following type for us:

142+

143+```haskell

144+data XmlStatus

145+ = XmlStatusActive

146+ | XmlStatusPending

147+ | XmlStatusDeleted

148+ | UnknownXmlStatus !String

149+```

150+

151+It has all the necessary instances, so you can use it as a type for a field.

152+

153+### Append content

154+

155+Sometimes the XML you are dealing with contains a mix of elements and immediate

156+content. Something like the following:

157+

158+```XML

159+<?xml version="1.0" encoding="UTF-8"?>

160+<example>

161+ <field1>

162+ I am

163+ </field1>

164+ totally

165+ <field2>

166+ weird

167+ </field2>

168+</example>

169+```

170+

171+You can model this with an "append content" modifier `^`. It will instruct

172+`xml-isogen` to append content of the field as it is, without wrapping it

173+into an XML element. For our case it may look like this:

174+

175+```haskell

176+"Example2" =:= record ParserAndGenerator

177+ ! "field1" [t|Text|]

178+ ^ "mixed" [t|Text|]

179+ ! "field2" [t|Text|]

180+```

181+

182+After parsing the XML above, we'll get the following:

183+

184+```haskell

185+XmlExample2 {_xe2Field1 = "I am", _xe2Mixed = "totally", _xe2Field2 = "weird"}

186+```

187+

188+### Attributes

189+

190+`xml-isogen` also supports XML attributes using `!%` and `?%` modifiers:

191+

192+```haskell

193+"Example3" =:= record ParserAndGenerator

194+ ! "field1" [t|Text|]

195+ !% "attribute1" [t|Text|]

196+ ?% "attribute2" [t|Text|]

197+

198+"Body" =:= record ParserAndGenerator

199+ ! "root" [t|XmlExample3|]

200+```

201+

202+The following two types will be generated:

203+

204+```haskell

205+data XmlExample3

206+ = XmlExample3 {_xe3Field1 :: !Text,

207+ _xe3Attribute1 :: !Text,

208+ _xe3Attribute2 :: !(Maybe Text)}

209+

210+newtype XmlBody = XmlBody {_xbRoot :: XmlExample3}

211+```

212+

213+The `_xe3Attribute2` is optional because we used `?%` modifier. Attributes will be

214+attached to parent XML element. Here is an example of the generated XML file:

215+

216+```XML

217+<root attribute1="world">

218+ <field1>

219+ hello

220+ </field1>

221+</root>

222+```

223+

224+Note that attributes are attached to the parent XML element, that's why we needed

225+`XmlBody` type here.

226+

227+And here is what you get after parsing the XML:

228+

229+```haskell

230+XmlExample3 {_xe3Field1 = "hello", _xe3Attribute1 = "world", _xe3Attribute2 = Nothing}

231+```

232+

233+### Namespaces

234+

235+Often XSD schema requires XML elements to be qualified with a namespace. To instruct

236+`xml-isogen` to qualify fields, specify namespace is a curly brackets:

237+

238+```haskell

239+"Example4" =:= record ParserAndGenerator

240+ ! "field1" [t|Text|]

241+ ! "{http://example.com/1}field2" [t|Text|]

242+ ! "{http://example.com/2}field3" [t|Text|]

243+```

244+

245+Here is the generated XML:

246+

247+```XML

248+<field1>

249+ hello

250+</field1>

251+<field2 xmlns="http://example.com/1">

252+ world

253+</field2>

254+<field3 xmlns="http://example.com/2">

255+ !

256+</field3>

257+```

258+

259+### Nillable types

260+

261+Sometimes optional element in XML are encoded using `nil="true"` attribute instead of

262+omitting the element. (The `nil` attribute comes from `http://www.w3.org/2001/XMLSchema-instance` namespace). With `xml-isogen` you handle it using the `Nillable` type:

263+

264+```haskell

265+"Example5" =:= record ParserAndGenerator

266+ ! "field" [t|Nillable Text|]

267+```

268+

269+If the field contains the value `Nothing`, like this

270+

271+```haskell

272+XmlExample5 { _xe5Field = Nillable Nothing}

273+```

274+

275+then the following XML will be generated:

276+

277+```XML

278+<field

279+ xmlns:ns="http://www.w3.org/2001/XMLSchema-instance"

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

ghc-802.yaml+4

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

1+nix:

2+ packages:

3+ - zlib

15resolver: lts-9.21

37packages:

ghc-822.yaml+4

@@ -1 +1,5 @@

1+nix:

2+ packages:

3+ - zlib

15resolver: lts-11.22

ghc-844.yaml+4

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

1+nix:

2+ packages:

3+ - zlib

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" }:

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/Orphans.hsnew file+11

@@ -0,0 +1,11 @@

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

3+module Data.THGen.Orphans

4+where

6+import Data.Scientific

7+import qualified Data.Text as Text

8+import Text.XML.Writer

10+instance ToXML Scientific where

11+ toXML = content . Text.pack . formatScientific Fixed Nothing

src/Data/THGen/XML.hs+6−3

@@ -22,7 +22,7 @@ wrapper around the field type:

2222

2323Example 1.

2424

25−> "Color" =:= enum Both

25+> "Color" =:= enum ParserAndGenerator

2626> & "R"

2727> & "G"

2828> & "B"

@@ -40,7 +40,7 @@ to be either @R@, @G@ or @B@.

4040

4141Example 2.

4242

43−> "Message" =:= record Both

43+> "Message" =:= record ParserAndGenerator

4444> ! "author"

4545> + "recipient"

4646> ? "message" [t|Text|]

@@ -93,7 +93,7 @@ The type of the field is inferred automatically from its name, so

9393if the field is called @"author"@ its type will be @Author@. You can

9494override the type by specifying it in quasiquotes like so:

9595

96−> "Message" =:= record Both

96+> "Message" =:= record ParserAndGenerator

9797> ! "author" [t|Person|].

9898> ...

9999

@@ -124,9 +124,12 @@ module Data.THGen.XML

124124 , Text

125125 , P.Int

126126 , P.Integer

127+ , Nillable(..)

127128 ) where

128129

129130import Data.THGen.Enum

131+import Data.THGen.Orphans ()

130132import Data.THGen.XML.Internal

131133import Data.Text

134+import Text.XML.Nillable

132135import qualified Prelude as P

src/Data/THGen/XML/Internal.hs+75−53

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

55module Data.THGen.XML.Internal where

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,10 +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 | Both

30+data GenType

31+ = Parser

32+ | Generator

33+ | ParserAndGenerator

34+ | LenientParser

35+ | LenientParserAndGenerator

2836

29−data GenerateLens = Lens | NoLens

37+isLenientType :: GenType -> Bool

38+isLenientType = \case

39+ LenientParser -> True

40+ LenientParserAndGenerator -> True

41+ _ -> False

3042

3143data XmlFieldPlural

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

@@ -57,7 +69,7 @@ data IsoXmlDescRecordPart

5769 | IsoXmlDescRecordAttribute IsoXmlDescAttribute

5870 | IsoXmlDescRecordContent IsoXmlDescContent

5971

60−data IsoXmlDescRecord = IsoXmlDescRecord GenType GenerateLens [IsoXmlDescRecordPart]

72+data IsoXmlDescRecord = IsoXmlDescRecord GenType [IsoXmlDescRecordPart]

6173

6274makePrisms ''IsoXmlDescRecord

6375

@@ -78,34 +90,26 @@ appendField

7890 -> IsoXmlDescRecord

7991 -> IsoXmlDescPreField

8092 -> IsoXmlDescRecord

81−appendField

82− plural

83− (IsoXmlDescRecord genType generateLens fields)

84− (IsoXmlDescPreField name ty) =

85− let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty

86− in IsoXmlDescRecord genType generateLens (xfield:fields)

93+appendField plural (IsoXmlDescRecord genType fields) (IsoXmlDescPreField name ty) =

94+ let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty

95+ in IsoXmlDescRecord genType (xfield:fields)

8796

8897appendAttribute

8998 :: XmlAttributePlural

9099 -> IsoXmlDescRecord

91100 -> IsoXmlDescPreAttribute

92101 -> IsoXmlDescRecord

93−appendAttribute

94− plural

95− (IsoXmlDescRecord genType generateLens fields)

96− (IsoXmlDescPreAttribute name ty) =

97− let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty

98− in IsoXmlDescRecord genType generateLens (xattribute:fields)

102+appendAttribute plural (IsoXmlDescRecord genType fields) (IsoXmlDescPreAttribute name ty) =

103+ let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty

104+ in IsoXmlDescRecord genType (xattribute:fields)

99105

100106appendContent

101107 :: IsoXmlDescRecord

102108 -> IsoXmlDescPreContent

103109 -> IsoXmlDescRecord

104−appendContent

105− (IsoXmlDescRecord genType generateLens fields)

106− (IsoXmlDescPreContent name ty) =

107− let xcontent = IsoXmlDescRecordContent $ IsoXmlDescContent name ty

108− in IsoXmlDescRecord genType generateLens (xcontent:fields)

110+appendContent (IsoXmlDescRecord genType fields) (IsoXmlDescPreContent name ty) =

111+ let xcontent = IsoXmlDescRecordContent $ IsoXmlDescContent name ty

112+ in IsoXmlDescRecord genType (xcontent:fields)

109113

110114(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord

111115(!) = appendField XmlFieldPluralMandatory

@@ -143,11 +147,11 @@ class Description name desc | desc -> name where

143147infix 0 =:=

144148

145149instance Description PrefixName IsoXmlDescRecord where

146− prefixName =:= (IsoXmlDescRecord genType generateLens descRecordParts) =

147− isoXmlGenerateDatatype genType generateLens prefixName (reverse descRecordParts)

150+ prefixName =:= (IsoXmlDescRecord genType descRecordParts) =

151+ isoXmlGenerateDatatype genType prefixName (reverse descRecordParts)

148152

149−record :: GenType -> GenerateLens -> IsoXmlDescRecord

150−record gt gl = IsoXmlDescRecord gt gl []

153+record :: GenType -> IsoXmlDescRecord

154+record gt = IsoXmlDescRecord gt []

151155

152156enum :: GenType -> IsoXmlDescEnum

153157enum gt = IsoXmlDescEnum gt []

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

156160 exhaustivenessName =:= (IsoXmlDescEnum genType descEnumCons) =

157161 isoXmlGenerateEnum genType exhaustivenessName (reverse descEnumCons)

158162

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

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

160164 fromString = IsoXmlDescPreField

161165

162166instance IsString IsoXmlDescPreField where

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

164168 where

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

166170

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

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

168172 fromString = IsoXmlDescPreAttribute

169173

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

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

171175 fromString = IsoXmlDescPreContent

172176

173177instance IsString IsoXmlDescPreAttribute where

@@ -193,7 +197,7 @@ instance IsString ExhaustivenessName where

193197 fromString strName = ExhaustivenessName strName NonExhaustive

194198

195199makeNamePrefix :: String -> String

196−makeNamePrefix = map C.toLower . filter C.isUpper

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

197201

198202funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ

199203funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]

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

221225 (return [])

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

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

224− genFromDomInst = do

228+ genFromDomInst mode = do

225229 TH.instanceD

226230 (return [])

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

228− [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+ ]

229236 genFromAttributeInst = do

230237 TH.instanceD

231238 (return [])

@@ -237,28 +244,30 @@ isoXmlGenerateEnum genType (ExhaustivenessName strName' exh) enumCons = do

237244 toXmlAttributeInst <- genToXmlAttributeInst

238245 return $ enumDecls ++ [toXmlInst, toXmlAttributeInst]

239246 Parser -> do

240− fromDomInst <- genFromDomInst

247+ fromDomInst <- genFromDomInst Strict

248+ fromAttributeInst <- genFromAttributeInst

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

250+ LenientParser -> do

251+ fromDomInst <- genFromDomInst Lenient

241252 fromAttributeInst <- genFromAttributeInst

242253 return $ enumDecls ++ [fromDomInst, fromAttributeInst]

243− Both -> do

254+ ParserAndGenerator -> do

255+ toXmlInst <- genToXmlInst

256+ toXmlAttributeInst <- genToXmlAttributeInst

257+ fromDomInst <- genFromDomInst Strict

258+ fromAttributeInst <- genFromAttributeInst

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

260+ fromDomInst, fromAttributeInst]

261+ LenientParserAndGenerator -> do

244262 toXmlInst <- genToXmlInst

245263 toXmlAttributeInst <- genToXmlAttributeInst

246− fromDomInst <- genFromDomInst

264+ fromDomInst <- genFromDomInst Lenient

247265 fromAttributeInst <- genFromAttributeInst

248266 return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,

249267 fromDomInst, fromAttributeInst]

250268

251−isoXmlGenerateDatatype

252− :: GenType

253− -> GenerateLens

254− -> PrefixName

255− -> [IsoXmlDescRecordPart]

256− -> TH.DecsQ

257−isoXmlGenerateDatatype

258− genType

259− generateLens

260− (PrefixName strName' strPrefix')

261− descRecordParts = do

269+isoXmlGenerateDatatype :: GenType -> PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ

270+isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts = do

262271 let

263272 isNewtype = length descRecordParts == 1

264273 strName = "Xml" ++ strName'

@@ -275,11 +284,14 @@ isoXmlGenerateDatatype

275284 IsoXmlDescField fieldPlural rawName fieldType = descField

276285 fieldStrName = xmlLocalName rawName

277286 fName = TH.mkName (fieldName fieldStrName)

278− fType = case fieldPlural of

287+ fType' = case fieldPlural of

279288 XmlFieldPluralMandatory -> fieldType

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

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

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

292+ fType = if isLenientType genType

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

294+ else fType'

283295 in if isNewtype

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

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

@@ -314,7 +326,7 @@ isoXmlGenerateDatatype

314326 [ ]

315327

316328 let

317− genFromDomInst = do

329+ genFromDomInst mode = do

318330 let

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

320332 exprRecordParts = do

@@ -328,8 +340,9 @@ isoXmlGenerateDatatype

328340 fieldParse = case fieldPlural of

329341 XmlFieldPluralMandatory -> [e|inElem|]

330342 _ -> [e|inElemTrav|]

331− in

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

343+ in case mode of

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

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

333346 IsoXmlDescRecordAttribute descAttribute ->

334347 let

335348 IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute

@@ -415,12 +428,21 @@ isoXmlGenerateDatatype

415428 return $ [termDecl] ++ lensDecls ++

416429 [toXmlInst, toXmlParentAttributesInst, nfDataInst]

417430 Parser -> do

418− fromDomInst <- genFromDomInst

431+ fromDomInst <- genFromDomInst Strict

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

433+ LenientParser -> do

434+ fromDomInst <- genFromDomInst Lenient

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

420− Both -> do

436+ ParserAndGenerator -> do

437+ toXmlInst <- genToXmlInst

438+ toXmlParentAttributesInst <- genToXmlParentAttributeInst

439+ fromDomInst <- genFromDomInst Strict

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

441+ [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]

442+ LenientParserAndGenerator -> do

421443 toXmlInst <- genToXmlInst

422444 toXmlParentAttributesInst <- genToXmlParentAttributeInst

423− fromDomInst <- genFromDomInst

445+ fromDomInst <- genFromDomInst Lenient

424446 return $ [termDecl] ++ lensDecls ++

425447 [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]

426448

src/Text/XML/Nillable.hsnew file+41

@@ -0,0 +1,41 @@

1+{-# LANGUAGE MonoLocalBinds #-}

2+{-# LANGUAGE OverloadedStrings #-}

4+module Text.XML.Nillable where

6+import Control.DeepSeq

7+import Control.Lens

8+import Text.XML.DOM.Parser

9+import Text.XML.ParentAttributes

10+import Text.XML.Writer

11+

12+-- | Type that can have explicit null value

13+--

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

15+newtype Nillable a = Nillable (Maybe a)

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

28+

29+instance ToXmlParentAttributes a => ToXmlParentAttributes (Nillable a) where

30+ toXmlParentAttributes (Nillable Nothing) =

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

32+ toXmlParentAttributes (Nillable (Just a)) = toXmlParentAttributes a

33+

34+instance FromDom a => FromDom (Nillable a) where

35+ fromDom = do

36+ nil <- parseAttributeMaybe

37+ (matchName "{http://www.w3.org/2001/XMLSchema-instance}nil")

38+ Right

39+ case nil of

40+ Just "true" -> return (Nillable Nothing)

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

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

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

1−resolver: lts-10.0

1+nix:

2+ packages:

3+ - zlib

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

test/TestDefs.hs+4−4

@@ -9,11 +9,11 @@ import Data.THGen.XML

99import Test.QuickCheck.Arbitrary.Generic

1010import Test.QuickCheck.Instances ()

1111

12−"Bar" =:= enum Both

12+"Bar" =:= enum ParserAndGenerator

1313 & "baroque"

1414 & "bartender"

1515

16−"Quux" Exhaustive =:= enum Both

16+"Quux" Exhaustive =:= enum ParserAndGenerator

1717 & "ALL"

1818 & "YOUR"

1919 & "BASE"

@@ -22,14 +22,14 @@ import Test.QuickCheck.Instances ()

2222 & "TO"

2323 & "US"

2424

25−"Foo" =:= record Both

25+"Foo" =:= record ParserAndGenerator

2626 ^ "Shmuux" [t|XmlQuux|]

2727 + "Bar"

2828 ? "Baz" [t|Text|]

2929 !% "Quux"

3030 ?% "Muux" [t|XmlQuux|]

3131

32−"Root" =:= record Both

32+"Root" =:= record ParserAndGenerator

3333 ! "{http://example.com/ns/my-namespace}Foo"

3434

3535instance Arbitrary XmlRoot where

xml-isogen.cabal+8−1

@@ -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

@@ -32,7 +32,9 @@ library

3232 , Data.THGen.XML

3333 , Data.THGen.XML.Internal

3434 , Text.XML.ParentAttributes

35+ , Text.XML.Nillable

3536 other-modules: Data.THGen.Compat

37+ , Data.THGen.Orphans

3638 , Text.XML.DOM.Parser.Internal.Content

3739 build-depends: QuickCheck >= 2.8

3840 , base >=4.8 && <5

@@ -40,17 +42,22 @@ library

4042 , deepseq

4143 , lens >= 4.13

4244 , mtl >= 2.2

45+ , scientific

4346 , semigroups >= 0.18

4447 , template-haskell >= 2.10

4548 , text >= 1.2

4649 , xml-conduit >= 1.0

4750 , xml-conduit-writer >= 0.1

4851

52+ ghc-options: -Wall

53+

4954 hs-source-dirs: src

5055

5156 default-language: Haskell2010

5257 default-extensions: CPP

58+ , DeriveTraversable

5359 , FlexibleInstances

60+ , GeneralizedNewtypeDeriving

5461 , LambdaCase

5562 , TemplateHaskell

5663 , TupleSections