3f22a98...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

.travis.yml+2−1

@@ -5,7 +5,8 @@ language: generic

5env:

6 - STACK_YAML=stack.yaml

7 - STACK_YAML=ghc-802.yaml

8− - STACK_YAML=ghc-821.yaml

8+ - STACK_YAML=ghc-822.yaml

9+ - STACK_YAML=ghc-844.yaml

10cache:

11cache:

11 directories:

12 directories:

CHANGELOG.md+15

@@ -1,3 +1,18 @@

1+HEAD

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)

9+0.3.0

10+------

11+

12+* Add namespaces support

13+* Builds with GHC 8.4

14+* Derive NFData for all generated datatypes

15+

10.2.1

160.2.1

2------

17------

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+5−1

@@ -1,4 +1,8 @@

1+nix:

2+ packages:

3+ - zlib

1−resolver: lts-9.0

5+resolver: lts-9.21

3packages:

7packages:

4- .

8- .

ghc-822.yamlnew file+5

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

1+nix:

2+ packages:

3+ - zlib

5+resolver: lts-11.22

ghc-844.yamlnew file+7

@@ -0,0 +1,7 @@

1+nix:

2+ packages:

3+ - zlib

5+resolver: lts-12.16

6+extra-deps:

7+- dom-parser-3.1.0

releasenew file+35

@@ -0,0 +1,35 @@

1+#!/bin/bash

3+set -o xtrace

5+dist=`stack path --dist-dir --stack-yaml ./stack.yaml 2> /dev/null`

7+echo -e "\033[1;36mTesting library...\033[0m"

8+stack test 2> /dev/null

10+echo -e "\033[1;36mRunning sdist...\033[0m"

11+cabal sdist

12+

13+echo -e "\033[1;36mGenerating documentation...\033[0m"

14+stack haddock 2> /dev/null

15+

16+if [ "$?" -eq "0" ]; then

17+ echo -e "\033[1;32mUploading package to Hackage...\033[0m"

18+ read -p "Hackage username: " username

19+ read -p "Hackage password: " -s password

20+ echo ""

21+ cabal upload -u $username -p $password dist/$1-$2.tar.gz

22+

23+ docdir=$dist/doc/html

24+ cd $docdir

25+ doc=$1-$2-docs

26+

27+ echo -e "Compressing documentation from \033[1;34m$docdir\033[0m for \033[1;35m$1\033[0m-\033[1;33m$2\033[1;30m"

28+ cp -r $1 $doc

29+ tar -c -v -z --format=ustar -f $doc.tar.gz $doc

30+ echo -e "\033[1;32mUploading documentation to Hackage...\033[0m"

31+ curl -X PUT -H 'Content-Type: application/x-tar' -H 'Content-Encoding: gzip' --data-binary "@$doc.tar.gz" "https://$username:$password@hackage.haskell.org/package/$1-$2/docs"

32+ exit $?

33+else

34+ echo -e "\033[1;31mNot in a stack-powered project\033[0m"

35+fi

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/Compat.hs+23

@@ -2,6 +2,8 @@

3module Data.THGen.Compat

4 ( dataD

5+ , newtypeD

6+ , nonStrictType

5 , strictType

7 , strictType

6 , varStrictType

8 , varStrictType

7 ) where

9 ) where

@@ -21,6 +23,27 @@ dataD name cons derivs = TH.dataD (return []) name [] Nothing cons derivCls

21dataD name = TH.dataD (return []) name []

23dataD name = TH.dataD (return []) name []

22#endif

24#endif

26+newtypeD :: TH.Name -> TH.ConQ -> [TH.Name] -> TH.DecQ

27+#if MIN_VERSION_template_haskell(2,12,0)

28+newtypeD name cons derivs = TH.newtypeD (return []) name [] Nothing cons [derivCls]

29+ where

30+ derivCls = TH.derivClause Nothing $ fmap TH.conT derivs

31+#elif MIN_VERSION_template_haskell(2,11,0)

32+newtypeD name cons derivs = TH.newtypeD (return []) name [] Nothing cons derivCls

33+ where

34+ derivCls = traverse TH.conT derivs

35+#else

36+newtypeD name = TH.newtypeD (return []) name []

37+#endif

38+

39+#if MIN_VERSION_template_haskell(2,11,0)

40+nonStrictType :: TH.TypeQ -> TH.BangTypeQ

41+nonStrictType = TH.bangType (TH.bang TH.noSourceUnpackedness TH.noSourceStrictness)

42+#else

43+nonStrictType :: TH.TypeQ -> TH.StrictTypeQ

44+nonStrictType = TH.strictType TH.notStrict

45+#endif

46+

24#if MIN_VERSION_template_haskell(2,11,0)

47#if MIN_VERSION_template_haskell(2,11,0)

25strictType :: TH.TypeQ -> TH.BangTypeQ

48strictType :: TH.TypeQ -> TH.BangTypeQ

26strictType = TH.bangType (TH.bang TH.noSourceUnpackedness TH.sourceStrict)

49strictType = TH.bangType (TH.bang TH.noSourceUnpackedness TH.sourceStrict)

src/Data/THGen/Enum.hs+10−2

@@ -25,14 +25,17 @@ module Data.THGen.Enum

25 ) where

27import Control.Applicative

28+import Control.DeepSeq

28import Control.Lens (over, _head, (<&>))

29import Control.Lens (over, _head, (<&>))

29import Control.Monad

30import Control.Monad

30import qualified Data.Char as C

31import qualified Data.Char as C

31import Data.THGen.Compat

32import Data.THGen.Compat

33+import GHC.Generics (Generic)

32import qualified Language.Haskell.TH as TH

34import qualified Language.Haskell.TH as TH

33import qualified Test.QuickCheck as QC

35import qualified Test.QuickCheck as QC

34import qualified Text.Read as R

36import qualified Text.Read as R

