git.iko.soy/typeable/xml-isogen
on 4c69be0 help sign in
e7de369
swap
0 ahead, 24 behind
17 files changed+163−657
since splitsnapshots
unifiedsplit
.gitignore−5 CHANGELOG.md−5 README.md+1−284 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+7−15 src/Data/THGen/XML/Internal.hs+147−221 src/Text/XML/Nillable.hs−41 stack-10.0.yaml−8 stack-18.18.yaml−9 stack-19.6.yaml−9 stack.yaml+3−8 test/TestDefs.hs+4−4 xml-isogen.cabal+1−8
.gitignore−5
@@ -3,8 +3,3 @@ 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,11 +1,6 @@
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−
940.3.0
105------
116
README.md+1−284
@@ -6,287 +6,4 @@ TemplateHaskell generators for XML-isomorphic data types, including
66instances for parsing and rendering. A convenient DSL to define those
77types.
88
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−```
9+This is similar to XSD but is Haskell-specific.
ghc-802.yaml−4
@@ -1,7 +1,3 @@
1−nix:
2− packages:
3− - zlib
4−
51resolver: lts-9.21
62
73packages:
ghc-822.yaml−4
@@ -1,5 +1 @@
1−nix:
2− packages:
3− - zlib
4−
51resolver: lts-11.22
ghc-844.yaml−4
@@ -1,7 +1,3 @@
1−nix:
2− packages:
3− - zlib
4−
51resolver: lts-12.16
62extra-deps:
73- dom-parser-3.1.0
shell.nixdeleted−17
@@ -1,17 +0,0 @@
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.hsdeleted−11
@@ -1,11 +0,0 @@
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+7−15
@@ -22,7 +22,7 @@ wrapper around the field type:
2222
2323Example 1.
2424
25−> "Color" =:= enum ParserAndGenerator
25+> "Color" =:= enum
2626> & "R"
2727> & "G"
2828> & "B"
@@ -40,7 +40,7 @@ to be either @R@, @G@ or @B@.
4040
4141Example 2.
4242
43−> "Message" =:= record ParserAndGenerator
43+> "Message" =:= record
4444> ! "author"
4545> + "recipient"
4646> ? "message" [t|Text|]
@@ -67,10 +67,10 @@ enumeration is exhaustive (contains only the listed constructors) or
6767non-exhaustive (also contains a constructor for unknown values; this
6868is the default):
6969
70−> "Enum1" Exhaustive =:= enum Generator
70+> "Enum1" Exhaustive =:= enum
7171> ...
7272
73−> "Enum2" NonExhaustive =:= enum Generator
73+> "Enum2" NonExhaustive =:= enum
7474> ...
7575
7676To define a record, use the `record` function followed by the name of
@@ -78,7 +78,7 @@ the data type to be generated. The prefix for the record fields is
7878inferred automatically by taking all of the uppercase letters in the
7979name. You can override it manually like so:
8080
81−> "Reference" "ref" =:= record Parser
81+> "Reference" "ref" =:= record
8282> ...
8383
8484To describe a record field you must supply its name as it appears
@@ -93,14 +93,10 @@ The type of the field is inferred automatically from its name, so
9393if the field is called @"author"@ its type will be @Author@. You can
9494override the type by specifying it in quasiquotes like so:
9595
96−> "Message" =:= record ParserAndGenerator
97−> ! "author" [t|Person|].
96+> "Message" =:= record
97+> ! "author" [t|Person|]
9898> ...
9999
100−Both @record@ and @enum@ take a @GenType@ argument which tells it to generate
101−generator, parser or both. It's being used to optimize compilation time by
102−skipping the unnecessary TH instance generation.
103−
104100-}
105101
106102
@@ -108,7 +104,6 @@ module Data.THGen.XML
108104 ( Exhaustiveness(..)
109105 , PrefixName(..)
110106 , ExhaustivenessName(..)
111− , GenType(..)
112107 , record
113108 , enum
114109 , (!)
@@ -124,12 +119,9 @@ module Data.THGen.XML
124119 , Text
125120 , P.Int
126121 , P.Integer
127− , Nillable(..)
128122 ) where
129123
130124import Data.THGen.Enum
131−import Data.THGen.Orphans ()
132125import Data.THGen.XML.Internal
133126import Data.Text
134−import Text.XML.Nillable
135127import qualified Prelude as P
src/Data/THGen/XML/Internal.hs+147−221
@@ -1,11 +1,10 @@
1−{-# LANGUAGE CPP #-}
21{-# LANGUAGE UndecidableInstances #-}
32{-# LANGUAGE FunctionalDependencies #-}
43
54module Data.THGen.XML.Internal where
65
76import Control.DeepSeq
8−import Control.Lens hiding (repeated, enum, (&), Strict)
7+import Control.Lens hiding (repeated, enum, (&))
98import Control.Lens.Internal.FieldTH (makeFieldOpticsForDec)
109import qualified Data.Char as C
1110import Data.List.NonEmpty (NonEmpty)
@@ -15,7 +14,7 @@ import Data.THGen.Compat as THC
1514import Data.THGen.Enum
1615import qualified Data.Text as T
1716import GHC.Generics (Generic)
18−import Language.Haskell.TH as TH hiding (Strict)
17+import Language.Haskell.TH as TH
1918import Prelude hiding ((+), (*), (^))
2019import qualified Text.XML as X
2120import Text.XML.DOM.Parser hiding (parseContent)
@@ -23,22 +22,6 @@ import Text.XML.DOM.Parser.Internal.Content
2322import Text.XML.ParentAttributes
2423import qualified Text.XML.Writer as XW
2524
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
4225
4326data XmlFieldPlural
4427 = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
@@ -69,7 +52,7 @@ data IsoXmlDescRecordPart
6952 | IsoXmlDescRecordAttribute IsoXmlDescAttribute
7053 | IsoXmlDescRecordContent IsoXmlDescContent
7154
72−data IsoXmlDescRecord = IsoXmlDescRecord GenType [IsoXmlDescRecordPart]
55+newtype IsoXmlDescRecord = IsoXmlDescRecord [IsoXmlDescRecordPart]
7356
7457makePrisms ''IsoXmlDescRecord
7558
@@ -81,7 +64,7 @@ newtype IsoXmlDescEnumCon
8164instance IsString IsoXmlDescEnumCon where
8265 fromString = IsoXmlDescEnumCon
8366
84−data IsoXmlDescEnum = IsoXmlDescEnum GenType [IsoXmlDescEnumCon]
67+data IsoXmlDescEnum = IsoXmlDescEnum [IsoXmlDescEnumCon]
8568
8669makePrisms ''IsoXmlDescEnum
8770
@@ -90,26 +73,26 @@ appendField
9073 -> IsoXmlDescRecord
9174 -> IsoXmlDescPreField
9275 -> IsoXmlDescRecord
93−appendField plural (IsoXmlDescRecord genType fields) (IsoXmlDescPreField name ty) =
76+appendField plural xrec (IsoXmlDescPreField name ty) =
9477 let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty
95− in IsoXmlDescRecord genType (xfield:fields)
78+ in over _IsoXmlDescRecord (xfield:) xrec
9679
9780appendAttribute
9881 :: XmlAttributePlural
9982 -> IsoXmlDescRecord
10083 -> IsoXmlDescPreAttribute
10184 -> IsoXmlDescRecord
102−appendAttribute plural (IsoXmlDescRecord genType fields) (IsoXmlDescPreAttribute name ty) =
85+appendAttribute plural xrec (IsoXmlDescPreAttribute name ty) =
10386 let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty
104− in IsoXmlDescRecord genType (xattribute:fields)
87+ in over _IsoXmlDescRecord (xattribute:) xrec
10588
10689appendContent
10790 :: IsoXmlDescRecord
10891 -> IsoXmlDescPreContent
10992 -> IsoXmlDescRecord
110−appendContent (IsoXmlDescRecord genType fields) (IsoXmlDescPreContent name ty) =
93+appendContent xrec (IsoXmlDescPreContent name ty) =
11194 let xcontent = IsoXmlDescRecordContent $ IsoXmlDescContent name ty
112− in IsoXmlDescRecord genType (xcontent:fields)
95+ in over _IsoXmlDescRecord (xcontent:) xrec
11396
11497(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
11598(!) = appendField XmlFieldPluralMandatory
@@ -133,8 +116,8 @@ infixl 2 ?%
133116infixl 2 ^
134117
135118appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
136−appendEnumCon (IsoXmlDescEnum genType enumCons) xenumcon =
137− IsoXmlDescEnum genType (xenumcon:enumCons)
119+appendEnumCon xenum xenumcon =
120+ over _IsoXmlDescEnum (xenumcon:) xenum
138121
139122(&) :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
140123(&) = appendEnumCon
@@ -147,20 +130,22 @@ class Description name desc | desc -> name where
147130infix 0 =:=
148131
149132instance Description PrefixName IsoXmlDescRecord where
150− prefixName =:= (IsoXmlDescRecord genType descRecordParts) =
151− isoXmlGenerateDatatype genType prefixName (reverse descRecordParts)
133+ prefixName =:= descRecord =
134+ let descRecordParts = descRecord ^. _IsoXmlDescRecord
135+ in isoXmlGenerateDatatype prefixName (reverse descRecordParts)
152136
153−record :: GenType -> IsoXmlDescRecord
154−record gt = IsoXmlDescRecord gt []
137+record :: IsoXmlDescRecord
138+record = IsoXmlDescRecord []
155139
156−enum :: GenType -> IsoXmlDescEnum
157−enum gt = IsoXmlDescEnum gt []
140+enum :: IsoXmlDescEnum
141+enum = IsoXmlDescEnum []
158142
159143instance Description ExhaustivenessName IsoXmlDescEnum where
160− exhaustivenessName =:= (IsoXmlDescEnum genType descEnumCons) =
161− isoXmlGenerateEnum genType exhaustivenessName (reverse descEnumCons)
144+ exhaustivenessName =:= descEnum =
145+ let descEnumCons = descEnum ^. _IsoXmlDescEnum
146+ in isoXmlGenerateEnum exhaustivenessName (reverse descEnumCons)
162147
163−instance (m ~ Q) => IsString (m TH.Type -> IsoXmlDescPreField) where
148+instance IsString (TH.TypeQ -> IsoXmlDescPreField) where
164149 fromString = IsoXmlDescPreField
165150
166151instance IsString IsoXmlDescPreField where
@@ -168,10 +153,10 @@ instance IsString IsoXmlDescPreField where
168153 where
169154 ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper (xmlLocalName name))
170155
171−instance (m ~ Q) => IsString (m TH.Type -> IsoXmlDescPreAttribute) where
156+instance IsString (TH.TypeQ -> IsoXmlDescPreAttribute) where
172157 fromString = IsoXmlDescPreAttribute
173158
174−instance (m ~ Q) => IsString (m Type -> IsoXmlDescPreContent) where
159+instance IsString (TH.TypeQ -> IsoXmlDescPreContent) where
175160 fromString = IsoXmlDescPreContent
176161
177162instance IsString IsoXmlDescPreAttribute where
@@ -197,77 +182,45 @@ instance IsString ExhaustivenessName where
197182 fromString strName = ExhaustivenessName strName NonExhaustive
198183
199184makeNamePrefix :: String -> String
200−makeNamePrefix = map C.toLower . filter (\c -> C.isUpper c || C.isDigit c)
185+makeNamePrefix = map C.toLower . filter C.isUpper
201186
202187funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ
203188funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]
204189
205190isoXmlGenerateEnum
206− :: GenType
207− -> ExhaustivenessName
208− -> [IsoXmlDescEnumCon]
209− -> TH.DecsQ
210−isoXmlGenerateEnum genType (ExhaustivenessName strName' exh) enumCons = do
191+ :: ExhaustivenessName -> [IsoXmlDescEnumCon] -> TH.DecsQ
192+isoXmlGenerateEnum (ExhaustivenessName strName' exh) enumCons = do
211193 let
212194 strName = "Xml" ++ strName'
213195 strVals = map unIsoXmlDescEnumCon enumCons
214196 enumDesc = EnumDesc exh strName strVals
215197 name = TH.mkName strName
216198 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
199+ toXmlInst <- do
200+ TH.instanceD
201+ (return [])
202+ [t|XW.ToXML $(TH.conT name)|]
203+ [funSimple 'XW.toXML [e|XW.toXML . T.pack . show|]]
204+ toXmlAttributeInst <- do
205+ TH.instanceD
206+ (return [])
207+ [t|ToXmlAttribute $(TH.conT name)|]
208+ [funSimple 'toXmlAttribute [e|T.pack . show|]]
209+ fromDomInst <- do
210+ TH.instanceD
211+ (return [])
212+ [t|FromDom $(TH.conT name)|]
213+ [funSimple 'fromDom [e|parseContent readContent|]]
214+ fromAttributeInst <- do
215+ TH.instanceD
216+ (return [])
217+ [t|FromAttribute $(TH.conT name)|]
218+ [funSimple 'fromAttribute [e|readContent|]]
219+ return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
220+ fromDomInst, fromAttributeInst]
221+
222+isoXmlGenerateDatatype :: PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ
223+isoXmlGenerateDatatype (PrefixName strName' strPrefix') descRecordParts = do
271224 let
272225 isNewtype = length descRecordParts == 1
273226 strName = "Xml" ++ strName'
@@ -284,14 +237,11 @@ isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts
284237 IsoXmlDescField fieldPlural rawName fieldType = descField
285238 fieldStrName = xmlLocalName rawName
286239 fName = TH.mkName (fieldName fieldStrName)
287− fType' = case fieldPlural of
240+ fType = case fieldPlural of
288241 XmlFieldPluralMandatory -> fieldType
289242 XmlFieldPluralOptional -> [t| Maybe $fieldType |]
290243 XmlFieldPluralRepeated -> [t| [$fieldType] |]
291244 XmlFieldPluralMultiplied -> [t| NonEmpty $fieldType |]
292− fType = if isLenientType genType
293− then [t| Maybe $fType' |]
294− else fType'
295245 in if isNewtype
296246 then THC.varStrictType fName (THC.nonStrictType fType)
297247 else THC.varStrictType fName (THC.strictType fType)
@@ -324,127 +274,103 @@ isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts
324274 (return [])
325275 [t|NFData $(TH.conT name)|]
326276 [ ]
277+ fromDomInst <- do
278+ let
279+ exprHeader = [e|pure $(TH.conE name)|]
280+ exprRecordParts = do
281+ descRecordPart <- descRecordParts
282+ return $ case descRecordPart of
283+ IsoXmlDescRecordField descField ->
284+ let
285+ IsoXmlDescField fieldPlural rawName _ = descField
286+ fieldStrName = xmlLocalName rawName
287+ exprFieldStrName = TH.litE (TH.stringL fieldStrName)
288+ fieldParse = case fieldPlural of
289+ XmlFieldPluralMandatory -> [e|inElem|]
290+ _ -> [e|inElemTrav|]
291+ in
292+ [e|$fieldParse $exprFieldStrName fromDom|]
293+ IsoXmlDescRecordAttribute descAttribute ->
294+ let
295+ IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute
296+ exprAttributeStrName = TH.litE (TH.stringL attributeStrName)
297+ attributeParse = case attributePlural of
298+ XmlAttributePluralMandatory -> [e|parseAttribute|]
299+ XmlAttributePluralOptional -> [e|parseAttributeMaybe|]
300+ in
301+ [e|$attributeParse $exprAttributeStrName fromAttribute|]
302+ IsoXmlDescRecordContent _ -> [e|parseContent fromAttribute|]
303+ fromDomExpr = foldl (\e fe -> [e| $e <*> $fe |]) exprHeader exprRecordParts
304+ TH.instanceD
305+ (return [])
306+ [t|FromDom $(TH.conT name)|]
307+ [ funSimple 'fromDom fromDomExpr ]
327308
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)|]
309+ toXmlInst <- do
310+ objName <- TH.newName strPrefix
311+ let
312+ exprFields = do
313+ descRecordPart <- descRecordParts
314+ case descRecordPart of
315+ IsoXmlDescRecordField (IsoXmlDescField fieldPlural rawName _) -> do
316+ let
317+ fieldStrName = xmlLocalName rawName
318+ fName = TH.mkName (fieldName fieldStrName)
319+ exprFieldStrName = TH.litE (TH.stringL rawName)
320+ exprForField = case fieldPlural of
321+ XmlFieldPluralMandatory -> [e|id|]
322+ _ -> [e|traverse|]
323+ exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
324+ exprFieldRender =
325+ [e|(\a ->
326+ XW.elementA $exprFieldStrName (toXmlParentAttributes a) a)|]
327+ return [e|$exprForField $exprFieldRender $exprFieldValue|]
328+ IsoXmlDescRecordContent (IsoXmlDescContent rawName _) -> do
329+ let
330+ fieldStrName = xmlLocalName rawName
331+ fName = TH.mkName (fieldName fieldStrName)
332+ exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
333+ return [e|XW.content . toXmlAttribute $ $exprFieldValue|]
334+ _ -> []
335+ toXmlExpr
336+ = TH.lamE [if null exprFields then TH.wildP else TH.varP objName]
337+ $ foldr (\fe e -> [e|$fe *> $e|]) [e|return ()|] exprFields
338+ TH.instanceD
339+ (return [])
340+ [t|XW.ToXML $(TH.conT name)|]
341+ [funSimple 'XW.toXML toXmlExpr]
342+
343+ toXmlParentAttributesInst <- do
344+ objName <- TH.newName strPrefix
345+ let
346+ exprAttributes = do
347+ descRecordPart <- descRecordParts
348+ IsoXmlDescAttribute attributePlural attributeStrName _ <-
349+ maybeToList $ case descRecordPart of
350+ IsoXmlDescRecordAttribute descAttribute -> Just descAttribute
351+ _ -> Nothing
352+ let
353+ fName = TH.mkName (fieldName attributeStrName)
354+ exprAttrStrName = TH.litE (TH.stringL attributeStrName)
355+ exprAttrValue = [e|$(TH.varE fName) $(TH.varE objName)|]
356+ exprAttrWrap = case attributePlural of
357+ XmlAttributePluralMandatory -> [e|Just . toXmlAttribute|]
358+ XmlAttributePluralOptional -> [e|fmap toXmlAttribute|]
359+ return [e|($exprAttrStrName, $exprAttrWrap $exprAttrValue)|]
360+ toXmlParentAttributesExpr
361+ = TH.lamE [if null exprAttributes then TH.wildP else TH.varP objName]
362+ $ [e|mapMaybe distribPair $(TH.listE exprAttributes)|]
415363#if __GLASGOW_HASKELL__ < 800
416− TH.instanceD
364+ TH.instanceD
417365#else
418− TH.instanceWithOverlapD (Just TH.Overlapping)
366+ TH.instanceWithOverlapD (Just TH.Overlapping)
419367#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]
368+ (return [])
369+ [t|ToXmlParentAttributes $(TH.conT name)|]
370+ [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]
371+
372+ return $ [termDecl] ++ lensDecls ++
373+ [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]
448374
449375distribPair :: Functor f => (a, f b) -> f (a, b)
450376distribPair (a, fb) = (a,) <$> fb
src/Text/XML/Nillable.hsdeleted−41
@@ -1,41 +0,0 @@
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.yamldeleted−8
@@ -1,8 +0,0 @@
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.yamldeleted−9
@@ -1,9 +0,0 @@
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.yamldeleted−9
@@ -1,9 +0,0 @@
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+3−8
@@ -1,9 +1,4 @@
1−nix:
2− packages:
3− - zlib
4−
5−resolver: lts-20.16
1+resolver: lts-10.0
62extra-deps:
7− - git: https://github.com/typeable/dom-parser.git
8− commit: 7d556ba528bfa216e99714f8a0d4d00f452803a9
9− - xml-lens-0.3.1
3+- dom-parser-3.0.0
4+- generic-arbitrary-0.1.0
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 ParserAndGenerator
12+"Bar" =:= enum
1313 & "baroque"
1414 & "bartender"
1515
16−"Quux" Exhaustive =:= enum ParserAndGenerator
16+"Quux" Exhaustive =:= enum
1717 & "ALL"
1818 & "YOUR"
1919 & "BASE"
@@ -22,14 +22,14 @@ import Test.QuickCheck.Instances ()
2222 & "TO"
2323 & "US"
2424
25−"Foo" =:= record ParserAndGenerator
25+"Foo" =:= record
2626 ^ "Shmuux" [t|XmlQuux|]
2727 + "Bar"
2828 ? "Baz" [t|Text|]
2929 !% "Quux"
3030 ?% "Muux" [t|XmlQuux|]
3131
32−"Root" =:= record ParserAndGenerator
32+"Root" =:= record
3333 ! "{http://example.com/ns/my-namespace}Foo"
3434
3535instance Arbitrary XmlRoot where
xml-isogen.cabal+1−8
@@ -1,5 +1,5 @@
11name: xml-isogen
2−version: 0.3.2
2+version: 0.3.1
33synopsis: Generate XML-isomorphic types
44description:
55 TemplateHaskell generators for XML-isomorphic data types, including
@@ -32,9 +32,7 @@ library
3232 , Data.THGen.XML
3333 , Data.THGen.XML.Internal
3434 , Text.XML.ParentAttributes
35− , Text.XML.Nillable
3635 other-modules: Data.THGen.Compat
37− , Data.THGen.Orphans
3836 , Text.XML.DOM.Parser.Internal.Content
3937 build-depends: QuickCheck >= 2.8
4038 , base >=4.8 && <5
@@ -42,22 +40,17 @@ library
4240 , deepseq
4341 , lens >= 4.13
4442 , mtl >= 2.2
45− , scientific
4643 , semigroups >= 0.18
4744 , template-haskell >= 2.10
4845 , text >= 1.2
4946 , xml-conduit >= 1.0
5047 , xml-conduit-writer >= 0.1
5148
52− ghc-options: -Wall
53−
5449 hs-source-dirs: src
5550
5651 default-language: Haskell2010
5752 default-extensions: CPP
58− , DeriveTraversable
5953 , FlexibleInstances
60− , GeneralizedNewtypeDeriving
6154 , LambdaCase
6255 , TemplateHaskell
6356 , TupleSections