git.iko.soy/typeable/xml-isogen
on master help sign in
swap
e7de36929 ahead, 0 behind
17 files changed+901−398
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+22−389 src/Data/THGen/XML/Internal.hs+457 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+9−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+22−389
@@ -1,5 +1,4 @@
1−{-# LANGUAGE UndecidableInstances #-}
2−{-# LANGUAGE FunctionalDependencies #-}
1+{-# LANGUAGE NoImplicitPrelude #-}
32
43{- |
54
@@ -23,7 +22,7 @@ wrapper around the field type:
2322
2423Example 1.
2524
26−> "Color" =:= enum
25+> "Color" =:= enum ParserAndGenerator
2726> & "R"
2827> & "G"
2928> & "B"
@@ -41,7 +40,7 @@ to be either @R@, @G@ or @B@.
4140
4241Example 2.
4342
44−> "Message" =:= record
43+> "Message" =:= record ParserAndGenerator
4544> ! "author"
4645> + "recipient"
4746> ? "message" [t|Text|]
@@ -68,10 +67,10 @@ enumeration is exhaustive (contains only the listed constructors) or
6867non-exhaustive (also contains a constructor for unknown values; this
6968is the default):
7069
71−> "Enum1" Exhaustive =:= enum
70+> "Enum1" Exhaustive =:= enum Generator
7271> ...
7372
74−> "Enum2" NonExhaustive =:= enum
73+> "Enum2" NonExhaustive =:= enum Generator
7574> ...
7675
7776To 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
7978inferred automatically by taking all of the uppercase letters in the
8079name. You can override it manually like so:
8180
82−> "Reference" "ref" =:= record
81+> "Reference" "ref" =:= record Parser
8382> ...
8483
8584To 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
9493if the field is called @"author"@ its type will be @Author@. You can
9594override the type by specifying it in quasiquotes like so:
9695
97−> "Message" =:= record
98−> ! "author" [t|Person|]
96+> "Message" =:= record ParserAndGenerator
97+> ! "author" [t|Person|].
9998> ...
10099
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+
101104-}
102105
103106
@@ -105,6 +108,7 @@ module Data.THGen.XML
105108 ( Exhaustiveness(..)
106109 , PrefixName(..)
107110 , ExhaustivenessName(..)
111+ , GenType(..)
108112 , record
109113 , enum
110114 , (!)
@@ -117,386 +121,15 @@ module Data.THGen.XML
117121 , (^)
118122 , (=:=)
119123 -- Re-exports
120− , T.Text
121− , Int
122− , Integer
124+ , Text
125+ , P.Int
126+ , P.Integer
127+ , Nillable(..)
123128 ) where
124129
125−import Control.DeepSeq
126−import Control.Lens hiding (repeated, enum, (&))
127−import Control.Lens.Internal.FieldTH (makeFieldOpticsForDec)
128−import qualified Data.Char as C
129−import Data.List.NonEmpty (NonEmpty)
130−import Data.Maybe (maybeToList, mapMaybe)
131−import Data.String
132−import Data.THGen.Compat
133130import Data.THGen.Enum
134−import qualified Data.Text as T
135−import GHC.Generics (Generic)
136−import qualified Language.Haskell.TH as TH
137−import Prelude hiding ((+), (*), (^))
138−import qualified Text.XML as X
139−import Text.XML.DOM.Parser hiding (parseContent)
140−import Text.XML.ParentAttributes
141−import qualified Text.XML.Writer as XW
142−import Text.XML.DOM.Parser.Internal.Content
143−
144−
145−data XmlFieldPlural
146− = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
147− | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)
148− | XmlFieldPluralRepeated -- Occurs 0 or more times (List)
149− | XmlFieldPluralMultiplied -- Occurs 1 or more times (NonEmpty)
150−
151−data XmlAttributePlural
152− = XmlAttributePluralMandatory -- Occurs exactly 1 time (Identity)
153− | XmlAttributePluralOptional -- Occurs 0 or 1 times (Maybe)
154−
155−data PrefixName = PrefixName String String
156−
157−data IsoXmlDescPreField = IsoXmlDescPreField String TH.TypeQ
158−
159−data IsoXmlDescPreAttribute = IsoXmlDescPreAttribute String TH.TypeQ
160−
161−data IsoXmlDescPreContent = IsoXmlDescPreContent String TH.TypeQ
162−
163−data IsoXmlDescField = IsoXmlDescField XmlFieldPlural String TH.TypeQ
164−
165−data IsoXmlDescAttribute = IsoXmlDescAttribute XmlAttributePlural String TH.TypeQ
166−
167−data IsoXmlDescContent = IsoXmlDescContent String TH.TypeQ
168−
169−data IsoXmlDescRecordPart
170− = IsoXmlDescRecordField IsoXmlDescField
171− | IsoXmlDescRecordAttribute IsoXmlDescAttribute
172− | IsoXmlDescRecordContent IsoXmlDescContent
173−
174−newtype IsoXmlDescRecord = IsoXmlDescRecord [IsoXmlDescRecordPart]
175−
176−makePrisms ''IsoXmlDescRecord
177−
178−data ExhaustivenessName = ExhaustivenessName String Exhaustiveness
179−
180−newtype IsoXmlDescEnumCon
181− = IsoXmlDescEnumCon { unIsoXmlDescEnumCon :: String }
182−
183−instance IsString IsoXmlDescEnumCon where
184− fromString = IsoXmlDescEnumCon
185−
186−data IsoXmlDescEnum = IsoXmlDescEnum [IsoXmlDescEnumCon]
187−
188−makePrisms ''IsoXmlDescEnum
189−
190−appendField
191− :: XmlFieldPlural
192− -> IsoXmlDescRecord
193− -> IsoXmlDescPreField
194− -> IsoXmlDescRecord
195−appendField plural xrec (IsoXmlDescPreField name ty) =
196− let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty
197− in over _IsoXmlDescRecord (xfield:) xrec
198−
199−appendAttribute
200− :: XmlAttributePlural
201− -> IsoXmlDescRecord
202− -> IsoXmlDescPreAttribute
203− -> IsoXmlDescRecord
204−appendAttribute plural xrec (IsoXmlDescPreAttribute name ty) =
205− let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty
206− in over _IsoXmlDescRecord (xattribute:) xrec
207−
208−appendContent
209− :: IsoXmlDescRecord
210− -> IsoXmlDescPreContent
211− -> IsoXmlDescRecord
212−appendContent xrec (IsoXmlDescPreContent name ty) =
213− let xcontent = IsoXmlDescRecordContent $ IsoXmlDescContent name ty
214− in over _IsoXmlDescRecord (xcontent:) xrec
215−
216−(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
217−(!) = appendField XmlFieldPluralMandatory
218−(?) = appendField XmlFieldPluralOptional
219−(*) = appendField XmlFieldPluralRepeated
220−(+) = appendField XmlFieldPluralMultiplied
221−
222−(!%), (?%) :: IsoXmlDescRecord -> IsoXmlDescPreAttribute -> IsoXmlDescRecord
223−(!%) = appendAttribute XmlAttributePluralMandatory
224−(?%) = appendAttribute XmlAttributePluralOptional
225−
226−(^) :: IsoXmlDescRecord -> IsoXmlDescPreContent -> IsoXmlDescRecord
227−(^) = appendContent
228−
229−infixl 2 !
230−infixl 2 ?
231−infixl 2 *
232−infixl 2 +
233−infixl 2 !%
234−infixl 2 ?%
235−infixl 2 ^
236−
237−appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
238−appendEnumCon xenum xenumcon =
239− over _IsoXmlDescEnum (xenumcon:) xenum
240−
241−(&) :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
242−(&) = appendEnumCon
243−
244−infixl 2 &
245−
246−class Description name desc | desc -> name where
247− (=:=) :: name -> desc -> TH.DecsQ
248−
249−infix 0 =:=
250−
251−instance Description PrefixName IsoXmlDescRecord where
252− prefixName =:= descRecord =
253− let descRecordParts = descRecord ^. _IsoXmlDescRecord
254− in isoXmlGenerateDatatype prefixName (reverse descRecordParts)
255−
256−record :: IsoXmlDescRecord
257−record = IsoXmlDescRecord []
258−
259−enum :: IsoXmlDescEnum
260−enum = IsoXmlDescEnum []
261−
262−instance Description ExhaustivenessName IsoXmlDescEnum where
263− exhaustivenessName =:= descEnum =
264− let descEnumCons = descEnum ^. _IsoXmlDescEnum
265− in isoXmlGenerateEnum exhaustivenessName (reverse descEnumCons)
266−
267−instance IsString (TH.TypeQ -> IsoXmlDescPreField) where
268− fromString = IsoXmlDescPreField
269−
270−instance IsString IsoXmlDescPreField where
271− fromString name = IsoXmlDescPreField name ty
272− where
273− ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper (xmlLocalName name))
274−
275−instance IsString (TH.TypeQ -> IsoXmlDescPreAttribute) where
276− fromString = IsoXmlDescPreAttribute
277−
278−instance IsString (TH.TypeQ -> IsoXmlDescPreContent) where
279− fromString = IsoXmlDescPreContent
280−
281−instance IsString IsoXmlDescPreAttribute where
282− fromString name = IsoXmlDescPreAttribute name ty
283− where
284− ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)
285−
286−instance IsString IsoXmlDescPreContent where
287− fromString name = IsoXmlDescPreContent name ty
288− where
289− ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)
290−
291−instance s ~ String => IsString (s -> PrefixName) where
292− fromString = PrefixName
293−
294−instance IsString PrefixName where
295− fromString strName = PrefixName strName (makeNamePrefix strName)
296−
297−instance e ~ Exhaustiveness => IsString (e -> ExhaustivenessName) where
298− fromString = ExhaustivenessName
299−
300−instance IsString ExhaustivenessName where
301− fromString strName = ExhaustivenessName strName NonExhaustive
302−
303−makeNamePrefix :: String -> String
304−makeNamePrefix = map C.toLower . filter C.isUpper
305−
306−funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ
307−funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]
308−
309−isoXmlGenerateEnum
310− :: ExhaustivenessName -> [IsoXmlDescEnumCon] -> TH.DecsQ
311−isoXmlGenerateEnum (ExhaustivenessName strName' exh) enumCons = do
312− let
313− strName = "Xml" ++ strName'
314− strVals = map unIsoXmlDescEnumCon enumCons
315− enumDesc = EnumDesc exh strName strVals
316− name = TH.mkName strName
317− enumDecls <- enumGenerate enumDesc
318− toXmlInst <- do
319− TH.instanceD
320− (return [])
321− [t|XW.ToXML $(TH.conT name)|]
322− [funSimple 'XW.toXML [e|XW.toXML . T.pack . show|]]
323− toXmlAttributeInst <- do
324− TH.instanceD
325− (return [])
326− [t|ToXmlAttribute $(TH.conT name)|]
327− [funSimple 'toXmlAttribute [e|T.pack . show|]]
328− fromDomInst <- do
329− TH.instanceD
330− (return [])
331− [t|FromDom $(TH.conT name)|]
332− [funSimple 'fromDom [e|parseContent readContent|]]
333− fromAttributeInst <- do
334− TH.instanceD
335− (return [])
336− [t|FromAttribute $(TH.conT name)|]
337− [funSimple 'fromAttribute [e|readContent|]]
338− return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
339− fromDomInst, fromAttributeInst]
340−
341−isoXmlGenerateDatatype :: PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ
342−isoXmlGenerateDatatype (PrefixName strName' strPrefix') descRecordParts = do
343− let
344− isNewtype = length descRecordParts == 1
345− strName = "Xml" ++ strName'
346− strPrefix = "x" ++ strPrefix'
347− name = TH.mkName strName
348− fieldName str = "_" ++ strPrefix ++ over _head C.toUpper str
349− termDecl <- do
350− let
351− fields = do
352− descRecordPart <- descRecordParts
353− return $ case descRecordPart of
354− IsoXmlDescRecordField descField ->
355− let
356− IsoXmlDescField fieldPlural rawName fieldType = descField
357− fieldStrName = xmlLocalName rawName
358− fName = TH.mkName (fieldName fieldStrName)
359− fType = case fieldPlural of
360− XmlFieldPluralMandatory -> fieldType
361− XmlFieldPluralOptional -> [t| Maybe $fieldType |]
362− XmlFieldPluralRepeated -> [t| [$fieldType] |]
363− XmlFieldPluralMultiplied -> [t| NonEmpty $fieldType |]
364− in if isNewtype
365− then varStrictType fName (nonStrictType fType)
366− else varStrictType fName (strictType fType)
367− IsoXmlDescRecordAttribute descAttribute ->
368− let
369− IsoXmlDescAttribute
370− attributePlural attributeStrName attributeType = descAttribute
371− fName = TH.mkName (fieldName attributeStrName)
372− fType = case attributePlural of
373− XmlAttributePluralMandatory -> attributeType
374− XmlAttributePluralOptional -> [t| Maybe $attributeType |]
375− in if isNewtype
376− then varStrictType fName (nonStrictType fType)
377− else varStrictType fName (strictType fType)
378− IsoXmlDescRecordContent descContent ->
379− let
380− IsoXmlDescContent contentStrName contentType = descContent
381− fName = TH.mkName (fieldName contentStrName)
382− fType = contentType
383− in if isNewtype
384− then varStrictType fName (nonStrictType fType)
385− else varStrictType fName (strictType fType)
386− if isNewtype
387− -- generate a newtype instead to do less allocations later
388− then newtypeD name (TH.recC name fields) [''Eq, ''Show, ''Generic]
389− else dataD name [TH.recC name fields] [''Eq, ''Show, ''Generic]
390− lensDecls <- makeFieldOpticsForDec lensRules termDecl
391− nfDataInst <- do
392− TH.instanceD
393− (return [])
394− [t|NFData $(TH.conT name)|]
395− [ ]
396− fromDomInst <- do
397− let
398− exprHeader = [e|pure $(TH.conE name)|]
399− exprRecordParts = do
400− descRecordPart <- descRecordParts
401− return $ case descRecordPart of
402− IsoXmlDescRecordField descField ->
403− let
404− IsoXmlDescField fieldPlural rawName _ = descField
405− fieldStrName = xmlLocalName rawName
406− exprFieldStrName = TH.litE (TH.stringL fieldStrName)
407− fieldParse = case fieldPlural of
408− XmlFieldPluralMandatory -> [e|inElem|]
409− _ -> [e|inElemTrav|]
410− in
411− [e|$fieldParse $exprFieldStrName fromDom|]
412− IsoXmlDescRecordAttribute descAttribute ->
413− let
414− IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute
415− exprAttributeStrName = TH.litE (TH.stringL attributeStrName)
416− attributeParse = case attributePlural of
417− XmlAttributePluralMandatory -> [e|parseAttribute|]
418− XmlAttributePluralOptional -> [e|parseAttributeMaybe|]
419− in
420− [e|$attributeParse $exprAttributeStrName fromAttribute|]
421− IsoXmlDescRecordContent _ -> [e|parseContent fromAttribute|]
422− fromDomExpr = foldl (\e fe -> [e| $e <*> $fe |]) exprHeader exprRecordParts
423− TH.instanceD
424− (return [])
425− [t|FromDom $(TH.conT name)|]
426− [ funSimple 'fromDom fromDomExpr ]
427−
428− toXmlInst <- do
429− objName <- TH.newName strPrefix
430− let
431− exprFields = do
432− descRecordPart <- descRecordParts
433− case descRecordPart of
434− IsoXmlDescRecordField (IsoXmlDescField fieldPlural rawName _) -> do
435− let
436− fieldStrName = xmlLocalName rawName
437− fName = TH.mkName (fieldName fieldStrName)
438− exprFieldStrName = TH.litE (TH.stringL rawName)
439− exprForField = case fieldPlural of
440− XmlFieldPluralMandatory -> [e|id|]
441− _ -> [e|traverse|]
442− exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
443− exprFieldRender =
444− [e|(\a ->
445− XW.elementA $exprFieldStrName (toXmlParentAttributes a) a)|]
446− return [e|$exprForField $exprFieldRender $exprFieldValue|]
447− IsoXmlDescRecordContent (IsoXmlDescContent rawName _) -> do
448− let
449− fieldStrName = xmlLocalName rawName
450− fName = TH.mkName (fieldName fieldStrName)
451− exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
452− return [e|XW.content . toXmlAttribute $ $exprFieldValue|]
453− _ -> []
454− toXmlExpr
455− = TH.lamE [if null exprFields then TH.wildP else TH.varP objName]
456− $ foldr (\fe e -> [e|$fe *> $e|]) [e|return ()|] exprFields
457− TH.instanceD
458− (return [])
459− [t|XW.ToXML $(TH.conT name)|]
460− [funSimple 'XW.toXML toXmlExpr]
461−
462− toXmlParentAttributesInst <- do
463− objName <- TH.newName strPrefix
464− let
465− exprAttributes = do
466− descRecordPart <- descRecordParts
467− IsoXmlDescAttribute attributePlural attributeStrName _ <-
468− maybeToList $ case descRecordPart of
469− IsoXmlDescRecordAttribute descAttribute -> Just descAttribute
470− _ -> Nothing
471− let
472− fName = TH.mkName (fieldName attributeStrName)
473− exprAttrStrName = TH.litE (TH.stringL attributeStrName)
474− exprAttrValue = [e|$(TH.varE fName) $(TH.varE objName)|]
475− exprAttrWrap = case attributePlural of
476− XmlAttributePluralMandatory -> [e|Just . toXmlAttribute|]
477− XmlAttributePluralOptional -> [e|fmap toXmlAttribute|]
478− return [e|($exprAttrStrName, $exprAttrWrap $exprAttrValue)|]
479− toXmlParentAttributesExpr
480− = TH.lamE [if null exprAttributes then TH.wildP else TH.varP objName]
481− $ [e|mapMaybe distribPair $(TH.listE exprAttributes)|]
482−#if __GLASGOW_HASKELL__ < 800
483− TH.instanceD
484−#else
485− TH.instanceWithOverlapD (Just TH.Overlapping)
486−#endif
487− (return [])
488− [t|ToXmlParentAttributes $(TH.conT name)|]
489− [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]
490−
491− return $ [termDecl] ++ lensDecls ++
492− [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]
493−
494−distribPair :: Functor f => (a, f b) -> f (a, b)
495−distribPair (a, fb) = (a,) <$> fb
496−
497−-- | Get a local part of (possibly) fully qualified 'X.Name':
498−--
499−-- >>> xmlLocalName "{http://example.com/ns/my-namespace}my-name"
500−-- "my-name"
501−xmlLocalName :: String -> String
502−xmlLocalName = T.unpack . X.nameLocalName . fromString
131+import Data.THGen.Orphans ()
132+import Data.THGen.XML.Internal
133+import Data.Text
134+import Text.XML.Nillable
135+import qualified Prelude as P
src/Data/THGen/XML/Internal.hsnew file+457
@@ -0,0 +1,457 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE UndecidableInstances #-}
3+{-# LANGUAGE FunctionalDependencies #-}
4+
5+module Data.THGen.XML.Internal where
6+
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/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+9−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
@@ -30,8 +30,11 @@ source-repository head
3030library
3131 exposed-modules: Data.THGen.Enum
3232 , Data.THGen.XML
33+ , Data.THGen.XML.Internal
3334 , Text.XML.ParentAttributes
35+ , Text.XML.Nillable
3436 other-modules: Data.THGen.Compat
37+ , Data.THGen.Orphans
3538 , Text.XML.DOM.Parser.Internal.Content
3639 build-depends: QuickCheck >= 2.8
3740 , base >=4.8 && <5
@@ -39,17 +42,22 @@ library
3942 , deepseq
4043 , lens >= 4.13
4144 , mtl >= 2.2
45+ , scientific
4246 , semigroups >= 0.18
4347 , template-haskell >= 2.10
4448 , text >= 1.2
4549 , xml-conduit >= 1.0
4650 , xml-conduit-writer >= 0.1
4751
52+ ghc-options: -Wall
53+
4854 hs-source-dirs: src
4955
5056 default-language: Haskell2010
5157 default-extensions: CPP
58+ , DeriveTraversable
5259 , FlexibleInstances
60+ , GeneralizedNewtypeDeriving
5361 , LambdaCase
5462 , TemplateHaskell
5563 , TupleSections