git.iko.soy/typeable/xml-isogen
on master help sign in
swap
e7de36940 ahead, 0 behind
20 files changed+958−366
since splitsnapshots
unifiedsplit
.gitignore+5 .travis.yml+2−1 CHANGELOG.md+15 README.md+284−1 ghc-802.yaml+5−1 ghc-822.yaml+5 ghc-844.yaml+7 shell.nix+17 src/Data/THGen/Enum.hs+10−2 src/Data/THGen/Orphans.hs+11 src/Data/THGen/XML.hs+23−343 src/Data/THGen/XML/Internal.hs+457 src/Text/XML/DOM/Parser/Internal/Content.hs+28 src/Text/XML/Nillable.hs+41 ghc-821.yaml → stack-10.0.yaml+4−4 stack-18.18.yaml+9 stack-19.6.yaml+9 stack.yaml+7−6 test/TestDefs.hs+7−6 xml-isogen.cabal+12−2
.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
.travis.yml+2−1
@@ -5,7 +5,8 @@ language: generic
55env:
66 - STACK_YAML=stack.yaml
77 - STACK_YAML=ghc-802.yaml
8− - STACK_YAML=ghc-821.yaml
8+ - STACK_YAML=ghc-822.yaml
9+ - STACK_YAML=ghc-844.yaml
910
1011cache:
1112 directories:
CHANGELOG.md+15
@@ -1,3 +1,18 @@
1+HEAD
2+------
3+
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+
9+0.3.0
10+------
11+
12+* Add namespaces support
13+* Builds with GHC 8.4
14+* Derive NFData for all generated datatypes
15+
1160.2.1
217------
318
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+5−1
@@ -1,4 +1,8 @@
1−resolver: lts-9.0
1+nix:
2+ packages:
3+ - zlib
4+
5+resolver: lts-9.21
26
37packages:
48- .
ghc-822.yamlnew file+5
@@ -0,0 +1,5 @@
1+nix:
2+ packages:
3+ - zlib
4+
5+resolver: lts-11.22
ghc-844.yamlnew file+7
@@ -0,0 +1,7 @@
1+nix:
2+ packages:
3+ - zlib
4+
5+resolver: lts-12.16
6+extra-deps:
7+- 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/Enum.hs+10−2
@@ -25,14 +25,17 @@ module Data.THGen.Enum
2525 ) where
2626
2727import Control.Applicative
28+import Control.DeepSeq
2829import Control.Lens (over, _head, (<&>))
2930import Control.Monad
3031import qualified Data.Char as C
3132import Data.THGen.Compat
33+import GHC.Generics (Generic)
3234import qualified Language.Haskell.TH as TH
3335import qualified Test.QuickCheck as QC
3436import qualified Text.Read as R
3537
38+
3639data Exhaustiveness = Exhaustive | NonExhaustive
3740 deriving (Eq, Ord, Show)
3841
@@ -79,7 +82,7 @@ enumGenerate (EnumDesc exh strName strVals) = do
7982 dataD
8083 name
8184 (constrs ++ unknownConstr)
82− ([''Eq, ''Ord] ++ if (exh == Exhaustive) then [''Enum, ''Bounded] else [])
85+ ([''Eq, ''Ord, ''Generic] ++ if (exh == Exhaustive) then [''Enum, ''Bounded] else [])
8386 showInstDecl <- do
8487 unknownMatch <- case exh of
8588 Exhaustive -> return []
@@ -126,4 +129,9 @@ enumGenerate (EnumDesc exh strName strVals) = do
126129 (return [])
127130 [t|QC.Arbitrary $(TH.conT name)|]
128131 [funSimple 'QC.arbitrary arbExpr]
129− return [dataDecl, readInstDecl, showInstDecl, arbInstance]
132+ nfDataInst <- do
133+ TH.instanceD
134+ (return [])
135+ [t|NFData $(TH.conT name)|]
136+ []
137+ return [dataDecl, readInstDecl, showInstDecl, arbInstance, nfDataInst]
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+23−343
@@ -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 , (!)
@@ -114,342 +118,18 @@ module Data.THGen.XML
114118 , (!%)
115119 , (?%)
116120 , (&)
121+ , (^)
117122 , (=:=)
118123 -- Re-exports
119− , T.Text
120− , Int
121− , Integer
124+ , Text
125+ , P.Int
126+ , P.Integer
127+ , Nillable(..)
122128 ) where
123129
124−import Control.DeepSeq
125−import Control.Lens hiding (repeated, enum, (&))
126−import Control.Lens.Internal.FieldTH (makeFieldOpticsForDec)
127−import qualified Data.Char as C
128−import Data.List.NonEmpty (NonEmpty)
129−import Data.Maybe (maybeToList, mapMaybe)
130−import Data.String
131−import Data.THGen.Compat
132130import Data.THGen.Enum
133−import qualified Data.Text as T
134−import GHC.Generics (Generic)
135−import qualified Language.Haskell.TH as TH
136−import qualified Language.Haskell.TH.Syntax as TH
137−import Prelude hiding ((+), (*))
138−import qualified Text.XML as X
139−import Text.XML.DOM.Parser
140−import Text.XML.ParentAttributes
141−import qualified Text.XML.Writer as XW
142−
143−
144−data XmlFieldPlural
145− = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
146− | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)
147− | XmlFieldPluralRepeated -- Occurs 0 or more times (List)
148− | XmlFieldPluralMultiplied -- Occurs 1 or more times (NonEmpty)
149−
150−data XmlAttributePlural
151− = XmlAttributePluralMandatory -- Occurs exactly 1 time (Identity)
152− | XmlAttributePluralOptional -- Occurs 0 or 1 times (Maybe)
153−
154−data PrefixName = PrefixName String String
155−
156−data IsoXmlDescPreField = IsoXmlDescPreField String TH.TypeQ
157−
158−data IsoXmlDescPreAttribute = IsoXmlDescPreAttribute String TH.TypeQ
159−
160−data IsoXmlDescField = IsoXmlDescField XmlFieldPlural String TH.TypeQ
161−
162−data IsoXmlDescAttribute = IsoXmlDescAttribute XmlAttributePlural String TH.TypeQ
163−
164−data IsoXmlDescRecordPart
165− = IsoXmlDescRecordField IsoXmlDescField
166− | IsoXmlDescRecordAttribute IsoXmlDescAttribute
167−
168−newtype IsoXmlDescRecord = IsoXmlDescRecord [IsoXmlDescRecordPart]
169−
170−makePrisms ''IsoXmlDescRecord
171−
172−data ExhaustivenessName = ExhaustivenessName String Exhaustiveness
173−
174−newtype IsoXmlDescEnumCon
175− = IsoXmlDescEnumCon { unIsoXmlDescEnumCon :: String }
176−
177−instance IsString IsoXmlDescEnumCon where
178− fromString = IsoXmlDescEnumCon
179−
180−data IsoXmlDescEnum = IsoXmlDescEnum [IsoXmlDescEnumCon]
181−
182−makePrisms ''IsoXmlDescEnum
183−
184−appendField
185− :: XmlFieldPlural
186− -> IsoXmlDescRecord
187− -> IsoXmlDescPreField
188− -> IsoXmlDescRecord
189−appendField plural xrec (IsoXmlDescPreField name ty) =
190− let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty
191− in over _IsoXmlDescRecord (xfield:) xrec
192−
193−appendAttribute
194− :: XmlAttributePlural
195− -> IsoXmlDescRecord
196− -> IsoXmlDescPreAttribute
197− -> IsoXmlDescRecord
198−appendAttribute plural xrec (IsoXmlDescPreAttribute name ty) =
199− let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty
200− in over _IsoXmlDescRecord (xattribute:) xrec
201−
202−(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
203−(!) = appendField XmlFieldPluralMandatory
204−(?) = appendField XmlFieldPluralOptional
205−(*) = appendField XmlFieldPluralRepeated
206−(+) = appendField XmlFieldPluralMultiplied
207−
208−(!%), (?%) :: IsoXmlDescRecord -> IsoXmlDescPreAttribute -> IsoXmlDescRecord
209−(!%) = appendAttribute XmlAttributePluralMandatory
210−(?%) = appendAttribute XmlAttributePluralOptional
211−
212−infixl 2 !
213−infixl 2 ?
214−infixl 2 *
215−infixl 2 +
216−infixl 2 !%
217−infixl 2 ?%
218−
219−appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
220−appendEnumCon xenum xenumcon =
221− over _IsoXmlDescEnum (xenumcon:) xenum
222−
223−(&) :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
224−(&) = appendEnumCon
225−
226−infixl 2 &
227−
228−class Description name desc | desc -> name where
229− (=:=) :: name -> desc -> TH.DecsQ
230−
231−infix 0 =:=
232−
233−instance Description PrefixName IsoXmlDescRecord where
234− prefixName =:= descRecord =
235− let descRecordParts = descRecord ^. _IsoXmlDescRecord
236− in isoXmlGenerateDatatype prefixName (reverse descRecordParts)
237−
238−record :: IsoXmlDescRecord
239−record = IsoXmlDescRecord []
240−
241−enum :: IsoXmlDescEnum
242−enum = IsoXmlDescEnum []
243−
244−instance Description ExhaustivenessName IsoXmlDescEnum where
245− exhaustivenessName =:= descEnum =
246− let descEnumCons = descEnum ^. _IsoXmlDescEnum
247− in isoXmlGenerateEnum exhaustivenessName (reverse descEnumCons)
248−
249−instance IsString (TH.TypeQ -> IsoXmlDescPreField) where
250− fromString = IsoXmlDescPreField
251−
252−instance IsString IsoXmlDescPreField where
253− fromString name = IsoXmlDescPreField name ty
254− where
255− ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)
256−
257−instance IsString (TH.TypeQ -> IsoXmlDescPreAttribute) where
258− fromString = IsoXmlDescPreAttribute
259−
260−instance IsString IsoXmlDescPreAttribute where
261− fromString name = IsoXmlDescPreAttribute name ty
262− where
263− ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)
264−
265−instance s ~ String => IsString (s -> PrefixName) where
266− fromString = PrefixName
267−
268−instance IsString PrefixName where
269− fromString strName = PrefixName strName (makeNamePrefix strName)
270−
271−instance e ~ Exhaustiveness => IsString (e -> ExhaustivenessName) where
272− fromString = ExhaustivenessName
273−
274−instance IsString ExhaustivenessName where
275− fromString strName = ExhaustivenessName strName NonExhaustive
276−
277−makeNamePrefix :: String -> String
278−makeNamePrefix = map C.toLower . filter C.isUpper
279−
280−funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ
281−funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]
282−
283−isoXmlGenerateEnum
284− :: ExhaustivenessName -> [IsoXmlDescEnumCon] -> TH.DecsQ
285−isoXmlGenerateEnum (ExhaustivenessName strName' exh) enumCons = do
286− let
287− strName = "Xml" ++ strName'
288− strVals = map unIsoXmlDescEnumCon enumCons
289− enumDesc = EnumDesc exh strName strVals
290− name = TH.mkName strName
291− enumDecls <- enumGenerate enumDesc
292− toXmlInst <- do
293− TH.instanceD
294− (return [])
295− [t|XW.ToXML $(TH.conT name)|]
296− [funSimple 'XW.toXML [e|XW.toXML . T.pack . show|]]
297− toXmlAttributeInst <- do
298− TH.instanceD
299− (return [])
300− [t|ToXmlAttribute $(TH.conT name)|]
301− [funSimple 'toXmlAttribute [e|T.pack . show|]]
302− fromDomInst <- do
303− TH.instanceD
304− (return [])
305− [t|FromDom $(TH.conT name)|]
306− [funSimple 'fromDom [e|parseContent readContent|]]
307− fromAttributeInst <- do
308− TH.instanceD
309− (return [])
310− [t|FromAttribute $(TH.conT name)|]
311− [funSimple 'fromAttribute [e|readContent|]]
312− return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
313− fromDomInst, fromAttributeInst]
314−
315−isoXmlGenerateDatatype :: PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ
316−isoXmlGenerateDatatype (PrefixName strName' strPrefix') descRecordParts = do
317− let
318− isNewtype = length descRecordParts == 1
319− strName = "Xml" ++ strName'
320− strPrefix = "x" ++ strPrefix'
321− name = TH.mkName strName
322− fieldName str = "_" ++ strPrefix ++ over _head C.toUpper str
323− termDecl <- do
324− let
325− fields = do
326− descRecordPart <- descRecordParts
327− return $ case descRecordPart of
328− IsoXmlDescRecordField descField ->
329− let
330− IsoXmlDescField fieldPlural fieldStrName fieldType = descField
331− fName = TH.mkName (fieldName fieldStrName)
332− fType = case fieldPlural of
333− XmlFieldPluralMandatory -> fieldType
334− XmlFieldPluralOptional -> [t| Maybe $fieldType |]
335− XmlFieldPluralRepeated -> [t| [$fieldType] |]
336− XmlFieldPluralMultiplied -> [t| NonEmpty $fieldType |]
337− in if isNewtype
338− then varStrictType fName (nonStrictType fType)
339− else varStrictType fName (strictType fType)
340− IsoXmlDescRecordAttribute descAttribute ->
341− let
342− IsoXmlDescAttribute
343− attributePlural attributeStrName attributeType = descAttribute
344− fName = TH.mkName (fieldName attributeStrName)
345− fType = case attributePlural of
346− XmlAttributePluralMandatory -> attributeType
347− XmlAttributePluralOptional -> [t| Maybe $attributeType |]
348− in
349− varStrictType fName (strictType fType)
350− dataD
351− name
352− [TH.recC name fields]
353− [''Eq, ''Show, ''Generic]
354− lensDecls <- makeFieldOpticsForDec lensRules dataDecl
355− nfDataInst <- do
356− TH.instanceD
357− (return [])
358− [t|NFData $(TH.conT name)|]
359− [ ]
360− if isNewtype
361− -- generate a newtype instead to do less allocations later
362− then newtypeD name (TH.recC name fields) [''Eq, ''Show]
363− else dataD name [TH.recC name fields] [''Eq, ''Show]
364− lensDecls <- makeFieldOpticsForDec lensRules termDecl
365− fromDomInst <- do
366− let
367− exprHeader = [e|pure $(TH.conE name)|]
368− exprRecordParts = do
369− descRecordPart <- descRecordParts
370− return $ case descRecordPart of
371− IsoXmlDescRecordField descField ->
372− let
373− IsoXmlDescField fieldPlural fieldStrName _ = descField
374− exprFieldStrName = TH.litE (TH.stringL fieldStrName)
375− fieldParse = case fieldPlural of
376− XmlFieldPluralMandatory -> [e|inElem|]
377− _ -> [e|inElemTrav|]
378− in
379− [e|$fieldParse $exprFieldStrName fromDom|]
380− IsoXmlDescRecordAttribute descAttribute ->
381− let
382− IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute
383− exprAttributeStrName = TH.litE (TH.stringL attributeStrName)
384− attributeParse = case attributePlural of
385− XmlAttributePluralMandatory -> [e|parseAttribute|]
386− XmlAttributePluralOptional -> [e|parseAttributeMaybe|]
387− in
388− [e|$attributeParse $exprAttributeStrName fromAttribute|]
389− fromDomExpr = foldl (\e fe -> [e| $e <*> $fe |]) exprHeader exprRecordParts
390− TH.instanceD
391− (return [])
392− [t|FromDom $(TH.conT name)|]
393− [ funSimple 'fromDom fromDomExpr ]
394−
395− toXmlInst <- do
396− objName <- TH.newName strPrefix
397− let
398− exprFields = do
399− descRecordPart <- descRecordParts
400− IsoXmlDescField fieldPlural fieldStrName _ <-
401− maybeToList $ case descRecordPart of
402− IsoXmlDescRecordField descField -> Just descField
403− _ -> Nothing
404− let
405− fName = TH.mkName (fieldName fieldStrName)
406− exprFieldStrName = TH.litE (TH.stringL fieldStrName)
407− exprForField = case fieldPlural of
408− XmlFieldPluralMandatory -> [e|id|]
409− _ -> [e|traverse|]
410− exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
411− exprFieldRender =
412− [e|(\a -> XW.elementA $exprFieldStrName (toXmlParentAttributes a) a)|]
413− return [e|$exprForField $exprFieldRender $exprFieldValue|]
414− toXmlExpr
415− = TH.lamE [if null exprFields then TH.wildP else TH.varP objName]
416− $ foldr (\fe e -> [e|$fe *> $e|]) [e|return ()|] exprFields
417− TH.instanceD
418− (return [])
419− [t|XW.ToXML $(TH.conT name)|]
420− [funSimple 'XW.toXML toXmlExpr]
421−
422− toXmlParentAttributesInst <- do
423− objName <- TH.newName strPrefix
424− let
425− exprAttributes = do
426− descRecordPart <- descRecordParts
427− IsoXmlDescAttribute attributePlural attributeStrName _ <-
428− maybeToList $ case descRecordPart of
429− IsoXmlDescRecordAttribute descAttribute -> Just descAttribute
430− _ -> Nothing
431− let
432− fName = TH.mkName (fieldName attributeStrName)
433− exprAttrStrName = TH.litE (TH.stringL attributeStrName)
434− exprAttrValue = [e|$(TH.varE fName) $(TH.varE objName)|]
435− exprAttrWrap = case attributePlural of
436− XmlAttributePluralMandatory -> [e|Just . toXmlAttribute|]
437− XmlAttributePluralOptional -> [e|fmap toXmlAttribute|]
438− return [e|($exprAttrStrName, $exprAttrWrap $exprAttrValue)|]
439− toXmlParentAttributesExpr
440− = TH.lamE [if null exprAttributes then TH.wildP else TH.varP objName]
441− $ [e|mapMaybe distribPair $(TH.listE exprAttributes)|]
442−#if __GLASGOW_HASKELL__ < 800
443− TH.instanceD
444−#else
445− TH.instanceWithOverlapD (Just TH.Overlapping)
446−#endif
447− (return [])
448− [t|ToXmlParentAttributes $(TH.conT name)|]
449− [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]
450−
451− return $ [termDecl] ++ lensDecls ++
452− [fromDomInst, toXmlInst, toXmlParentAttributesInst]
453−
454−distribPair :: Functor f => (a, f b) -> f (a, b)
455−distribPair (a, fb) = (a,) <$> fb
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/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)
8+
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 #-}
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
ghc-821.yaml → stack-10.0.yamlrenamed+4−4
@@ -1,8 +1,8 @@
1−resolver: nightly-2017-09-14
2−
3−packages:
4−- .
1+nix:
2+ packages:
3+ - zlib
54
5+resolver: lts-10.0
66extra-deps:
77- dom-parser-3.0.0
88- 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+7−6
@@ -1,8 +1,9 @@
1−resolver: lts-6.35
2−
3−packages:
4−- .
1+nix:
2+ packages:
3+ - zlib
54
5+resolver: lts-20.16
66extra-deps:
7−- dom-parser-3.0.0
8−- 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+7−6
@@ -4,16 +4,16 @@
44
55module TestDefs where
66
7−import Data.List.NonEmpty
7+-- import Data.List.NonEmpty
88import 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,15 @@ import Test.QuickCheck.Instances ()
2222 & "TO"
2323 & "US"
2424
25−"Foo" =:= record
25+"Foo" =:= record ParserAndGenerator
26+ ^ "Shmuux" [t|XmlQuux|]
2627 + "Bar"
2728 ? "Baz" [t|Text|]
2829 !% "Quux"
2930 ?% "Muux" [t|XmlQuux|]
3031
31−"Root" =:= record
32− ! "Foo"
32+"Root" =:= record ParserAndGenerator
33+ ! "{http://example.com/ns/my-namespace}Foo"
3334
3435instance Arbitrary XmlRoot where
3536 arbitrary = genericArbitrary
xml-isogen.cabal+12−2
@@ -1,5 +1,5 @@
11name: xml-isogen
2−version: 0.2.1
2+version: 0.3.2
33synopsis: Generate XML-isomorphic types
44description:
55 TemplateHaskell generators for XML-isomorphic data types, including
@@ -18,7 +18,8 @@ cabal-version: >=1.22
1818homepage: https://github.com/typeable/xml-isogen
1919tested-with: GHC == 7.10.3
2020 , GHC == 8.0.2
21− , GHC == 8.2.1
21+ , GHC == 8.2.2
22+ , GHC == 8.4.1
2223extra-source-files: CHANGELOG.md
2324 , README.md
2425
@@ -29,25 +30,34 @@ source-repository head
2930library
3031 exposed-modules: Data.THGen.Enum
3132 , Data.THGen.XML
33+ , Data.THGen.XML.Internal
3234 , Text.XML.ParentAttributes
35+ , Text.XML.Nillable
3336 other-modules: Data.THGen.Compat
37+ , Data.THGen.Orphans
38+ , Text.XML.DOM.Parser.Internal.Content
3439 build-depends: QuickCheck >= 2.8
3540 , base >=4.8 && <5
3641 , dom-parser >= 2.0.0
3742 , deepseq
3843 , lens >= 4.13
3944 , mtl >= 2.2
45+ , scientific
4046 , semigroups >= 0.18
4147 , template-haskell >= 2.10
4248 , text >= 1.2
4349 , xml-conduit >= 1.0
4450 , xml-conduit-writer >= 0.1
4551
52+ ghc-options: -Wall
53+
4654 hs-source-dirs: src
4755
4856 default-language: Haskell2010
4957 default-extensions: CPP
58+ , DeriveTraversable
5059 , FlexibleInstances
60+ , GeneralizedNewtypeDeriving
5161 , LambdaCase
5262 , TemplateHaskell
5363 , TupleSections