b768c73..master · typeable/xml-isogen

git.iko.soy/typeable/xml-isogen

on master help sign in

.gitignore+5

since splitsnapshots

unifiedsplit

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

3.stack-work

4.cabal-sandbox/

5cabal.sandbox.config

6+dist-newstyle/

7+default.nix

8+# vim backup and swap files

9+*~

10+.*.swp

CHANGELOG.md+5

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

1HEAD

2------

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)

40.3.0

90.3.0

5------

10------

README.md+284−1

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

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

7types.

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

1resolver: lts-9.21

5resolver: lts-9.21

3packages:

7packages:

ghc-822.yaml+4

@@ -1 +1,5 @@

1+nix:

2+ packages:

3+ - zlib

1resolver: lts-11.22

5resolver: lts-11.22

ghc-844.yaml+4

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

1+nix:

2+ packages:

3+ - zlib

1resolver: lts-12.16

5resolver: lts-12.16

2extra-deps:

6extra-deps:

3- dom-parser-3.1.0

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

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

23Example 1.

25−> "Color" =:= enum Both

25+> "Color" =:= enum ParserAndGenerator

26> & "R"

27> & "G"

28> & "B"

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

41Example 2.

43−> "Message" =:= record Both Lens

43+> "Message" =:= record ParserAndGenerator

44> ! "author"

45> + "recipient"

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

@@ -78,12 +78,9 @@ the data type to be generated. The prefix for the record fields is

78inferred automatically by taking all of the uppercase letters in the

79name. You can override it manually like so:

81−> "Reference" "ref" =:= record Parser Lens

81+> "Reference" "ref" =:= record Parser

82> ...

84−Second argument to @record@ either enabled lens generation for records fields

85−or disables it for use with DuplicateRecordFields and, possibly, generic-lens.

86−

87To describe a record field you must supply its name as it appears

84To describe a record field you must supply its name as it appears

88in the XML tag, prefixed by its repetition kind:

85in the XML tag, prefixed by its repetition kind:

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

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

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

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

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

99−> "Message" =:= record Both NoLens

96+> "Message" =:= record ParserAndGenerator

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

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

101> ...

98> ...

102

@@ -112,7 +109,6 @@ module Data.THGen.XML

112 , PrefixName(..)

109 , PrefixName(..)

113 , ExhaustivenessName(..)

110 , ExhaustivenessName(..)

114 , GenType(..)

111 , GenType(..)

115− , GenerateLens(..)

116 , record

112 , record

117 , enum

113 , enum

118 , (!)

114 , (!)

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

128 , Text

124 , Text

129 , P.Int

125 , P.Int

130 , P.Integer

126 , P.Integer

127+ , Nillable(..)

131 ) where

128 ) where

132

129

133import Data.THGen.Enum

130import Data.THGen.Enum

131+import Data.THGen.Orphans ()

134import Data.THGen.XML.Internal

132import Data.THGen.XML.Internal

135import Data.Text

133import Data.Text

134+import Text.XML.Nillable

136import qualified Prelude as P

135import qualified Prelude as P

src/Data/THGen/XML/Internal.hs+76−72

@@ -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,26 +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

27−-- | Marks the type of code generation:

28−-- Parser - generate only instances for xml parsing (@FromDom@)

29−-- Generator - generate only @ToXML@ instances

30−-- Both - generate @FromDom@ and @ToXML@ instances

31−data GenType = Parser | Generator | Both

30+data GenType

31+ = Parser

32+ | Generator

33+ | ParserAndGenerator

34+ | LenientParser

35+ | LenientParserAndGenerator

33−{- | Marks the style of code generation regarding records fields

37+isLenientType :: GenType -> Bool

34−@LensRenaming@ - fields get renamed by prefixing the field name with

38+isLenientType = \case

35−'_' and lowercased capital letter used in the type name.

39+ LenientParser -> True

36−e.g. for

40+ LenientParserAndGenerator -> True

37−

41+ _ -> False

38−> "MyNewDataType" =:= record genType LensRenaming

39−> * "field1"

40−

41−field will be renamed to `_mndtField1` and lens `mndtField1` will be created.

42−

43−@NoLens@ - no field renaming and no lens generation.

44−-}

45−data GenerateLens = LensRenaming | NoLens

47data XmlFieldPlural

43data XmlFieldPlural

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

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

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

73 | IsoXmlDescRecordAttribute IsoXmlDescAttribute