38+

36data Exhaustiveness = Exhaustive | NonExhaustive

39data Exhaustiveness = Exhaustive | NonExhaustive

37 deriving (Eq, Ord, Show)

40 deriving (Eq, Ord, Show)

@@ -79,7 +82,7 @@ enumGenerate (EnumDesc exh strName strVals) = do

79 dataD

82 dataD

80 name

83 name

81 (constrs ++ unknownConstr)

84 (constrs ++ unknownConstr)

82− ([''Eq, ''Ord] ++ if (exh == Exhaustive) then [''Enum, ''Bounded] else [])

85+ ([''Eq, ''Ord, ''Generic] ++ if (exh == Exhaustive) then [''Enum, ''Bounded] else [])

83 showInstDecl <- do

86 showInstDecl <- do

84 unknownMatch <- case exh of

87 unknownMatch <- case exh of

85 Exhaustive -> return []

88 Exhaustive -> return []

@@ -126,4 +129,9 @@ enumGenerate (EnumDesc exh strName strVals) = do

126 (return [])

129 (return [])

127 [t|QC.Arbitrary $(TH.conT name)|]

130 [t|QC.Arbitrary $(TH.conT name)|]

128 [funSimple 'QC.arbitrary arbExpr]

131 [funSimple 'QC.arbitrary arbExpr]

132+ nfDataInst <- do

133+ TH.instanceD

134+ (return [])

135+ [t|NFData $(TH.conT name)|]

136+ []

129− return [dataDecl, readInstDecl, showInstDecl, arbInstance]

137+ return [dataDecl, readInstDecl, showInstDecl, arbInstance, nfDataInst]

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+23−327

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

1−{-# LANGUAGE UndecidableInstances #-}

1+{-# LANGUAGE NoImplicitPrelude #-}

2−{-# LANGUAGE FunctionalDependencies #-}

4{- |

3{- |

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

24Example 1.

23Example 1.

26−> "Color" =:= enum

25+> "Color" =:= enum ParserAndGenerator

27> & "R"

26> & "R"

28> & "G"

27> & "G"

29> & "B"

28> & "B"

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

42Example 2.

41Example 2.

44−> "Message" =:= record

43+> "Message" =:= record ParserAndGenerator

45> ! "author"

44> ! "author"

46> + "recipient"

45> + "recipient"

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

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

@@ -68,10 +67,10 @@ enumeration is exhaustive (contains only the listed constructors) or

68non-exhaustive (also contains a constructor for unknown values; this

67non-exhaustive (also contains a constructor for unknown values; this

69is the default):

68is the default):

71−> "Enum1" Exhaustive =:= enum

70+> "Enum1" Exhaustive =:= enum Generator

72> ...

71> ...

74−> "Enum2" NonExhaustive =:= enum

73+> "Enum2" NonExhaustive =:= enum Generator

75> ...

74> ...

77To define a record, use the `record` function followed by the name of

76To define a record, use the `record` function followed by the name of

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

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

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

80name. You can override it manually like so:

79name. You can override it manually like so:

82−> "Reference" "ref" =:= record

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

83> ...

82> ...

85To 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

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

94if 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

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

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

97−> "Message" =:= record

96+> "Message" =:= record ParserAndGenerator

98−> ! "author" [t|Person|]

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

99> ...

98> ...

100

100+Both @record@ and @enum@ take a @GenType@ argument which tells it to generate

101+generator, parser or both. It's being used to optimize compilation time by

102+skipping the unnecessary TH instance generation.

103+

101-}

104-}

102

105

103

106

@@ -105,6 +108,7 @@ module Data.THGen.XML

105 ( Exhaustiveness(..)

108 ( Exhaustiveness(..)

106 , PrefixName(..)

109 , PrefixName(..)

107 , ExhaustivenessName(..)

110 , ExhaustivenessName(..)

111+ , GenType(..)

108 , record

112 , record

109 , enum

113 , enum

110 , (!)

114 , (!)

@@ -114,326 +118,18 @@ module Data.THGen.XML

114 , (!%)

118 , (!%)

115 , (?%)

119 , (?%)

116 , (&)

120 , (&)

121+ , (^)

117 , (=:=)

122 , (=:=)

118 -- Re-exports

123 -- Re-exports

119− , T.Text

124+ , Text

120− , Int

125+ , P.Int

121− , Integer

126+ , P.Integer

127+ , Nillable(..)

122 ) where

128 ) where

123

129

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

125−import Control.Lens.Internal.FieldTH (makeFieldOpticsForDec)

126−import qualified Data.Char as C

127−import Data.List.NonEmpty (NonEmpty)

128−import Data.Maybe (maybeToList, mapMaybe)

129−import Data.String

130−import Data.THGen.Compat

131import Data.THGen.Enum

130import Data.THGen.Enum

132−import qualified Data.Text as T

131+import Data.THGen.Orphans ()

133−import qualified Language.Haskell.TH as TH

132+import Data.THGen.XML.Internal

134−import Prelude hiding ((+), (*))

133+import Data.Text

135−import Text.XML.DOM.Parser

134+import Text.XML.Nillable

136−import Text.XML.ParentAttributes

135+import qualified Prelude as P

137−import qualified Text.XML.Writer as XW

138−import qualified Text.XML as X

139−

140−data XmlFieldPlural

141− = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)

142− | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)

143− | XmlFieldPluralRepeated -- Occurs 0 or more times (List)

144− | XmlFieldPluralMultiplied -- Occurs 1 or more times (NonEmpty)

145−

146−data XmlAttributePlural

147− = XmlAttributePluralMandatory -- Occurs exactly 1 time (Identity)

148− | XmlAttributePluralOptional -- Occurs 0 or 1 times (Maybe)

149−

150−data PrefixName = PrefixName String String

151−

152−data IsoXmlDescPreField = IsoXmlDescPreField String TH.TypeQ

153−

154−data IsoXmlDescPreAttribute = IsoXmlDescPreAttribute String TH.TypeQ

155−

156−data IsoXmlDescField = IsoXmlDescField XmlFieldPlural String TH.TypeQ

157−

158−data IsoXmlDescAttribute = IsoXmlDescAttribute XmlAttributePlural String TH.TypeQ

159−

160−data IsoXmlDescRecordPart

161− = IsoXmlDescRecordField IsoXmlDescField

162− | IsoXmlDescRecordAttribute IsoXmlDescAttribute

163−

164−newtype IsoXmlDescRecord = IsoXmlDescRecord [IsoXmlDescRecordPart]

165−

166−makePrisms ''IsoXmlDescRecord

167−

168−data ExhaustivenessName = ExhaustivenessName String Exhaustiveness

169−

170−newtype IsoXmlDescEnumCon

171− = IsoXmlDescEnumCon { unIsoXmlDescEnumCon :: String }

172−

173−instance IsString IsoXmlDescEnumCon where

174− fromString = IsoXmlDescEnumCon

175−

176−data IsoXmlDescEnum = IsoXmlDescEnum [IsoXmlDescEnumCon]

177−

178−makePrisms ''IsoXmlDescEnum

179−

180−appendField

181− :: XmlFieldPlural

182− -> IsoXmlDescRecord

183− -> IsoXmlDescPreField

184− -> IsoXmlDescRecord

185−appendField plural xrec (IsoXmlDescPreField name ty) =

186− let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty

187− in over _IsoXmlDescRecord (xfield:) xrec

188−

189−appendAttribute

190− :: XmlAttributePlural

191− -> IsoXmlDescRecord

192− -> IsoXmlDescPreAttribute

193− -> IsoXmlDescRecord

194−appendAttribute plural xrec (IsoXmlDescPreAttribute name ty) =

195− let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty

196− in over _IsoXmlDescRecord (xattribute:) xrec

197−

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

199−(!) = appendField XmlFieldPluralMandatory

200−(?) = appendField XmlFieldPluralOptional

201−(*) = appendField XmlFieldPluralRepeated

202−(+) = appendField XmlFieldPluralMultiplied

203−

204−(!%), (?%) :: IsoXmlDescRecord -> IsoXmlDescPreAttribute -> IsoXmlDescRecord

205−(!%) = appendAttribute XmlAttributePluralMandatory

206−(?%) = appendAttribute XmlAttributePluralOptional

207−

208−infixl 2 !

209−infixl 2 ?

210−infixl 2 *

211−infixl 2 +

212−infixl 2 !%

213−infixl 2 ?%

214−

215−appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum

216−appendEnumCon xenum xenumcon =

217− over _IsoXmlDescEnum (xenumcon:) xenum

218−

219−(&) :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum

220−(&) = appendEnumCon

221−

222−infixl 2 &

223−

224−class Description name desc | desc -> name where

225− (=:=) :: name -> desc -> TH.DecsQ

226−

227−infix 0 =:=

228−

229−instance Description PrefixName IsoXmlDescRecord where

230− prefixName =:= descRecord =

231− let descRecordParts = descRecord ^. _IsoXmlDescRecord

232− in isoXmlGenerateRecord prefixName (reverse descRecordParts)

233−

234−record :: IsoXmlDescRecord

235−record = IsoXmlDescRecord []

236−

237−enum :: IsoXmlDescEnum

238−enum = IsoXmlDescEnum []

239−

240−instance Description ExhaustivenessName IsoXmlDescEnum where

241− exhaustivenessName =:= descEnum =

242− let descEnumCons = descEnum ^. _IsoXmlDescEnum

243− in isoXmlGenerateEnum exhaustivenessName (reverse descEnumCons)

244−

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

246− fromString = IsoXmlDescPreField

247−

248−instance IsString IsoXmlDescPreField where

249− fromString name = IsoXmlDescPreField name ty

250− where

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

252−

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

254− fromString = IsoXmlDescPreAttribute

255−

256−instance IsString IsoXmlDescPreAttribute where

257− fromString name = IsoXmlDescPreAttribute name ty

258− where

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

260−

261−instance s ~ String => IsString (s -> PrefixName) where

262− fromString = PrefixName

263−

264−instance IsString PrefixName where

265− fromString strName = PrefixName strName (makeNamePrefix strName)

266−

267−instance e ~ Exhaustiveness => IsString (e -> ExhaustivenessName) where

268− fromString = ExhaustivenessName

269−

270−instance IsString ExhaustivenessName where

271− fromString strName = ExhaustivenessName strName NonExhaustive

272−

273−makeNamePrefix :: String -> String

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

275−

276−funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ

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

278−

279−isoXmlGenerateEnum

280− :: ExhaustivenessName -> [IsoXmlDescEnumCon] -> TH.DecsQ

281−isoXmlGenerateEnum (ExhaustivenessName strName' exh) enumCons = do

282− let

283− strName = "Xml" ++ strName'

284− strVals = map unIsoXmlDescEnumCon enumCons

285− enumDesc = EnumDesc exh strName strVals

286− name = TH.mkName strName

287− enumDecls <- enumGenerate enumDesc

288− toXmlInst <- do

289− TH.instanceD

290− (return [])

291− [t|XW.ToXML $(TH.conT name)|]

292− [funSimple 'XW.toXML [e|XW.toXML . T.pack . show|]]

293− toXmlAttributeInst <- do

294− TH.instanceD

295− (return [])

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

297− [funSimple 'toXmlAttribute [e|T.pack . show|]]

298− fromDomInst <- do

299− TH.instanceD

300− (return [])

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

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

303− fromAttributeInst <- do

304− TH.instanceD

305− (return [])

306− [t|FromAttribute $(TH.conT name)|]

307− [funSimple 'fromAttribute [e|readContent|]]

308− return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,

309− fromDomInst, fromAttributeInst]

310−

311−isoXmlGenerateRecord :: PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ

312−isoXmlGenerateRecord (PrefixName strName' strPrefix') descRecordParts = do

313− let

314− strName = "Xml" ++ strName'

315− strPrefix = "x" ++ strPrefix'

316− name = TH.mkName strName

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

318− dataDecl <- do

319− let

320− fields = do

321− descRecordPart <- descRecordParts

322− return $ case descRecordPart of

323− IsoXmlDescRecordField descField ->

324− let

325− IsoXmlDescField fieldPlural fieldStrName fieldType = descField

326− fName = TH.mkName (fieldName fieldStrName)

327− fType = case fieldPlural of

328− XmlFieldPluralMandatory -> fieldType

329− XmlFieldPluralOptional -> [t| Maybe $fieldType |]

330− XmlFieldPluralRepeated -> [t| [$fieldType] |]

331− XmlFieldPluralMultiplied -> [t| NonEmpty $fieldType |]

332− in

333− varStrictType fName (strictType fType)

334− IsoXmlDescRecordAttribute descAttribute ->

335− let

336− IsoXmlDescAttribute

337− attributePlural attributeStrName attributeType = descAttribute

338− fName = TH.mkName (fieldName attributeStrName)

339− fType = case attributePlural of

340− XmlAttributePluralMandatory -> attributeType

341− XmlAttributePluralOptional -> [t| Maybe $attributeType |]

342− in

343− varStrictType fName (strictType fType)

344− dataD

345− name

346− [TH.recC name fields]

347− [''Eq, ''Show]

348− lensDecls <- makeFieldOpticsForDec lensRules dataDecl

349− fromDomInst <- do

350− let

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

352− exprRecordParts = do

353− descRecordPart <- descRecordParts

354− return $ case descRecordPart of

355− IsoXmlDescRecordField descField ->

356− let

357− IsoXmlDescField fieldPlural fieldStrName _ = descField

358− exprFieldStrName = TH.litE (TH.stringL fieldStrName)

359− fieldParse = case fieldPlural of

360− XmlFieldPluralMandatory -> [e|inElem|]

361− _ -> [e|inElemTrav|]

362− in

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

364− IsoXmlDescRecordAttribute descAttribute ->

365− let

366− IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute

367− exprAttributeStrName = TH.litE (TH.stringL attributeStrName)

368− attributeParse = case attributePlural of

369− XmlAttributePluralMandatory -> [e|parseAttribute|]

370− XmlAttributePluralOptional -> [e|parseAttributeMaybe|]

371− in

372− [e|$attributeParse $exprAttributeStrName fromAttribute|]

373− fromDomExpr = foldl (\e fe -> [e| $e <*> $fe |]) exprHeader exprRecordParts

374− TH.instanceD

375− (return [])

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

377− [ funSimple 'fromDom fromDomExpr ]

378−

379− toXmlInst <- do

380− objName <- TH.newName strPrefix

381− let

382− exprFields = do

383− descRecordPart <- descRecordParts

384− IsoXmlDescField fieldPlural fieldStrName _ <-

385− maybeToList $ case descRecordPart of

386− IsoXmlDescRecordField descField -> Just descField

387− _ -> Nothing

388− let

389− fName = TH.mkName (fieldName fieldStrName)

390− exprFieldStrName = TH.litE (TH.stringL fieldStrName)

391− exprForField = case fieldPlural of

392− XmlFieldPluralMandatory -> [e|id|]

393− _ -> [e|traverse|]

394− exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]

395− exprFieldRender =

396− [e|(\a -> XW.elementA $exprFieldStrName (toXmlParentAttributes a) a)|]

397− return [e|$exprForField $exprFieldRender $exprFieldValue|]

398− toXmlExpr

399− = TH.lamE [if null exprFields then TH.wildP else TH.varP objName]

400− $ foldr (\fe e -> [e|$fe *> $e|]) [e|return ()|] exprFields

401− TH.instanceD

402− (return [])

403− [t|XW.ToXML $(TH.conT name)|]

404− [funSimple 'XW.toXML toXmlExpr]

405−

406− toXmlParentAttributesInst <- do

407− objName <- TH.newName strPrefix

408− let

409− exprAttributes = do

410− descRecordPart <- descRecordParts

411− IsoXmlDescAttribute attributePlural attributeStrName _ <-

412− maybeToList $ case descRecordPart of

413− IsoXmlDescRecordAttribute descAttribute -> Just descAttribute

414− _ -> Nothing

415− let

416− fName = TH.mkName (fieldName attributeStrName)

417− exprAttrStrName = TH.litE (TH.stringL attributeStrName)

418− exprAttrValue = [e|$(TH.varE fName) $(TH.varE objName)|]

419− exprAttrWrap = case attributePlural of

420− XmlAttributePluralMandatory -> [e|Just . toXmlAttribute|]

421− XmlAttributePluralOptional -> [e|fmap toXmlAttribute|]

422− return [e|($exprAttrStrName, $exprAttrWrap $exprAttrValue)|]

423− toXmlParentAttributesExpr

424− = TH.lamE [if null exprAttributes then TH.wildP else TH.varP objName]

425− $ [e|mapMaybe distribPair $(TH.listE exprAttributes)|]

426−#if __GLASGOW_HASKELL__ < 800

427− TH.instanceD

428−#else

429− TH.instanceWithOverlapD (Just TH.Overlapping)

430−#endif

431− (return [])

432− [t|ToXmlParentAttributes $(TH.conT name)|]

433− [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]

434−

435− return $ [dataDecl] ++ lensDecls ++

436− [fromDomInst, toXmlInst, toXmlParentAttributesInst]

437−

438−distribPair :: Functor f => (a, f b) -> f (a, b)

439−distribPair (a, fb) = (a,) <$> fb

src/Data/THGen/XML/Internal.hsnew file+457

@@ -0,0 +1,457 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE UndecidableInstances #-}

3+{-# LANGUAGE FunctionalDependencies #-}

5+module Data.THGen.XML.Internal where

7+import Control.DeepSeq

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

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

10+import qualified Data.Char as C

11+import Data.List.NonEmpty (NonEmpty)

12+import Data.Maybe (maybeToList, mapMaybe)

13+import Data.String

14+import Data.THGen.Compat as THC

15+import Data.THGen.Enum

16+import qualified Data.Text as T

17+import GHC.Generics (Generic)

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

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

20+import qualified Text.XML as X

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

22+import Text.XML.DOM.Parser.Internal.Content

23+import Text.XML.ParentAttributes

24+import qualified Text.XML.Writer as XW

25+

26+data ParserMode

27+ = Strict

28+ | Lenient

29+

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

42+

43+data XmlFieldPlural

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

45+ | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)

46+ | XmlFieldPluralRepeated -- Occurs 0 or more times (List)

47+ | XmlFieldPluralMultiplied -- Occurs 1 or more times (NonEmpty)

48+

49+data XmlAttributePlural

50+ = XmlAttributePluralMandatory -- Occurs exactly 1 time (Identity)

51+ | XmlAttributePluralOptional -- Occurs 0 or 1 times (Maybe)

52+

53+data PrefixName = PrefixName String String

54+

55+data IsoXmlDescPreField = IsoXmlDescPreField String TH.TypeQ

56+

57+data IsoXmlDescPreAttribute = IsoXmlDescPreAttribute String TH.TypeQ

58+

59+data IsoXmlDescPreContent = IsoXmlDescPreContent String TH.TypeQ

60+

61+data IsoXmlDescField = IsoXmlDescField XmlFieldPlural String TH.TypeQ

62+

63+data IsoXmlDescAttribute = IsoXmlDescAttribute XmlAttributePlural String TH.TypeQ

64+

65+data IsoXmlDescContent = IsoXmlDescContent String TH.TypeQ

66+

67+data IsoXmlDescRecordPart

68+ = IsoXmlDescRecordField IsoXmlDescField

69+ | IsoXmlDescRecordAttribute IsoXmlDescAttribute

70+ | IsoXmlDescRecordContent IsoXmlDescContent

71+

72+data IsoXmlDescRecord = IsoXmlDescRecord GenType [IsoXmlDescRecordPart]

73+

74+makePrisms ''IsoXmlDescRecord

75+

76+data ExhaustivenessName = ExhaustivenessName String Exhaustiveness

77+

78+newtype IsoXmlDescEnumCon

79+ = IsoXmlDescEnumCon { unIsoXmlDescEnumCon :: String }

80+

81+instance IsString IsoXmlDescEnumCon where

82+ fromString = IsoXmlDescEnumCon

83+

84+data IsoXmlDescEnum = IsoXmlDescEnum GenType [IsoXmlDescEnumCon]

85+

86+makePrisms ''IsoXmlDescEnum

87+

88+appendField

89+ :: XmlFieldPlural

90+ -> IsoXmlDescRecord

91+ -> IsoXmlDescPreField

92+ -> IsoXmlDescRecord

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

94+ let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty

95+ in IsoXmlDescRecord genType (xfield:fields)

96+

97+appendAttribute

98+ :: XmlAttributePlural

99+ -> IsoXmlDescRecord

100+ -> IsoXmlDescPreAttribute

101+ -> IsoXmlDescRecord

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

103+ let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty

104+ in IsoXmlDescRecord genType (xattribute:fields)

105+

106+appendContent

107+ :: IsoXmlDescRecord

108+ -> IsoXmlDescPreContent

109+ -> IsoXmlDescRecord

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

111+ let xcontent = IsoXmlDescRecordContent $ IsoXmlDescContent name ty

112+ in IsoXmlDescRecord genType (xcontent:fields)

113+

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

115+(!) = appendField XmlFieldPluralMandatory

116+(?) = appendField XmlFieldPluralOptional

117+(*) = appendField XmlFieldPluralRepeated

118+(+) = appendField XmlFieldPluralMultiplied

119+

120+(!%), (?%) :: IsoXmlDescRecord -> IsoXmlDescPreAttribute -> IsoXmlDescRecord

121+(!%) = appendAttribute XmlAttributePluralMandatory

122+(?%) = appendAttribute XmlAttributePluralOptional

123+

124+(^) :: IsoXmlDescRecord -> IsoXmlDescPreContent -> IsoXmlDescRecord

125+(^) = appendContent

126+

127+infixl 2 !

128+infixl 2 ?

129+infixl 2 *

130+infixl 2 +

131+infixl 2 !%

132+infixl 2 ?%

133+infixl 2 ^

134+

135+appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum

136+appendEnumCon (IsoXmlDescEnum genType enumCons) xenumcon =

137+ IsoXmlDescEnum genType (xenumcon:enumCons)

138+

139+(&) :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum

140+(&) = appendEnumCon

141+

142+infixl 2 &

143+

144+class Description name desc | desc -> name where

145+ (=:=) :: name -> desc -> TH.DecsQ

146+

147+infix 0 =:=

148+

149+instance Description PrefixName IsoXmlDescRecord where

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

151+ isoXmlGenerateDatatype genType prefixName (reverse descRecordParts)

152+

153+record :: GenType -> IsoXmlDescRecord

154+record gt = IsoXmlDescRecord gt []

155+

156+enum :: GenType -> IsoXmlDescEnum

157+enum gt = IsoXmlDescEnum gt []

158+

159+instance Description ExhaustivenessName IsoXmlDescEnum where

160+ exhaustivenessName =:= (IsoXmlDescEnum genType descEnumCons) =

161+ isoXmlGenerateEnum genType exhaustivenessName (reverse descEnumCons)

162+

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

164+ fromString = IsoXmlDescPreField

165+

166+instance IsString IsoXmlDescPreField where

167+ fromString name = IsoXmlDescPreField name ty

168+ where

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

170+

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

172+ fromString = IsoXmlDescPreAttribute

173+

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

175+ fromString = IsoXmlDescPreContent

176+

177+instance IsString IsoXmlDescPreAttribute where

178+ fromString name = IsoXmlDescPreAttribute name ty

179+ where

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

181+

182+instance IsString IsoXmlDescPreContent where

183+ fromString name = IsoXmlDescPreContent name ty

184+ where

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

186+

187+instance s ~ String => IsString (s -> PrefixName) where

188+ fromString = PrefixName

189+

190+instance IsString PrefixName where

191+ fromString strName = PrefixName strName (makeNamePrefix strName)

192+

193+instance e ~ Exhaustiveness => IsString (e -> ExhaustivenessName) where

194+ fromString = ExhaustivenessName

195+

196+instance IsString ExhaustivenessName where

197+ fromString strName = ExhaustivenessName strName NonExhaustive

198+

199+makeNamePrefix :: String -> String

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

201+

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

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

204+

205+isoXmlGenerateEnum

206+ :: GenType

207+ -> ExhaustivenessName

208+ -> [IsoXmlDescEnumCon]

209+ -> TH.DecsQ

210+isoXmlGenerateEnum genType (ExhaustivenessName strName' exh) enumCons = do

211+ let

212+ strName = "Xml" ++ strName'

213+ strVals = map unIsoXmlDescEnumCon enumCons

214+ enumDesc = EnumDesc exh strName strVals

215+ name = TH.mkName strName

216+ enumDecls <- enumGenerate enumDesc

217+ let

218+ genToXmlInst = do

219+ TH.instanceD

220+ (return [])

221+ [t|XW.ToXML $(TH.conT name)|]

222+ [funSimple 'XW.toXML [e|XW.toXML . T.pack . show|]]

223+ genToXmlAttributeInst = do

224+ TH.instanceD

225+ (return [])

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

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

228+ genFromDomInst mode = do

229+ TH.instanceD

230+ (return [])

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

232+ [case mode of

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

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

235+ ]

236+ genFromAttributeInst = do

237+ TH.instanceD

238+ (return [])

239+ [t|FromAttribute $(TH.conT name)|]

240+ [funSimple 'fromAttribute [e|readContent|]]

241+ case genType of

242+ Generator -> do

243+ toXmlInst <- genToXmlInst

244+ toXmlAttributeInst <- genToXmlAttributeInst

245+ return $ enumDecls ++ [toXmlInst, toXmlAttributeInst]

246+ Parser -> do

247+ fromDomInst <- genFromDomInst Strict

248+ fromAttributeInst <- genFromAttributeInst

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

250+ LenientParser -> do

251+ fromDomInst <- genFromDomInst Lenient

252+ fromAttributeInst <- genFromAttributeInst

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

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

262+ toXmlInst <- genToXmlInst

263+ toXmlAttributeInst <- genToXmlAttributeInst

264+ fromDomInst <- genFromDomInst Lenient

265+ fromAttributeInst <- genFromAttributeInst

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

267+ fromDomInst, fromAttributeInst]

268+

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

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

271+ let

272+ isNewtype = length descRecordParts == 1

273+ strName = "Xml" ++ strName'

274+ strPrefix = "x" ++ strPrefix'

275+ name = TH.mkName strName

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

277+ termDecl <- do

278+ let

279+ fields = do

280+ descRecordPart <- descRecordParts

281+ return $ case descRecordPart of

282+ IsoXmlDescRecordField descField ->

283+ let

284+ IsoXmlDescField fieldPlural rawName fieldType = descField

285+ fieldStrName = xmlLocalName rawName

286+ fName = TH.mkName (fieldName fieldStrName)

287+ fType' = case fieldPlural of

288+ XmlFieldPluralMandatory -> fieldType

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

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

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

292+ fType = if isLenientType genType

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

294+ else fType'

295+ in if isNewtype

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

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

298+ IsoXmlDescRecordAttribute descAttribute ->

299+ let

300+ IsoXmlDescAttribute

301+ attributePlural attributeStrName attributeType = descAttribute

302+ fName = TH.mkName (fieldName attributeStrName)

303+ fType = case attributePlural of

304+ XmlAttributePluralMandatory -> attributeType

305+ XmlAttributePluralOptional -> [t| Maybe $attributeType |]

306+ in if isNewtype

307+ then THC.varStrictType fName (THC.nonStrictType fType)

308+ else THC.varStrictType fName (THC.strictType fType)

309+ IsoXmlDescRecordContent descContent ->

310+ let

311+ IsoXmlDescContent contentStrName contentType = descContent

312+ fName = TH.mkName (fieldName contentStrName)

313+ fType = contentType

314+ in if isNewtype

315+ then THC.varStrictType fName (THC.nonStrictType fType)

316+ else THC.varStrictType fName (THC.strictType fType)

317+ if isNewtype

318+ -- generate a newtype instead to do less allocations later

319+ then THC.newtypeD name (TH.recC name fields) [''Eq, ''Show, ''Generic]

320+ else THC.dataD name [TH.recC name fields] [''Eq, ''Show, ''Generic]

321+ lensDecls <- makeFieldOpticsForDec lensRules termDecl

322+ nfDataInst <- do

323+ TH.instanceD

324+ (return [])

325+ [t|NFData $(TH.conT name)|]

326+ [ ]

327+

328+ let

329+ genFromDomInst mode = do

330+ let

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

332+ exprRecordParts = do

333+ descRecordPart <- descRecordParts

334+ return $ case descRecordPart of

335+ IsoXmlDescRecordField descField ->

336+ let

337+ IsoXmlDescField fieldPlural rawName _ = descField

338+ fieldStrName = xmlLocalName rawName

339+ exprFieldStrName = TH.litE (TH.stringL fieldStrName)

340+ fieldParse = case fieldPlural of

341+ XmlFieldPluralMandatory -> [e|inElem|]

342+ _ -> [e|inElemTrav|]

343+ in case mode of

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

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

346+ IsoXmlDescRecordAttribute descAttribute ->

347+ let

348+ IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute

349+ exprAttributeStrName = TH.litE (TH.stringL attributeStrName)

350+ attributeParse = case attributePlural of

351+ XmlAttributePluralMandatory -> [e|parseAttribute|]

352+ XmlAttributePluralOptional -> [e|parseAttributeMaybe|]

353+ in

354+ [e|$attributeParse $exprAttributeStrName fromAttribute|]

355+ IsoXmlDescRecordContent _ -> [e|parseContent fromAttribute|]

356+ fromDomExpr = foldl (\e fe -> [e| $e <*> $fe |]) exprHeader exprRecordParts

357+ TH.instanceD

358+ (return [])

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

360+ [ funSimple 'fromDom fromDomExpr ]

361+

362+ genToXmlInst = do

363+ objName <- TH.newName strPrefix

364+ let

365+ exprFields = do

366+ descRecordPart <- descRecordParts

367+ case descRecordPart of

368+ IsoXmlDescRecordField (IsoXmlDescField fieldPlural rawName _) -> do

369+ let

370+ fieldStrName = xmlLocalName rawName

371+ fName = TH.mkName (fieldName fieldStrName)

372+ exprFieldStrName = TH.litE (TH.stringL rawName)

373+ exprForField = case fieldPlural of

374+ XmlFieldPluralMandatory -> [e|id|]

375+ _ -> [e|traverse|]

376+ exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]

377+ exprFieldRender =

378+ [e|(\a ->

379+ XW.elementA $exprFieldStrName (toXmlParentAttributes a) a)|]

380+ return [e|$exprForField $exprFieldRender $exprFieldValue|]

381+ IsoXmlDescRecordContent (IsoXmlDescContent rawName _) -> do

382+ let

383+ fieldStrName = xmlLocalName rawName

384+ fName = TH.mkName (fieldName fieldStrName)

385+ exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]

386+ return [e|XW.content . toXmlAttribute $ $exprFieldValue|]

387+ _ -> []

388+ toXmlExpr

389+ = TH.lamE [if null exprFields then TH.wildP else TH.varP objName]

390+ $ foldr (\fe e -> [e|$fe *> $e|]) [e|return ()|] exprFields

391+ TH.instanceD

392+ (return [])

393+ [t|XW.ToXML $(TH.conT name)|]

394+ [funSimple 'XW.toXML toXmlExpr]

395+ genToXmlParentAttributeInst = do

396+ objName <- TH.newName strPrefix

397+ let

398+ exprAttributes = do

399+ descRecordPart <- descRecordParts

400+ IsoXmlDescAttribute attributePlural attributeStrName _ <-

401+ maybeToList $ case descRecordPart of

402+ IsoXmlDescRecordAttribute descAttribute -> Just descAttribute

403+ _ -> Nothing

404+ let

405+ fName = TH.mkName (fieldName attributeStrName)

406+ exprAttrStrName = TH.litE (TH.stringL attributeStrName)

407+ exprAttrValue = [e|$(TH.varE fName) $(TH.varE objName)|]

408+ exprAttrWrap = case attributePlural of

409+ XmlAttributePluralMandatory -> [e|Just . toXmlAttribute|]

410+ XmlAttributePluralOptional -> [e|fmap toXmlAttribute|]

411+ return [e|($exprAttrStrName, $exprAttrWrap $exprAttrValue)|]

412+ toXmlParentAttributesExpr

413+ = TH.lamE [if null exprAttributes then TH.wildP else TH.varP objName]

414+ $ [e|mapMaybe distribPair $(TH.listE exprAttributes)|]

415+#if __GLASGOW_HASKELL__ < 800

416+ TH.instanceD

417+#else

418+ TH.instanceWithOverlapD (Just TH.Overlapping)

419+#endif

420+ (return [])

421+ [t|ToXmlParentAttributes $(TH.conT name)|]

422+ [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]

423+

424+ case genType of

425+ Generator -> do

426+ toXmlInst <- genToXmlInst

427+ toXmlParentAttributesInst <- genToXmlParentAttributeInst

428+ return $ [termDecl] ++ lensDecls ++

429+ [toXmlInst, toXmlParentAttributesInst, nfDataInst]

430+ Parser -> do

431+ fromDomInst <- genFromDomInst Strict

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

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

443+ toXmlInst <- genToXmlInst

444+ toXmlParentAttributesInst <- genToXmlParentAttributeInst

445+ fromDomInst <- genFromDomInst Lenient

446+ return $ [termDecl] ++ lensDecls ++

447+ [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]

448+

449+distribPair :: Functor f => (a, f b) -> f (a, b)

450+distribPair (a, fb) = (a,) <$> fb

451+

452+-- | Get a local part of (possibly) fully qualified 'X.Name':

453+--

454+-- >>> xmlLocalName "{http://example.com/ns/my-namespace}my-name"

455+-- "my-name"

456+xmlLocalName :: String -> String

457+xmlLocalName = T.unpack . X.nameLocalName . fromString

src/Text/XML/DOM/Parser/Internal/Content.hsnew file+28

@@ -0,0 +1,28 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module Text.XML.DOM.Parser.Internal.Content where

3+import Control.Lens

4+import Control.Monad.Reader

5+import Data.Text as T

6+import Text.XML

7+import Text.XML.DOM.Parser hiding (getCurrentContent, parseContent)

9+-- Get current content. If there are more than one content

10+-- they are intercalate with space like in xpath `text()`

11+--

12+getCurrentContent :: (Monad m) => DomParserT Identity m Text

13+getCurrentContent

14+ = T.intercalate " "

15+ . (\e -> [T.strip cs| (NodeContent cs) <- e])

16+ . elementNodes

17+ . runIdentity

18+ . _pdElements

19+ <$> ask

20+

21+parseContent

22+ :: (Monad m)

23+ => (Text -> Either Text a)

24+ -- ^ Content parser, return error msg if value is not parsed

25+ -> DomParserT Identity m a

26+parseContent parse

27+ = getCurrentContent

28+ >>= either (throwParserError . PEContentWrongFormat) return . parse

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

ghc-821.yaml → stack-10.0.yamlrenamed+4−4

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

1−resolver: nightly-2017-09-14

1+nix:

2−

3−packages:

2+ packages:

4−- .

3+ - zlib

5+resolver: lts-10.0

6extra-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+7−6

@@ -1,8 +1,9 @@

1−resolver: lts-6.35

1+nix:

2−

3−packages:

2+ packages:

4−- .

3+ - zlib

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

test/TestDefs.hs+7−11

@@ -4,17 +4,16 @@

5module TestDefs where

7−import Data.List.NonEmpty

7+-- import Data.List.NonEmpty

8import Data.THGen.XML

9−import GHC.Generics (Generic)

10import Test.QuickCheck.Arbitrary.Generic

9import Test.QuickCheck.Arbitrary.Generic

11import Test.QuickCheck.Instances ()

10import Test.QuickCheck.Instances ()

13−"Bar" =:= enum

12+"Bar" =:= enum ParserAndGenerator

14 & "baroque"

13 & "baroque"

15 & "bartender"

14 & "bartender"

17−"Quux" Exhaustive =:= enum

16+"Quux" Exhaustive =:= enum ParserAndGenerator

18 & "ALL"

17 & "ALL"

19 & "YOUR"

18 & "YOUR"

20 & "BASE"

19 & "BASE"

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

23 & "TO"

22 & "TO"

24 & "US"

23 & "US"

26−"Foo" =:= record

25+"Foo" =:= record ParserAndGenerator

26+ ^ "Shmuux" [t|XmlQuux|]

27 + "Bar"

28 ? "Baz" [t|Text|]

29 !% "Quux"

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

32−"Root" =:= record

32+"Root" =:= record ParserAndGenerator

33− ! "Foo"

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

34−

35−deriving instance Generic XmlRoot

37instance Arbitrary XmlRoot where

35instance Arbitrary XmlRoot where

38 arbitrary = genericArbitrary

36 arbitrary = genericArbitrary

39 shrink = genericShrink

37 shrink = genericShrink

41−deriving instance Generic XmlFoo

42−

43instance Arbitrary XmlFoo where

39instance Arbitrary XmlFoo where

44 arbitrary = genericArbitrary

40 arbitrary = genericArbitrary

45 shrink = genericShrink

41 shrink = genericShrink

xml-isogen.cabal+14−2

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

1name: xml-isogen

2−version: 0.2.1

2+version: 0.3.2

3synopsis: Generate XML-isomorphic types

4description:

5 TemplateHaskell generators for XML-isomorphic data types, including

@@ -18,7 +18,8 @@ cabal-version: >=1.22

18homepage: https://github.com/typeable/xml-isogen

19tested-with: GHC == 7.10.3

20 , GHC == 8.0.2

21− , GHC == 8.2.1

21+ , GHC == 8.2.2

22+ , GHC == 8.4.1

22extra-source-files: CHANGELOG.md

23extra-source-files: CHANGELOG.md

23 , README.md

24 , README.md

@@ -29,24 +30,34 @@ source-repository head

29library

30library

30 exposed-modules: Data.THGen.Enum

31 exposed-modules: Data.THGen.Enum

31 , Data.THGen.XML

32 , Data.THGen.XML

33+ , Data.THGen.XML.Internal

32 , Text.XML.ParentAttributes

34 , Text.XML.ParentAttributes

35+ , Text.XML.Nillable

33 other-modules: Data.THGen.Compat

36 other-modules: Data.THGen.Compat

37+ , Data.THGen.Orphans

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

34 build-depends: QuickCheck >= 2.8

39 build-depends: QuickCheck >= 2.8

35 , base >=4.8 && <5

40 , base >=4.8 && <5

36 , dom-parser >= 2.0.0

41 , dom-parser >= 2.0.0

42+ , deepseq

37 , lens >= 4.13

43 , lens >= 4.13

38 , mtl >= 2.2

44 , mtl >= 2.2

45+ , scientific

39 , semigroups >= 0.18

46 , semigroups >= 0.18

40 , template-haskell >= 2.10

47 , template-haskell >= 2.10

41 , text >= 1.2

48 , text >= 1.2

42 , xml-conduit >= 1.0

49 , xml-conduit >= 1.0

43 , xml-conduit-writer >= 0.1

50 , xml-conduit-writer >= 0.1

52+ ghc-options: -Wall

53+

45 hs-source-dirs: src

54 hs-source-dirs: src

47 default-language: Haskell2010

56 default-language: Haskell2010

48 default-extensions: CPP

57 default-extensions: CPP

58+ , DeriveTraversable

49 , FlexibleInstances

59 , FlexibleInstances

60+ , GeneralizedNewtypeDeriving

50 , LambdaCase

61 , LambdaCase

51 , TemplateHaskell

62 , TemplateHaskell

52 , TupleSections

63 , TupleSections

@@ -60,6 +71,7 @@ test-suite spec

60 build-depends: base

71 build-depends: base

61 , QuickCheck

72 , QuickCheck

62 , data-default

73 , data-default

74+ , deepseq

63 , dom-parser

75 , dom-parser

64 , generic-arbitrary

76 , generic-arbitrary

65 , hspec

77 , hspec