git.iko.soy/typeable/xml-isogen
on master help sign in
swap
e7de36924 ahead, 0 behind
17 files changed+657−163
since splitsnapshots
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+15−7 src/Data/THGen/XML/Internal.hs+221−147 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------
33
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)
8+
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.
88
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
4+
15resolver: lts-9.21
26
37packages:
ghc-822.yaml+4
@@ -1 +1,5 @@
1+nix:
2+ packages:
3+ - zlib
4+
15resolver: lts-11.22
ghc-844.yaml+4
@@ -1,3 +1,7 @@
1+nix:
2+ packages:
3+ - zlib
4+
15resolver: lts-12.16
26extra-deps:
37- dom-parser-3.1.0
shell.nixnew file+17
@@ -0,0 +1,17 @@
1+{ nixpkgs ? import <nixpkgs> {}, compiler ? "default" }:
2+
3+let
4+
5+ inherit (nixpkgs) pkgs;
6+
7+ f = import ./default.nix;
8+
9+ haskellPackages = if compiler == "default"
10+ then pkgs.haskellPackages
11+ else pkgs.haskell.packages.${compiler};
12+
13+ drv = haskellPackages.callPackage f {};
14+
15+in
16+
17+ if pkgs.lib.inNixShell then drv.env else drv
src/Data/THGen/Orphans.hsnew file+11
@@ -0,0 +1,11 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2+
3+module Data.THGen.Orphans
4+where
5+
6+import Data.Scientific
7+import qualified Data.Text as Text
8+import Text.XML.Writer
9+
10+instance ToXML Scientific where
11+ toXML = content . Text.pack . formatScientific Fixed Nothing
src/Data/THGen/XML.hs+15−7
@@ -22,7 +22,7 @@ wrapper around the field type:
2222
2323Example 1.
2424
25−> "Color" =:= enum
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
43+> "Message" =:= record ParserAndGenerator
4444> ! "author"
4545> + "recipient"
4646> ? "message" [t|Text|]
@@ -67,10 +67,10 @@ enumeration is exhaustive (contains only the listed constructors) or
6767non-exhaustive (also contains a constructor for unknown values; this
6868is the default):
6969
70−> "Enum1" Exhaustive =:= enum
70+> "Enum1" Exhaustive =:= enum Generator
7171> ...
7272
73−> "Enum2" NonExhaustive =:= enum
73+> "Enum2" NonExhaustive =:= enum Generator
7474> ...
7575
7676To define a record, use the `record` function followed by the name of
@@ -78,7 +78,7 @@ the data type to be generated. The prefix for the record fields is
7878inferred automatically by taking all of the uppercase letters in the
7979name. You can override it manually like so:
8080
81−> "Reference" "ref" =:= record
81+> "Reference" "ref" =:= record Parser
8282> ...
8383
8484To describe a record field you must supply its name as it appears
@@ -93,10 +93,14 @@ 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
97−> ! "author" [t|Person|]
96+> "Message" =:= record ParserAndGenerator
97+> ! "author" [t|Person|].
9898> ...
9999
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+
100104-}
101105
102106
@@ -104,6 +108,7 @@ module Data.THGen.XML
104108 ( Exhaustiveness(..)
105109 , PrefixName(..)
106110 , ExhaustivenessName(..)
111+ , GenType(..)
107112 , record
108113 , enum
109114 , (!)
@@ -119,9 +124,12 @@ module Data.THGen.XML
119124 , Text
120125 , P.Int
121126 , P.Integer
127+ , Nillable(..)
122128 ) where
123129
124130import Data.THGen.Enum
131+import Data.THGen.Orphans ()
125132import Data.THGen.XML.Internal
126133import Data.Text
134+import Text.XML.Nillable
127135import qualified Prelude as P
src/Data/THGen/XML/Internal.hs+221−147
@@ -1,10 +1,11 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE UndecidableInstances #-}
23{-# LANGUAGE FunctionalDependencies #-}
34
45module Data.THGen.XML.Internal where
56
67import Control.DeepSeq
7−import Control.Lens hiding (repeated, enum, (&))
8+import Control.Lens hiding (repeated, enum, (&), Strict)
89import Control.Lens.Internal.FieldTH (makeFieldOpticsForDec)
910import qualified Data.Char as C
1011import Data.List.NonEmpty (NonEmpty)
@@ -14,7 +15,7 @@ import Data.THGen.Compat as THC
1415import Data.THGen.Enum
1516import qualified Data.Text as T
1617import GHC.Generics (Generic)
17−import Language.Haskell.TH as TH
18+import Language.Haskell.TH as TH hiding (Strict)
1819import Prelude hiding ((+), (*), (^))
1920import qualified Text.XML as X
2021import Text.XML.DOM.Parser hiding (parseContent)
@@ -22,6 +23,22 @@ import Text.XML.DOM.Parser.Internal.Content
2223import Text.XML.ParentAttributes
2324import qualified Text.XML.Writer as XW
2425
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
2542
2643data XmlFieldPlural
2744 = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
@@ -52,7 +69,7 @@ data IsoXmlDescRecordPart
5269 | IsoXmlDescRecordAttribute IsoXmlDescAttribute
5370 | IsoXmlDescRecordContent IsoXmlDescContent
5471
55−newtype IsoXmlDescRecord = IsoXmlDescRecord [IsoXmlDescRecordPart]
72+data IsoXmlDescRecord = IsoXmlDescRecord GenType [IsoXmlDescRecordPart]
5673
5774makePrisms ''IsoXmlDescRecord
5875
@@ -64,7 +81,7 @@ newtype IsoXmlDescEnumCon
6481instance IsString IsoXmlDescEnumCon where
6582 fromString = IsoXmlDescEnumCon
6683
67−data IsoXmlDescEnum = IsoXmlDescEnum [IsoXmlDescEnumCon]
84+data IsoXmlDescEnum = IsoXmlDescEnum GenType [IsoXmlDescEnumCon]
6885
6986makePrisms ''IsoXmlDescEnum
7087
@@ -73,26 +90,26 @@ appendField
7390 -> IsoXmlDescRecord
7491 -> IsoXmlDescPreField
7592 -> IsoXmlDescRecord
76−appendField plural xrec (IsoXmlDescPreField name ty) =
93+appendField plural (IsoXmlDescRecord genType fields) (IsoXmlDescPreField name ty) =
7794 let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty
78− in over _IsoXmlDescRecord (xfield:) xrec
95+ in IsoXmlDescRecord genType (xfield:fields)
7996
8097appendAttribute
8198 :: XmlAttributePlural
8299 -> IsoXmlDescRecord
83100 -> IsoXmlDescPreAttribute
84101 -> IsoXmlDescRecord
85−appendAttribute plural xrec (IsoXmlDescPreAttribute name ty) =
102+appendAttribute plural (IsoXmlDescRecord genType fields) (IsoXmlDescPreAttribute name ty) =
86103 let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty
87− in over _IsoXmlDescRecord (xattribute:) xrec
104+ in IsoXmlDescRecord genType (xattribute:fields)
88105
89106appendContent
90107 :: IsoXmlDescRecord
91108 -> IsoXmlDescPreContent
92109 -> IsoXmlDescRecord
93−appendContent xrec (IsoXmlDescPreContent name ty) =
110+appendContent (IsoXmlDescRecord genType fields) (IsoXmlDescPreContent name ty) =
94111 let xcontent = IsoXmlDescRecordContent $ IsoXmlDescContent name ty
95− in over _IsoXmlDescRecord (xcontent:) xrec
112+ in IsoXmlDescRecord genType (xcontent:fields)
96113
97114(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
98115(!) = appendField XmlFieldPluralMandatory
@@ -116,8 +133,8 @@ infixl 2 ?%
116133infixl 2 ^
117134
118135appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
119−appendEnumCon xenum xenumcon =
120− over _IsoXmlDescEnum (xenumcon:) xenum
136+appendEnumCon (IsoXmlDescEnum genType enumCons) xenumcon =
137+ IsoXmlDescEnum genType (xenumcon:enumCons)
121138
122139(&) :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
123140(&) = appendEnumCon
@@ -130,22 +147,20 @@ class Description name desc | desc -> name where
130147infix 0 =:=
131148
132149instance Description PrefixName IsoXmlDescRecord where
133− prefixName =:= descRecord =
134− let descRecordParts = descRecord ^. _IsoXmlDescRecord
135− in isoXmlGenerateDatatype prefixName (reverse descRecordParts)
150+ prefixName =:= (IsoXmlDescRecord genType descRecordParts) =
151+ isoXmlGenerateDatatype genType prefixName (reverse descRecordParts)
136152
137−record :: IsoXmlDescRecord
138−record = IsoXmlDescRecord []
153+record :: GenType -> IsoXmlDescRecord
154+record gt = IsoXmlDescRecord gt []
139155
140−enum :: IsoXmlDescEnum
141−enum = IsoXmlDescEnum []
156+enum :: GenType -> IsoXmlDescEnum
157+enum gt = IsoXmlDescEnum gt []
142158
143159instance Description ExhaustivenessName IsoXmlDescEnum where
144− exhaustivenessName =:= descEnum =
145− let descEnumCons = descEnum ^. _IsoXmlDescEnum
146− in isoXmlGenerateEnum exhaustivenessName (reverse descEnumCons)
160+ exhaustivenessName =:= (IsoXmlDescEnum genType descEnumCons) =
161+ isoXmlGenerateEnum genType exhaustivenessName (reverse descEnumCons)
147162
148−instance IsString (TH.TypeQ -> IsoXmlDescPreField) where
163+instance (m ~ Q) => IsString (m TH.Type -> IsoXmlDescPreField) where
149164 fromString = IsoXmlDescPreField
150165
151166instance IsString IsoXmlDescPreField where
@@ -153,10 +168,10 @@ instance IsString IsoXmlDescPreField where
153168 where
154169 ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper (xmlLocalName name))
155170
156−instance IsString (TH.TypeQ -> IsoXmlDescPreAttribute) where
171+instance (m ~ Q) => IsString (m TH.Type -> IsoXmlDescPreAttribute) where
157172 fromString = IsoXmlDescPreAttribute
158173
159−instance IsString (TH.TypeQ -> IsoXmlDescPreContent) where
174+instance (m ~ Q) => IsString (m Type -> IsoXmlDescPreContent) where
160175 fromString = IsoXmlDescPreContent
161176
162177instance IsString IsoXmlDescPreAttribute where
@@ -182,45 +197,77 @@ instance IsString ExhaustivenessName where
182197 fromString strName = ExhaustivenessName strName NonExhaustive
183198
184199makeNamePrefix :: String -> String
185−makeNamePrefix = map C.toLower . filter C.isUpper
200+makeNamePrefix = map C.toLower . filter (\c -> C.isUpper c || C.isDigit c)
186201
187202funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ
188203funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]
189204
190205isoXmlGenerateEnum
191− :: ExhaustivenessName -> [IsoXmlDescEnumCon] -> TH.DecsQ
192−isoXmlGenerateEnum (ExhaustivenessName strName' exh) enumCons = do
206+ :: GenType
207+ -> ExhaustivenessName
208+ -> [IsoXmlDescEnumCon]
209+ -> TH.DecsQ
210+isoXmlGenerateEnum genType (ExhaustivenessName strName' exh) enumCons = do
193211 let
194212 strName = "Xml" ++ strName'
195213 strVals = map unIsoXmlDescEnumCon enumCons
196214 enumDesc = EnumDesc exh strName strVals
197215 name = TH.mkName strName
198216 enumDecls <- enumGenerate enumDesc
199− toXmlInst <- do
200− TH.instanceD
201− (return [])
202− [t|XW.ToXML $(TH.conT name)|]
203− [funSimple 'XW.toXML [e|XW.toXML . T.pack . show|]]
204− toXmlAttributeInst <- do
205− TH.instanceD
206− (return [])
207− [t|ToXmlAttribute $(TH.conT name)|]
208− [funSimple 'toXmlAttribute [e|T.pack . show|]]
209− fromDomInst <- do
210− TH.instanceD
211− (return [])
212− [t|FromDom $(TH.conT name)|]
213− [funSimple 'fromDom [e|parseContent readContent|]]
214− fromAttributeInst <- do
215− TH.instanceD
216− (return [])
217− [t|FromAttribute $(TH.conT name)|]
218− [funSimple 'fromAttribute [e|readContent|]]
219− return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
220− fromDomInst, fromAttributeInst]
221−
222−isoXmlGenerateDatatype :: PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ
223−isoXmlGenerateDatatype (PrefixName strName' strPrefix') descRecordParts = do
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
224271 let
225272 isNewtype = length descRecordParts == 1
226273 strName = "Xml" ++ strName'
@@ -237,11 +284,14 @@ isoXmlGenerateDatatype (PrefixName strName' strPrefix') descRecordParts = do
237284 IsoXmlDescField fieldPlural rawName fieldType = descField
238285 fieldStrName = xmlLocalName rawName
239286 fName = TH.mkName (fieldName fieldStrName)
240− fType = case fieldPlural of
287+ fType' = case fieldPlural of
241288 XmlFieldPluralMandatory -> fieldType
242289 XmlFieldPluralOptional -> [t| Maybe $fieldType |]
243290 XmlFieldPluralRepeated -> [t| [$fieldType] |]
244291 XmlFieldPluralMultiplied -> [t| NonEmpty $fieldType |]
292+ fType = if isLenientType genType
293+ then [t| Maybe $fType' |]
294+ else fType'
245295 in if isNewtype
246296 then THC.varStrictType fName (THC.nonStrictType fType)
247297 else THC.varStrictType fName (THC.strictType fType)
@@ -274,103 +324,127 @@ isoXmlGenerateDatatype (PrefixName strName' strPrefix') descRecordParts = do
274324 (return [])
275325 [t|NFData $(TH.conT name)|]
276326 [ ]
277− fromDomInst <- do
278− let
279− exprHeader = [e|pure $(TH.conE name)|]
280− exprRecordParts = do
281− descRecordPart <- descRecordParts
282− return $ case descRecordPart of
283− IsoXmlDescRecordField descField ->
284− let
285− IsoXmlDescField fieldPlural rawName _ = descField
286− fieldStrName = xmlLocalName rawName
287− exprFieldStrName = TH.litE (TH.stringL fieldStrName)
288− fieldParse = case fieldPlural of
289− XmlFieldPluralMandatory -> [e|inElem|]
290− _ -> [e|inElemTrav|]
291− in
292− [e|$fieldParse $exprFieldStrName fromDom|]
293− IsoXmlDescRecordAttribute descAttribute ->
294− let
295− IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute
296− exprAttributeStrName = TH.litE (TH.stringL attributeStrName)
297− attributeParse = case attributePlural of
298− XmlAttributePluralMandatory -> [e|parseAttribute|]
299− XmlAttributePluralOptional -> [e|parseAttributeMaybe|]
300− in
301− [e|$attributeParse $exprAttributeStrName fromAttribute|]
302− IsoXmlDescRecordContent _ -> [e|parseContent fromAttribute|]
303− fromDomExpr = foldl (\e fe -> [e| $e <*> $fe |]) exprHeader exprRecordParts
304− TH.instanceD
305− (return [])
306− [t|FromDom $(TH.conT name)|]
307− [ funSimple 'fromDom fromDomExpr ]
308327
309− toXmlInst <- do
310− objName <- TH.newName strPrefix
311− let
312− exprFields = do
313− descRecordPart <- descRecordParts
314− case descRecordPart of
315− IsoXmlDescRecordField (IsoXmlDescField fieldPlural rawName _) -> do
316− let
317− fieldStrName = xmlLocalName rawName
318− fName = TH.mkName (fieldName fieldStrName)
319− exprFieldStrName = TH.litE (TH.stringL rawName)
320− exprForField = case fieldPlural of
321− XmlFieldPluralMandatory -> [e|id|]
322− _ -> [e|traverse|]
323− exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
324− exprFieldRender =
325− [e|(\a ->
326− XW.elementA $exprFieldStrName (toXmlParentAttributes a) a)|]
327− return [e|$exprForField $exprFieldRender $exprFieldValue|]
328− IsoXmlDescRecordContent (IsoXmlDescContent rawName _) -> do
329− let
330− fieldStrName = xmlLocalName rawName
331− fName = TH.mkName (fieldName fieldStrName)
332− exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
333− return [e|XW.content . toXmlAttribute $ $exprFieldValue|]
334− _ -> []
335− toXmlExpr
336− = TH.lamE [if null exprFields then TH.wildP else TH.varP objName]
337− $ foldr (\fe e -> [e|$fe *> $e|]) [e|return ()|] exprFields
338− TH.instanceD
339− (return [])
340− [t|XW.ToXML $(TH.conT name)|]
341− [funSimple 'XW.toXML toXmlExpr]
342−
343− toXmlParentAttributesInst <- do
344− objName <- TH.newName strPrefix
345− let
346− exprAttributes = do
347− descRecordPart <- descRecordParts
348− IsoXmlDescAttribute attributePlural attributeStrName _ <-
349− maybeToList $ case descRecordPart of
350− IsoXmlDescRecordAttribute descAttribute -> Just descAttribute
351− _ -> Nothing
352− let
353− fName = TH.mkName (fieldName attributeStrName)
354− exprAttrStrName = TH.litE (TH.stringL attributeStrName)
355− exprAttrValue = [e|$(TH.varE fName) $(TH.varE objName)|]
356− exprAttrWrap = case attributePlural of
357− XmlAttributePluralMandatory -> [e|Just . toXmlAttribute|]
358− XmlAttributePluralOptional -> [e|fmap toXmlAttribute|]
359− return [e|($exprAttrStrName, $exprAttrWrap $exprAttrValue)|]
360− toXmlParentAttributesExpr
361− = TH.lamE [if null exprAttributes then TH.wildP else TH.varP objName]
362− $ [e|mapMaybe distribPair $(TH.listE exprAttributes)|]
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)|]
363415#if __GLASGOW_HASKELL__ < 800
364− TH.instanceD
416+ TH.instanceD
365417#else
366− TH.instanceWithOverlapD (Just TH.Overlapping)
418+ TH.instanceWithOverlapD (Just TH.Overlapping)
367419#endif
368− (return [])
369− [t|ToXmlParentAttributes $(TH.conT name)|]
370− [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]
371−
372− return $ [termDecl] ++ lensDecls ++
373− [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]
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]
374448
375449distribPair :: Functor f => (a, f b) -> f (a, b)
376450distribPair (a, fb) = (a,) <$> fb
src/Text/XML/Nillable.hsnew file+41
@@ -0,0 +1,41 @@
1+{-# LANGUAGE MonoLocalBinds #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+
4+module Text.XML.Nillable where
5+
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
4+
5+resolver: lts-10.0
6+extra-deps:
7+- dom-parser-3.0.0
8+- generic-arbitrary-0.1.0
stack-18.18.yamlnew file+9
@@ -0,0 +1,9 @@
1+nix:
2+ packages:
3+ - zlib
4+
5+resolver: lts-18.18
6+extra-deps:
7+- git: https://github.com/typeable/dom-parser.git
8+ commit: 7d556ba528bfa216e99714f8a0d4d00f452803a9
9+- xml-lens-0.3.1
stack-19.6.yamlnew file+9
@@ -0,0 +1,9 @@
1+nix:
2+ packages:
3+ - zlib
4+
5+resolver: lts-19.6
6+extra-deps:
7+- git: https://github.com/typeable/dom-parser.git
8+ commit: 7d556ba528bfa216e99714f8a0d4d00f452803a9
9+- xml-lens-0.3.1
stack.yaml+8−3
@@ -1,4 +1,9 @@
1−resolver: lts-10.0
1+nix:
2+ packages:
3+ - zlib
4+
5+resolver: lts-20.16
26extra-deps:
3−- dom-parser-3.0.0
4−- generic-arbitrary-0.1.0
7+ - git: https://github.com/typeable/dom-parser.git
8+ commit: 7d556ba528bfa216e99714f8a0d4d00f452803a9
9+ - xml-lens-0.3.1
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
12+"Bar" =:= enum ParserAndGenerator
1313 & "baroque"
1414 & "bartender"
1515
16−"Quux" Exhaustive =:= enum
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
25+"Foo" =:= record ParserAndGenerator
2626 ^ "Shmuux" [t|XmlQuux|]
2727 + "Bar"
2828 ? "Baz" [t|Text|]
2929 !% "Quux"
3030 ?% "Muux" [t|XmlQuux|]
3131
32−"Root" =:= record
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