69 | IsoXmlDescRecordAttribute IsoXmlDescAttribute

74 | IsoXmlDescRecordContent IsoXmlDescContent

70 | IsoXmlDescRecordContent IsoXmlDescContent

76−data IsoXmlDescRecord = IsoXmlDescRecord GenType GenerateLens [IsoXmlDescRecordPart]

72+data IsoXmlDescRecord = IsoXmlDescRecord GenType [IsoXmlDescRecordPart]

78makePrisms ''IsoXmlDescRecord

74makePrisms ''IsoXmlDescRecord

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

94 -> IsoXmlDescRecord

90 -> IsoXmlDescRecord

95 -> IsoXmlDescPreField

91 -> IsoXmlDescPreField

96 -> IsoXmlDescRecord

92 -> IsoXmlDescRecord

97−appendField

98− plural

99− (IsoXmlDescRecord genType generateLens fields)

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

100− (IsoXmlDescPreField name ty) =

101− let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty

94+ let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty

102− in IsoXmlDescRecord genType generateLens (xfield:fields)

95+ in IsoXmlDescRecord genType (xfield:fields)

103

104appendAttribute

97appendAttribute

105 :: XmlAttributePlural

98 :: XmlAttributePlural

106 -> IsoXmlDescRecord

99 -> IsoXmlDescRecord

107 -> IsoXmlDescPreAttribute

100 -> IsoXmlDescPreAttribute

108 -> IsoXmlDescRecord

101 -> IsoXmlDescRecord

109−appendAttribute

110− plural

111− (IsoXmlDescRecord genType generateLens fields)

112− (IsoXmlDescPreAttribute name ty) =

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

113− let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty

103+ let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty

114− in IsoXmlDescRecord genType generateLens (xattribute:fields)

104+ in IsoXmlDescRecord genType (xattribute:fields)

115

105

116appendContent

106appendContent

117 :: IsoXmlDescRecord

107 :: IsoXmlDescRecord

118 -> IsoXmlDescPreContent

108 -> IsoXmlDescPreContent

119 -> IsoXmlDescRecord

109 -> IsoXmlDescRecord

120−appendContent

121− (IsoXmlDescRecord genType generateLens fields)

122− (IsoXmlDescPreContent name ty) =

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

123− let xcontent = IsoXmlDescRecordContent $ IsoXmlDescContent name ty

111+ let xcontent = IsoXmlDescRecordContent $ IsoXmlDescContent name ty

124− in IsoXmlDescRecord genType generateLens (xcontent:fields)

112+ in IsoXmlDescRecord genType (xcontent:fields)

125

113

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

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

127(!) = appendField XmlFieldPluralMandatory

115(!) = appendField XmlFieldPluralMandatory

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

159infix 0 =:=

147infix 0 =:=

160

148

161instance Description PrefixName IsoXmlDescRecord where

149instance Description PrefixName IsoXmlDescRecord where

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

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

163− isoXmlGenerateDatatype genType generateLens prefixName (reverse descRecordParts)

151+ isoXmlGenerateDatatype genType prefixName (reverse descRecordParts)

164

152

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

153+record :: GenType -> IsoXmlDescRecord

166−record gt gl = IsoXmlDescRecord gt gl []

154+record gt = IsoXmlDescRecord gt []

167

155

168enum :: GenType -> IsoXmlDescEnum

156enum :: GenType -> IsoXmlDescEnum

169enum gt = IsoXmlDescEnum gt []

157enum gt = IsoXmlDescEnum gt []

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

172 exhaustivenessName =:= (IsoXmlDescEnum genType descEnumCons) =

160 exhaustivenessName =:= (IsoXmlDescEnum genType descEnumCons) =

173 isoXmlGenerateEnum genType exhaustivenessName (reverse descEnumCons)

161 isoXmlGenerateEnum genType exhaustivenessName (reverse descEnumCons)

174

162

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

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

176 fromString = IsoXmlDescPreField

164 fromString = IsoXmlDescPreField

177

165

178instance IsString IsoXmlDescPreField where

166instance IsString IsoXmlDescPreField where

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

180 where

168 where

181 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))

182

170

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

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

184 fromString = IsoXmlDescPreAttribute

172 fromString = IsoXmlDescPreAttribute

185

173

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

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

187 fromString = IsoXmlDescPreContent

175 fromString = IsoXmlDescPreContent

188

176

189instance IsString IsoXmlDescPreAttribute where

177instance IsString IsoXmlDescPreAttribute where

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

209 fromString strName = ExhaustivenessName strName NonExhaustive

197 fromString strName = ExhaustivenessName strName NonExhaustive

210

198

211makeNamePrefix :: String -> String

199makeNamePrefix :: String -> String

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

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

213

201

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

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

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

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

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

237 (return [])

225 (return [])

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

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

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

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

240− genFromDomInst = do

228+ genFromDomInst mode = do

241 TH.instanceD

229 TH.instanceD

242 (return [])

230 (return [])

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

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

232+ [case mode of

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

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

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

235+ ]

245 genFromAttributeInst = do

236 genFromAttributeInst = do

246 TH.instanceD

237 TH.instanceD

247 (return [])

238 (return [])

@@ -253,36 +244,36 @@ isoXmlGenerateEnum genType (ExhaustivenessName strName' exh) enumCons = do

253 toXmlAttributeInst <- genToXmlAttributeInst

244 toXmlAttributeInst <- genToXmlAttributeInst

254 return $ enumDecls ++ [toXmlInst, toXmlAttributeInst]

245 return $ enumDecls ++ [toXmlInst, toXmlAttributeInst]

255 Parser -> do

246 Parser -> do

256− fromDomInst <- genFromDomInst

247+ fromDomInst <- genFromDomInst Strict

257 fromAttributeInst <- genFromAttributeInst

248 fromAttributeInst <- genFromAttributeInst

258 return $ enumDecls ++ [fromDomInst, fromAttributeInst]

249 return $ enumDecls ++ [fromDomInst, fromAttributeInst]

259− Both -> do

250+ LenientParser -> do

251+ fromDomInst <- genFromDomInst Lenient

252+ fromAttributeInst <- genFromAttributeInst

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

254+ ParserAndGenerator -> do

260 toXmlInst <- genToXmlInst

255 toXmlInst <- genToXmlInst

261 toXmlAttributeInst <- genToXmlAttributeInst

256 toXmlAttributeInst <- genToXmlAttributeInst

262− 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

263 fromAttributeInst <- genFromAttributeInst

265 fromAttributeInst <- genFromAttributeInst

264 return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,

266 return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,

265 fromDomInst, fromAttributeInst]

267 fromDomInst, fromAttributeInst]

266

268

267−isoXmlGenerateDatatype

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

268− :: GenType

269− -> GenerateLens

270− -> PrefixName

271− -> [IsoXmlDescRecordPart]

272− -> TH.DecsQ

273−isoXmlGenerateDatatype

274− genType

275− generateLens

276− (PrefixName strName' strPrefix')

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

277− descRecordParts = do

278 let

271 let

279 isNewtype = length descRecordParts == 1

272 isNewtype = length descRecordParts == 1

280 strName = "Xml" ++ strName'

273 strName = "Xml" ++ strName'

281 strPrefix = "x" ++ strPrefix'

274 strPrefix = "x" ++ strPrefix'

282 name = TH.mkName strName

275 name = TH.mkName strName

283− fieldName str = case generateLens of

284− LensRenaming -> "_" ++ strPrefix ++ over _head C.toUpper str

276+ fieldName str = "_" ++ strPrefix ++ over _head C.toUpper str

285− NoLens -> str

286 termDecl <- do

277 termDecl <- do

287 let

278 let

288 fields = do

279 fields = do

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

293 IsoXmlDescField fieldPlural rawName fieldType = descField

284 IsoXmlDescField fieldPlural rawName fieldType = descField

294 fieldStrName = xmlLocalName rawName

285 fieldStrName = xmlLocalName rawName

295 fName = TH.mkName (fieldName fieldStrName)

286 fName = TH.mkName (fieldName fieldStrName)

296− fType = case fieldPlural of

287+ fType' = case fieldPlural of

297 XmlFieldPluralMandatory -> fieldType

288 XmlFieldPluralMandatory -> fieldType

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

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

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

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

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

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

292+ fType = if isLenientType genType

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

294+ else fType'

301 in if isNewtype

295 in if isNewtype

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

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

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

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

@@ -332,7 +326,7 @@ isoXmlGenerateDatatype

332 [ ]

326 [ ]

333

327

334 let

328 let

335− genFromDomInst = do

329+ genFromDomInst mode = do

336 let

330 let

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

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

338 exprRecordParts = do

332 exprRecordParts = do

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

346 fieldParse = case fieldPlural of

340 fieldParse = case fieldPlural of

347 XmlFieldPluralMandatory -> [e|inElem|]

341 XmlFieldPluralMandatory -> [e|inElem|]

348 _ -> [e|inElemTrav|]

342 _ -> [e|inElemTrav|]

349− in

343+ in case mode of

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

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

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

351 IsoXmlDescRecordAttribute descAttribute ->

346 IsoXmlDescRecordAttribute descAttribute ->

352 let

347 let

353 IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute

348 IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute

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

433 return $ [termDecl] ++ lensDecls ++

428 return $ [termDecl] ++ lensDecls ++

434 [toXmlInst, toXmlParentAttributesInst, nfDataInst]

429 [toXmlInst, toXmlParentAttributesInst, nfDataInst]

435 Parser -> do

430 Parser -> do

436− fromDomInst <- genFromDomInst

431+ fromDomInst <- genFromDomInst Strict

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

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

438− Both -> do

433+ LenientParser -> do

434+ fromDomInst <- genFromDomInst Lenient

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

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

439 toXmlInst <- genToXmlInst

443 toXmlInst <- genToXmlInst

440 toXmlParentAttributesInst <- genToXmlParentAttributeInst

444 toXmlParentAttributesInst <- genToXmlParentAttributeInst

441− fromDomInst <- genFromDomInst

445+ fromDomInst <- genFromDomInst Lenient

442 return $ [termDecl] ++ lensDecls ++

446 return $ [termDecl] ++ lensDecls ++

443 [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]

447 [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]

444

448

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+nix:

2+ packages:

3+ - zlib

1−resolver: lts-10.0

5+resolver: lts-20.16

2extra-deps:

6extra-deps:

3−- dom-parser-3.0.0

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

4−- generic-arbitrary-0.1.0

8+ commit: 7d556ba528bfa216e99714f8a0d4d00f452803a9

9+ - xml-lens-0.3.1

test/TestDefs.hs+4−4

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

9import Test.QuickCheck.Arbitrary.Generic

10import Test.QuickCheck.Instances ()

12−"Bar" =:= enum Both

12+"Bar" =:= enum ParserAndGenerator

13 & "baroque"

14 & "bartender"

16−"Quux" Exhaustive =:= enum Both

16+"Quux" Exhaustive =:= enum ParserAndGenerator

17 & "ALL"

18 & "YOUR"

19 & "BASE"

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

22 & "TO"

23 & "US"

25−"Foo" =:= record Both NoLens

25+"Foo" =:= record ParserAndGenerator

26 ^ "Shmuux" [t|XmlQuux|]

27 + "Bar"

28 ? "Baz" [t|Text|]

29 !% "Quux"

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

32−"Root" =:= record Both LensRename

32+"Root" =:= record ParserAndGenerator

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

35instance Arbitrary XmlRoot where

xml-isogen.cabal+8−1

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

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

32 , Data.THGen.XML

33 , Data.THGen.XML.Internal

34 , Text.XML.ParentAttributes

35+ , Text.XML.Nillable

35 other-modules: Data.THGen.Compat

36 other-modules: Data.THGen.Compat

37+ , Data.THGen.Orphans

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

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

37 build-depends: QuickCheck >= 2.8

39 build-depends: QuickCheck >= 2.8

38 , base >=4.8 && <5

40 , base >=4.8 && <5

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

40 , deepseq

42 , deepseq

41 , lens >= 4.13

43 , lens >= 4.13

42 , mtl >= 2.2

44 , mtl >= 2.2

45+ , scientific

43 , semigroups >= 0.18

46 , semigroups >= 0.18

44 , template-haskell >= 2.10

47 , template-haskell >= 2.10

45 , text >= 1.2

48 , text >= 1.2

46 , xml-conduit >= 1.0

49 , xml-conduit >= 1.0

47 , xml-conduit-writer >= 0.1

50 , xml-conduit-writer >= 0.1

52+ ghc-options: -Wall

53+

49 hs-source-dirs: src

54 hs-source-dirs: src

51 default-language: Haskell2010

56 default-language: Haskell2010

52 default-extensions: CPP

57 default-extensions: CPP

58+ , DeriveTraversable

53 , FlexibleInstances

59 , FlexibleInstances

60+ , GeneralizedNewtypeDeriving

54 , LambdaCase

61 , LambdaCase

55 , TemplateHaskell

62 , TemplateHaskell

56 , TupleSections

63 , TupleSections