git.iko.soy/typeable/xml-isogen
on master help sign in
swap
e7de36947 ahead, 0 behind
.gitignore+5
since splitsnapshots
unifiedsplit
@@ -3,3 +3,8 @@ dist
3.stack-work
3.stack-work
4.cabal-sandbox/
4.cabal-sandbox/
5cabal.sandbox.config
5cabal.sandbox.config
6+dist-newstyle/
7+default.nix
8+# vim backup and swap files
9+*~
10+.*.swp
.travis.yml+2−1
@@ -5,7 +5,8 @@ language: generic
5env:
5env:
6 - STACK_YAML=stack.yaml
6 - STACK_YAML=stack.yaml
7 - STACK_YAML=ghc-802.yaml
7 - STACK_YAML=ghc-802.yaml
8− - STACK_YAML=ghc-821.yaml
8+ - STACK_YAML=ghc-822.yaml
9+ - STACK_YAML=ghc-844.yaml
9
10
10cache:
11cache:
11 directories:
12 directories:
CHANGELOG.md+16−1
@@ -1,7 +1,22 @@
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+
10.2.1
160.2.1
2------
17------
3
18
4−* Workaround bug in 8.2.1: attributes generation did not work on 8.2.1 only
19+* Workaround for the GHC 8.2.1 attribute generation bug
5
20
6* Add tests checking run-time behaviour of generated code
21* Add tests checking run-time behaviour of generated code
7
22
README.md+284−1
@@ -6,4 +6,287 @@ TemplateHaskell generators for XML-isomorphic data types, including
6instances for parsing and rendering. A convenient DSL to define those
6instances for parsing and rendering. A convenient DSL to define those
7types.
7types.
8
8
9−This is similar to XSD but is Haskell-specific.
9+Essentially it's a haskell DSL which allows its users to generate XML parsers and generators for haskell datatypes.
10+See also [xsd-isogen](https://github.com/typeable/xsd-isogen)
11+
12+## Tutorial
13+
14+Lets go through series of examples. First things first:
15+
16+```haskell
17+{-# LANGUAGE TemplateHaskell #-}
18+{-# LANGUAGE OverloadedStrings #-}
19+{-# LANGUAGE DeriveGeneric #-}
20+
21+module Tutorial
22+where
23+
24+import Prelude hiding ((^))
25+import Control.DeepSeq -- from deepseq
26+import Data.Text
27+import Data.THGen.XML -- from xml-isogen
28+import Text.XML.Writer -- from xml-conduit-writer
29+import Text.XML.DOM.Parser -- from dom-parser
30+```
31+
32+### Records
33+
34+Lets say we want to parse and/or generate an XML file of the following form:
35+
36+```XML
37+<?xml version="1.0" encoding="UTF-8"?>
38+<person>
39+ <name>
40+ John
41+ </name>
42+ <email>
43+ john@example.com
44+ </email>
45+</person>
46+```
47+
48+Person has a name and an email, and email could be omitted. With `xml-isogen` it's
49+enough to write the following definition:
50+
51+```haskell
52+"Person" =:= record ParserAndGenerator
53+ ! "name" [t|Text|]
54+ ? "email" [t|Text|]
55+```
56+
57+At this point you can load the module into `ghci` and check what was generated for us
58+so far:
59+
60+```
61+*Tutorial> :browse
62+data XmlPerson
63+ = XmlPerson {_xpName :: !Text, _xpEmail :: !(Maybe Text)}
64+xpEmail ::
65+ lens-4.18.1:Control.Lens.Type.Lens' XmlPerson (Maybe Text)
66+xpName :: lens-4.18.1:Control.Lens.Type.Lens' XmlPerson Text
67+```
68+
69+We have a data type `XmlPerson` with two fields and two lenses. Note that the
70+fields have a prefix built of an underscore and all upper case characters
71+and digits of the type name.
72+
73+
74+Lets take a closer look at `XmlPerson`:
75+
76+```
77+*Tutorial> :i XmlPerson
78+data XmlPerson
79+ = XmlPerson {_xpName :: !Text, _xpEmail :: !(Maybe Text)}
80+ -- Defined at Tutorial.hs:13:1
81+instance Show XmlPerson -- Defined at Tutorial.hs:13:1
82+instance Eq XmlPerson -- Defined at Tutorial.hs:13:1
83+instance FromDom XmlPerson -- Defined at Tutorial.hs:13:1
84+instance ToXML XmlPerson -- Defined at Tutorial.hs:13:1
85+
86+```
87+
88+We have
89+[FromDom](https://hackage.haskell.org/package/dom-parser-3.1.0/docs/Text-XML-DOM-Parser-FromDom.html#t:FromDom)
90+and
91+[ToXML](https://hackage.haskell.org/package/xml-conduit-writer-0.1.1.2/docs/Text-XML-Writer.html#t:ToXML)
92+instance generated for us. That's because
93+we instructed `xml-isogen` to generate them using the `ParserAndGenerator` noun. You can specify
94+also `Parser` or `Generator` if you want only one of them.
95+
96+The `_xpEmail` field is optional; that's because we prefixed it with `?` modifier.
97+Here is the list of possible modifiers that affect types:
98+
99+Modifier | Description | Generated Type
100+--- | --- | ---
101+`!` | required | `a`
102+`?` | optional | `Maybe a`
103+`*` | repeated | `[a]`
104+`+` | nonempty | `NonEmpty a`
105+
106+### Supported types
107+
108+Fields in a record may have any types as long as they are instances of `Eq`, `Show`,
109+`NFData`, `FromDom` (for the parser) and `ToXml` (for the generator). Remember
110+though that TemplateHaskell requires types to be available before they are used
111+in a splice.
112+
113+You can omit field types altogether, in that case the type will be assumed to be a
114+capitalized field name with an `Xml` prefix.
115+It's your responsibility to make sure that type exists.
116+Example:
117+
118+```haskell
119+newtype XmlEmail = XmlEmail Text
120+ deriving (Eq, Show, NFData, ToXML)
121+
122+instance FromDom XmlEmail where
123+ fromDom = XmlEmail <$> fromDom
124+
125+"Example1" =:= record Parser
126+ ! "email" -- will have type XmlEmail
127+```
128+
129+### Enumerations
130+
131+Often XML element can contain only limited number of possible values. Lets define
132+a type `Status` that can have only values `Active`, `Pending` or `Deleted`:
133+
134+```haskell
135+"Status" =:= enum ParserAndGenerator
136+ & "Active"
137+ & "Pending"
138+ & "Deleted"
139+```
140+
141+This definition will generate the following type for us:
142+
143+```haskell
144+data XmlStatus
145+ = XmlStatusActive
146+ | XmlStatusPending
147+ | XmlStatusDeleted
148+ | UnknownXmlStatus !String
149+```
150+
151+It has all the necessary instances, so you can use it as a type for a field.
152+
153+### Append content
154+
155+Sometimes the XML you are dealing with contains a mix of elements and immediate
156+content. Something like the following:
157+
158+```XML
159+<?xml version="1.0" encoding="UTF-8"?>
160+<example>
161+ <field1>
162+ I am
163+ </field1>
164+ totally
165+ <field2>
166+ weird
167+ </field2>
168+</example>
169+```
170+
171+You can model this with an "append content" modifier `^`. It will instruct
172+`xml-isogen` to append content of the field as it is, without wrapping it
173+into an XML element. For our case it may look like this:
174+
175+```haskell
176+"Example2" =:= record ParserAndGenerator
177+ ! "field1" [t|Text|]
178+ ^ "mixed" [t|Text|]
179+ ! "field2" [t|Text|]
180+```
181+
182+After parsing the XML above, we'll get the following:
183+
184+```haskell
185+XmlExample2 {_xe2Field1 = "I am", _xe2Mixed = "totally", _xe2Field2 = "weird"}
186+```
187+
188+### Attributes
189+
190+`xml-isogen` also supports XML attributes using `!%` and `?%` modifiers:
191+
192+```haskell
193+"Example3" =:= record ParserAndGenerator
194+ ! "field1" [t|Text|]
195+ !% "attribute1" [t|Text|]
196+ ?% "attribute2" [t|Text|]
197+
198+"Body" =:= record ParserAndGenerator
199+ ! "root" [t|XmlExample3|]
200+```
201+
202+The following two types will be generated:
203+
204+```haskell
205+data XmlExample3
206+ = XmlExample3 {_xe3Field1 :: !Text,
207+ _xe3Attribute1 :: !Text,
208+ _xe3Attribute2 :: !(Maybe Text)}
209+
210+newtype XmlBody = XmlBody {_xbRoot :: XmlExample3}
211+```
212+
213+The `_xe3Attribute2` is optional because we used `?%` modifier. Attributes will be
214+attached to parent XML element. Here is an example of the generated XML file:
215+
216+```XML
217+<root attribute1="world">
218+ <field1>
219+ hello
220+ </field1>
221+</root>
222+```
223+
224+Note that attributes are attached to the parent XML element, that's why we needed
225+`XmlBody` type here.
226+
227+And here is what you get after parsing the XML:
228+
229+```haskell
230+XmlExample3 {_xe3Field1 = "hello", _xe3Attribute1 = "world", _xe3Attribute2 = Nothing}
231+```
232+
233+### Namespaces
234+
235+Often XSD schema requires XML elements to be qualified with a namespace. To instruct
236+`xml-isogen` to qualify fields, specify namespace is a curly brackets:
237+
238+```haskell
239+"Example4" =:= record ParserAndGenerator
240+ ! "field1" [t|Text|]
241+ ! "{http://example.com/1}field2" [t|Text|]
242+ ! "{http://example.com/2}field3" [t|Text|]
243+```
244+
245+Here is the generated XML:
246+
247+```XML
248+<field1>
249+ hello
250+</field1>
251+<field2 xmlns="http://example.com/1">
252+ world
253+</field2>
254+<field3 xmlns="http://example.com/2">
255+ !
256+</field3>
257+```
258+
259+### Nillable types
260+
261+Sometimes optional element in XML are encoded using `nil="true"` attribute instead of
262+omitting the element. (The `nil` attribute comes from `http://www.w3.org/2001/XMLSchema-instance` namespace). With `xml-isogen` you handle it using the `Nillable` type:
263+
264+```haskell
265+"Example5" =:= record ParserAndGenerator
266+ ! "field" [t|Nillable Text|]
267+```
268+
269+If the field contains the value `Nothing`, like this
270+
271+```haskell
272+XmlExample5 { _xe5Field = Nillable Nothing}
273+```
274+
275+then the following XML will be generated:
276+
277+```XML
278+<field
279+ xmlns:ns="http://www.w3.org/2001/XMLSchema-instance"
280+ ns:nil="true"
281+/>
282+```
283+
284+## Development
285+
286+To start working with `xml-isogen` using nix use:
287+
288+```
289+nix-shell --packages cabal2nix --run "cabal2nix ." > default.nix
290+nix-shell
291+cabal v2-build
292+```
ghc-802.yaml+5−1
@@ -1,4 +1,8 @@
1+nix:
2+ packages:
3+ - zlib
4+
1−resolver: lts-9.0
5+resolver: lts-9.21
2
6
3packages:
7packages:
4- .
8- .
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
releasenew file+35
@@ -0,0 +1,35 @@
1+#!/bin/bash
2+
3+set -o xtrace
4+
5+dist=`stack path --dist-dir --stack-yaml ./stack.yaml 2> /dev/null`
6+
7+echo -e "\033[1;36mTesting library...\033[0m"
8+stack test 2> /dev/null
9+
10+echo -e "\033[1;36mRunning sdist...\033[0m"
11+cabal sdist
12+
13+echo -e "\033[1;36mGenerating documentation...\033[0m"
14+stack haddock 2> /dev/null
15+
16+if [ "$?" -eq "0" ]; then
17+ echo -e "\033[1;32mUploading package to Hackage...\033[0m"
18+ read -p "Hackage username: " username
19+ read -p "Hackage password: " -s password
20+ echo ""
21+ cabal upload -u $username -p $password dist/$1-$2.tar.gz
22+
23+ docdir=$dist/doc/html
24+ cd $docdir
25+ doc=$1-$2-docs
26+
27+ echo -e "Compressing documentation from \033[1;34m$docdir\033[0m for \033[1;35m$1\033[0m-\033[1;33m$2\033[1;30m"
28+ cp -r $1 $doc
29+ tar -c -v -z --format=ustar -f $doc.tar.gz $doc
30+ echo -e "\033[1;32mUploading documentation to Hackage...\033[0m"
31+ curl -X PUT -H 'Content-Type: application/x-tar' -H 'Content-Encoding: gzip' --data-binary "@$doc.tar.gz" "https://$username:$password@hackage.haskell.org/package/$1-$2/docs"
32+ exit $?
33+else
34+ echo -e "\033[1;31mNot in a stack-powered project\033[0m"
35+fi
shell.nixnew file+17
@@ -0,0 +1,17 @@
1+{ nixpkgs ? import <nixpkgs> {}, compiler ? "default" }:
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/Compat.hs+23
@@ -2,6 +2,8 @@
2
2
3module Data.THGen.Compat
3module Data.THGen.Compat
4 ( dataD
4 ( dataD
5+ , newtypeD
6+ , nonStrictType
5 , strictType
7 , strictType
6 , varStrictType
8 , varStrictType
7 ) where
9 ) where
@@ -21,6 +23,27 @@ dataD name cons derivs = TH.dataD (return []) name [] Nothing cons derivCls
21dataD name = TH.dataD (return []) name []
23dataD name = TH.dataD (return []) name []
22#endif
24#endif
23
25
26+newtypeD :: TH.Name -> TH.ConQ -> [TH.Name] -> TH.DecQ
27+#if MIN_VERSION_template_haskell(2,12,0)
28+newtypeD name cons derivs = TH.newtypeD (return []) name [] Nothing cons [derivCls]
29+ where
30+ derivCls = TH.derivClause Nothing $ fmap TH.conT derivs
31+#elif MIN_VERSION_template_haskell(2,11,0)
32+newtypeD name cons derivs = TH.newtypeD (return []) name [] Nothing cons derivCls
33+ where
34+ derivCls = traverse TH.conT derivs
35+#else
36+newtypeD name = TH.newtypeD (return []) name []
37+#endif
38+
39+#if MIN_VERSION_template_haskell(2,11,0)
40+nonStrictType :: TH.TypeQ -> TH.BangTypeQ
41+nonStrictType = TH.bangType (TH.bang TH.noSourceUnpackedness TH.noSourceStrictness)
42+#else
43+nonStrictType :: TH.TypeQ -> TH.StrictTypeQ
44+nonStrictType = TH.strictType TH.notStrict
45+#endif
46+
24#if MIN_VERSION_template_haskell(2,11,0)
47#if MIN_VERSION_template_haskell(2,11,0)
25strictType :: TH.TypeQ -> TH.BangTypeQ
48strictType :: TH.TypeQ -> TH.BangTypeQ
26strictType = TH.bangType (TH.bang TH.noSourceUnpackedness TH.sourceStrict)
49strictType = TH.bangType (TH.bang TH.noSourceUnpackedness TH.sourceStrict)
src/Data/THGen/Enum.hs+10−2
@@ -25,14 +25,17 @@ module Data.THGen.Enum
25 ) where
25 ) where
26
26
27import Control.Applicative
27import Control.Applicative
28+import Control.DeepSeq
28import Control.Lens (over, _head, (<&>))
29import Control.Lens (over, _head, (<&>))
29import Control.Monad
30import Control.Monad
30import qualified Data.Char as C
31import qualified Data.Char as C
31import Data.THGen.Compat
32import Data.THGen.Compat
33+import GHC.Generics (Generic)
32import qualified Language.Haskell.TH as TH
34import qualified Language.Haskell.TH as TH
33import qualified Test.QuickCheck as QC
35import qualified Test.QuickCheck as QC
34import qualified Text.Read as R
36import qualified Text.Read as R
35
37
38+
36data Exhaustiveness = Exhaustive | NonExhaustive
39data Exhaustiveness = Exhaustive | NonExhaustive
37 deriving (Eq, Ord, Show)
40 deriving (Eq, Ord, Show)
38
41
@@ -79,7 +82,7 @@ enumGenerate (EnumDesc exh strName strVals) = do
79 dataD
82 dataD
80 name
83 name
81 (constrs ++ unknownConstr)
84 (constrs ++ unknownConstr)
82− ([''Eq, ''Ord] ++ if (exh == Exhaustive) then [''Enum, ''Bounded] else [])
85+ ([''Eq, ''Ord, ''Generic] ++ if (exh == Exhaustive) then [''Enum, ''Bounded] else [])
83 showInstDecl <- do
86 showInstDecl <- do
84 unknownMatch <- case exh of
87 unknownMatch <- case exh of
85 Exhaustive -> return []
88 Exhaustive -> return []
@@ -126,4 +129,9 @@ enumGenerate (EnumDesc exh strName strVals) = do
126 (return [])
129 (return [])
127 [t|QC.Arbitrary $(TH.conT name)|]
130 [t|QC.Arbitrary $(TH.conT name)|]
128 [funSimple 'QC.arbitrary arbExpr]
131 [funSimple 'QC.arbitrary arbExpr]
132+ nfDataInst <- do
133+ TH.instanceD
134+ (return [])
135+ [t|NFData $(TH.conT name)|]
136+ []
129− return [dataDecl, readInstDecl, showInstDecl, arbInstance]
137+ return [dataDecl, readInstDecl, showInstDecl, arbInstance, nfDataInst]
src/Data/THGen/Orphans.hsnew file+11
@@ -0,0 +1,11 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
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−327
@@ -1,5 +1,4 @@
1−{-# LANGUAGE UndecidableInstances #-}
1+{-# LANGUAGE NoImplicitPrelude #-}
2−{-# LANGUAGE FunctionalDependencies #-}
3
2
4{- |
3{- |
5
4
@@ -23,7 +22,7 @@ wrapper around the field type:
23
22
24Example 1.
23Example 1.
25
24
26−> "Color" =:= enum
25+> "Color" =:= enum ParserAndGenerator
27> & "R"
26> & "R"
28> & "G"
27> & "G"
29> & "B"
28> & "B"
@@ -41,7 +40,7 @@ to be either @R@, @G@ or @B@.
41
40
42Example 2.
41Example 2.
43
42
44−> "Message" =:= record
43+> "Message" =:= record ParserAndGenerator
45> ! "author"
44> ! "author"
46> + "recipient"
45> + "recipient"
47> ? "message" [t|Text|]
46> ? "message" [t|Text|]
@@ -68,10 +67,10 @@ enumeration is exhaustive (contains only the listed constructors) or
68non-exhaustive (also contains a constructor for unknown values; this
67non-exhaustive (also contains a constructor for unknown values; this
69is the default):
68is the default):
70
69
71−> "Enum1" Exhaustive =:= enum
70+> "Enum1" Exhaustive =:= enum Generator
72> ...
71> ...
73
72
74−> "Enum2" NonExhaustive =:= enum
73+> "Enum2" NonExhaustive =:= enum Generator
75> ...
74> ...
76
75
77To define a record, use the `record` function followed by the name of
76To define a record, use the `record` function followed by the name of
@@ -79,7 +78,7 @@ the data type to be generated. The prefix for the record fields is
79inferred automatically by taking all of the uppercase letters in the
78inferred automatically by taking all of the uppercase letters in the
80name. You can override it manually like so:
79name. You can override it manually like so:
81
80
82−> "Reference" "ref" =:= record
81+> "Reference" "ref" =:= record Parser
83> ...
82> ...
84
83
85To describe a record field you must supply its name as it appears
84To describe a record field you must supply its name as it appears
@@ -94,10 +93,14 @@ The type of the field is inferred automatically from its name, so
94if the field is called @"author"@ its type will be @Author@. You can
93if the field is called @"author"@ its type will be @Author@. You can
95override the type by specifying it in quasiquotes like so:
94override the type by specifying it in quasiquotes like so:
96
95
97−> "Message" =:= record
96+> "Message" =:= record ParserAndGenerator
98−> ! "author" [t|Person|]
97+> ! "author" [t|Person|].
99> ...
98> ...
100
99
100+Both @record@ and @enum@ take a @GenType@ argument which tells it to generate
101+generator, parser or both. It's being used to optimize compilation time by
102+skipping the unnecessary TH instance generation.
103+
101-}
104-}
102
105
103
106
@@ -105,6 +108,7 @@ module Data.THGen.XML
105 ( Exhaustiveness(..)
108 ( Exhaustiveness(..)
106 , PrefixName(..)
109 , PrefixName(..)
107 , ExhaustivenessName(..)
110 , ExhaustivenessName(..)
111+ , GenType(..)
108 , record
112 , record
109 , enum
113 , enum
110 , (!)
114 , (!)
@@ -114,326 +118,18 @@ module Data.THGen.XML
114 , (!%)
118 , (!%)
115 , (?%)
119 , (?%)
116 , (&)
120 , (&)
121+ , (^)
117 , (=:=)
122 , (=:=)
118 -- Re-exports
123 -- Re-exports
119− , T.Text
124+ , Text
120− , Int
125+ , P.Int
121− , Integer
126+ , P.Integer
127+ , Nillable(..)
122 ) where
128 ) where
123
129
124−import Control.Lens hiding (repeated, enum, (&))
125−import Control.Lens.Internal.FieldTH (makeFieldOpticsForDec)
126−import qualified Data.Char as C
127−import Data.List.NonEmpty (NonEmpty)
128−import Data.Maybe (maybeToList, mapMaybe)
129−import Data.String
130−import Data.THGen.Compat
131import Data.THGen.Enum
130import Data.THGen.Enum
132−import qualified Data.Text as T
131+import Data.THGen.Orphans ()
133−import qualified Language.Haskell.TH as TH
132+import Data.THGen.XML.Internal
134−import Prelude hiding ((+), (*))
133+import Data.Text
135−import Text.XML.DOM.Parser
134+import Text.XML.Nillable
136−import Text.XML.ParentAttributes
135+import qualified Prelude as P
137−import qualified Text.XML.Writer as XW
138−import qualified Text.XML as X
139−
140−data XmlFieldPlural
141− = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
142− | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)
143− | XmlFieldPluralRepeated -- Occurs 0 or more times (List)
144− | XmlFieldPluralMultiplied -- Occurs 1 or more times (NonEmpty)
145−
146−data XmlAttributePlural
147− = XmlAttributePluralMandatory -- Occurs exactly 1 time (Identity)
148− | XmlAttributePluralOptional -- Occurs 0 or 1 times (Maybe)
149−
150−data PrefixName = PrefixName String String
151−
152−data IsoXmlDescPreField = IsoXmlDescPreField String TH.TypeQ
153−
154−data IsoXmlDescPreAttribute = IsoXmlDescPreAttribute String TH.TypeQ
155−
156−data IsoXmlDescField = IsoXmlDescField XmlFieldPlural String TH.TypeQ
157−
158−data IsoXmlDescAttribute = IsoXmlDescAttribute XmlAttributePlural String TH.TypeQ
159−
160−data IsoXmlDescRecordPart
161− = IsoXmlDescRecordField IsoXmlDescField
162− | IsoXmlDescRecordAttribute IsoXmlDescAttribute
163−
164−newtype IsoXmlDescRecord = IsoXmlDescRecord [IsoXmlDescRecordPart]
165−
166−makePrisms ''IsoXmlDescRecord
167−
168−data ExhaustivenessName = ExhaustivenessName String Exhaustiveness
169−
170−newtype IsoXmlDescEnumCon
171− = IsoXmlDescEnumCon { unIsoXmlDescEnumCon :: String }
172−
173−instance IsString IsoXmlDescEnumCon where
174− fromString = IsoXmlDescEnumCon
175−
176−data IsoXmlDescEnum = IsoXmlDescEnum [IsoXmlDescEnumCon]
177−
178−makePrisms ''IsoXmlDescEnum
179−
180−appendField
181− :: XmlFieldPlural
182− -> IsoXmlDescRecord
183− -> IsoXmlDescPreField
184− -> IsoXmlDescRecord
185−appendField plural xrec (IsoXmlDescPreField name ty) =
186− let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty
187− in over _IsoXmlDescRecord (xfield:) xrec
188−
189−appendAttribute
190− :: XmlAttributePlural
191− -> IsoXmlDescRecord
192− -> IsoXmlDescPreAttribute
193− -> IsoXmlDescRecord
194−appendAttribute plural xrec (IsoXmlDescPreAttribute name ty) =
195− let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty
196− in over _IsoXmlDescRecord (xattribute:) xrec
197−
198−(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
199−(!) = appendField XmlFieldPluralMandatory
200−(?) = appendField XmlFieldPluralOptional
201−(*) = appendField XmlFieldPluralRepeated
202−(+) = appendField XmlFieldPluralMultiplied
203−
204−(!%), (?%) :: IsoXmlDescRecord -> IsoXmlDescPreAttribute -> IsoXmlDescRecord
205−(!%) = appendAttribute XmlAttributePluralMandatory
206−(?%) = appendAttribute XmlAttributePluralOptional
207−
208−infixl 2 !
209−infixl 2 ?
210−infixl 2 *
211−infixl 2 +
212−infixl 2 !%
213−infixl 2 ?%
214−
215−appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
216−appendEnumCon xenum xenumcon =
217− over _IsoXmlDescEnum (xenumcon:) xenum
218−
219−(&) :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
220−(&) = appendEnumCon
221−
222−infixl 2 &
223−
224−class Description name desc | desc -> name where
225− (=:=) :: name -> desc -> TH.DecsQ
226−
227−infix 0 =:=
228−
229−instance Description PrefixName IsoXmlDescRecord where
230− prefixName =:= descRecord =
231− let descRecordParts = descRecord ^. _IsoXmlDescRecord
232− in isoXmlGenerateRecord prefixName (reverse descRecordParts)
233−
234−record :: IsoXmlDescRecord
235−record = IsoXmlDescRecord []
236−
237−enum :: IsoXmlDescEnum
238−enum = IsoXmlDescEnum []
239−
240−instance Description ExhaustivenessName IsoXmlDescEnum where
241− exhaustivenessName =:= descEnum =
242− let descEnumCons = descEnum ^. _IsoXmlDescEnum
243− in isoXmlGenerateEnum exhaustivenessName (reverse descEnumCons)
244−
245−instance IsString (TH.TypeQ -> IsoXmlDescPreField) where
246− fromString = IsoXmlDescPreField
247−
248−instance IsString IsoXmlDescPreField where
249− fromString name = IsoXmlDescPreField name ty
250− where
251− ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)
252−
253−instance IsString (TH.TypeQ -> IsoXmlDescPreAttribute) where
254− fromString = IsoXmlDescPreAttribute
255−
256−instance IsString IsoXmlDescPreAttribute where
257− fromString name = IsoXmlDescPreAttribute name ty
258− where
259− ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)
260−
261−instance s ~ String => IsString (s -> PrefixName) where
262− fromString = PrefixName
263−
264−instance IsString PrefixName where
265− fromString strName = PrefixName strName (makeNamePrefix strName)
266−
267−instance e ~ Exhaustiveness => IsString (e -> ExhaustivenessName) where
268− fromString = ExhaustivenessName
269−
270−instance IsString ExhaustivenessName where
271− fromString strName = ExhaustivenessName strName NonExhaustive
272−
273−makeNamePrefix :: String -> String
274−makeNamePrefix = map C.toLower . filter C.isUpper
275−
276−funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ
277−funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]
278−
279−isoXmlGenerateEnum
280− :: ExhaustivenessName -> [IsoXmlDescEnumCon] -> TH.DecsQ
281−isoXmlGenerateEnum (ExhaustivenessName strName' exh) enumCons = do
282− let
283− strName = "Xml" ++ strName'
284− strVals = map unIsoXmlDescEnumCon enumCons
285− enumDesc = EnumDesc exh strName strVals
286− name = TH.mkName strName
287− enumDecls <- enumGenerate enumDesc
288− toXmlInst <- do
289− TH.instanceD
290− (return [])
291− [t|XW.ToXML $(TH.conT name)|]
292− [funSimple 'XW.toXML [e|XW.toXML . T.pack . show|]]
293− toXmlAttributeInst <- do
294− TH.instanceD
295− (return [])
296− [t|ToXmlAttribute $(TH.conT name)|]
297− [funSimple 'toXmlAttribute [e|T.pack . show|]]
298− fromDomInst <- do
299− TH.instanceD
300− (return [])
301− [t|FromDom $(TH.conT name)|]
302− [funSimple 'fromDom [e|parseContent readContent|]]
303− fromAttributeInst <- do
304− TH.instanceD
305− (return [])
306− [t|FromAttribute $(TH.conT name)|]
307− [funSimple 'fromAttribute [e|readContent|]]
308− return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
309− fromDomInst, fromAttributeInst]
310−
311−isoXmlGenerateRecord :: PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ
312−isoXmlGenerateRecord (PrefixName strName' strPrefix') descRecordParts = do
313− let
314− strName = "Xml" ++ strName'
315− strPrefix = "x" ++ strPrefix'
316− name = TH.mkName strName
317− fieldName str = "_" ++ strPrefix ++ over _head C.toUpper str
318− dataDecl <- do
319− let
320− fields = do
321− descRecordPart <- descRecordParts
322− return $ case descRecordPart of
323− IsoXmlDescRecordField descField ->
324− let
325− IsoXmlDescField fieldPlural fieldStrName fieldType = descField
326− fName = TH.mkName (fieldName fieldStrName)
327− fType = case fieldPlural of
328− XmlFieldPluralMandatory -> fieldType
329− XmlFieldPluralOptional -> [t| Maybe $fieldType |]
330− XmlFieldPluralRepeated -> [t| [$fieldType] |]
331− XmlFieldPluralMultiplied -> [t| NonEmpty $fieldType |]
332− in
333− varStrictType fName (strictType fType)
334− IsoXmlDescRecordAttribute descAttribute ->
335− let
336− IsoXmlDescAttribute
337− attributePlural attributeStrName attributeType = descAttribute
338− fName = TH.mkName (fieldName attributeStrName)
339− fType = case attributePlural of
340− XmlAttributePluralMandatory -> attributeType
341− XmlAttributePluralOptional -> [t| Maybe $attributeType |]
342− in
343− varStrictType fName (strictType fType)
344− dataD
345− name
346− [TH.recC name fields]
347− [''Eq, ''Show]
348− lensDecls <- makeFieldOpticsForDec lensRules dataDecl
349− fromDomInst <- do
350− let
351− exprHeader = [e|pure $(TH.conE name)|]
352− exprRecordParts = do
353− descRecordPart <- descRecordParts
354− return $ case descRecordPart of
355− IsoXmlDescRecordField descField ->
356− let
357− IsoXmlDescField fieldPlural fieldStrName _ = descField
358− exprFieldStrName = TH.litE (TH.stringL fieldStrName)
359− fieldParse = case fieldPlural of
360− XmlFieldPluralMandatory -> [e|inElem|]
361− _ -> [e|inElemTrav|]
362− in
363− [e|$fieldParse $exprFieldStrName fromDom|]
364− IsoXmlDescRecordAttribute descAttribute ->
365− let
366− IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute
367− exprAttributeStrName = TH.litE (TH.stringL attributeStrName)
368− attributeParse = case attributePlural of
369− XmlAttributePluralMandatory -> [e|parseAttribute|]
370− XmlAttributePluralOptional -> [e|parseAttributeMaybe|]
371− in
372− [e|$attributeParse $exprAttributeStrName fromAttribute|]
373− fromDomExpr = foldl (\e fe -> [e| $e <*> $fe |]) exprHeader exprRecordParts
374− TH.instanceD
375− (return [])
376− [t|FromDom $(TH.conT name)|]
377− [ funSimple 'fromDom fromDomExpr ]
378−
379− toXmlInst <- do
380− objName <- TH.newName strPrefix
381− let
382− exprFields = do
383− descRecordPart <- descRecordParts
384− IsoXmlDescField fieldPlural fieldStrName _ <-
385− maybeToList $ case descRecordPart of
386− IsoXmlDescRecordField descField -> Just descField
387− _ -> Nothing
388− let
389− fName = TH.mkName (fieldName fieldStrName)
390− exprFieldStrName = TH.litE (TH.stringL fieldStrName)
391− exprForField = case fieldPlural of
392− XmlFieldPluralMandatory -> [e|id|]
393− _ -> [e|traverse|]
394− exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
395− exprFieldRender =
396− [e|(\a -> XW.elementA $exprFieldStrName (toXmlParentAttributes a) a)|]
397− return [e|$exprForField $exprFieldRender $exprFieldValue|]
398− toXmlExpr
399− = TH.lamE [if null exprFields then TH.wildP else TH.varP objName]
400− $ foldr (\fe e -> [e|$fe *> $e|]) [e|return ()|] exprFields
401− TH.instanceD
402− (return [])
403− [t|XW.ToXML $(TH.conT name)|]
404− [funSimple 'XW.toXML toXmlExpr]
405−
406− toXmlParentAttributesInst <- do
407− objName <- TH.newName strPrefix
408− let
409− exprAttributes = do
410− descRecordPart <- descRecordParts
411− IsoXmlDescAttribute attributePlural attributeStrName _ <-
412− maybeToList $ case descRecordPart of
413− IsoXmlDescRecordAttribute descAttribute -> Just descAttribute
414− _ -> Nothing
415− let
416− fName = TH.mkName (fieldName attributeStrName)
417− exprAttrStrName = TH.litE (TH.stringL attributeStrName)
418− exprAttrValue = [e|$(TH.varE fName) $(TH.varE objName)|]
419− exprAttrWrap = case attributePlural of
420− XmlAttributePluralMandatory -> [e|Just . toXmlAttribute|]
421− XmlAttributePluralOptional -> [e|fmap toXmlAttribute|]
422− return [e|($exprAttrStrName, $exprAttrWrap $exprAttrValue)|]
423− toXmlParentAttributesExpr
424− = TH.lamE [if null exprAttributes then TH.wildP else TH.varP objName]
425− $ [e|mapMaybe distribPair $(TH.listE exprAttributes)|]
426−#if __GLASGOW_HASKELL__ < 800
427− TH.instanceD
428−#else
429− TH.instanceWithOverlapD (Just TH.Overlapping)
430−#endif
431− (return [])
432− [t|ToXmlParentAttributes $(TH.conT name)|]
433− [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]
434−
435− return $ [dataDecl] ++ lensDecls ++
436− [fromDomInst, toXmlInst, toXmlParentAttributesInst]
437−
438−distribPair :: Functor f => (a, f b) -> f (a, b)
439−distribPair (a, fb) = (a,) <$> fb
src/Data/THGen/XML/Internal.hsnew file+457
@@ -0,0 +1,457 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE UndecidableInstances #-}
3+{-# LANGUAGE FunctionalDependencies #-}
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
1+nix:
2−
3−packages:
2+ packages:
4−- .
3+ - zlib
5
4
5+resolver: lts-10.0
6extra-deps:
6extra-deps:
7- dom-parser-3.0.0
7- dom-parser-3.0.0
8- generic-arbitrary-0.1.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+7−6
@@ -1,8 +1,9 @@
1−resolver: lts-6.35
1+nix:
2−
3−packages:
2+ packages:
4−- .
3+ - zlib
5
4
5+resolver: lts-20.16
6extra-deps:
6extra-deps:
7−- dom-parser-3.0.0
7+ - git: https://github.com/typeable/dom-parser.git
8−- generic-arbitrary-0.1.0
8+ commit: 7d556ba528bfa216e99714f8a0d4d00f452803a9
9+ - xml-lens-0.3.1
test/TestDefs.hs+7−11
@@ -4,17 +4,16 @@
4
4
5module TestDefs where
5module TestDefs where
6
6
7−import Data.List.NonEmpty
7+-- import Data.List.NonEmpty
8import Data.THGen.XML
8import Data.THGen.XML
9−import GHC.Generics (Generic)
10import Test.QuickCheck.Arbitrary.Generic
9import Test.QuickCheck.Arbitrary.Generic
11import Test.QuickCheck.Instances ()
10import Test.QuickCheck.Instances ()
12
11
13−"Bar" =:= enum
12+"Bar" =:= enum ParserAndGenerator
14 & "baroque"
13 & "baroque"
15 & "bartender"
14 & "bartender"
16
15
17−"Quux" Exhaustive =:= enum
16+"Quux" Exhaustive =:= enum ParserAndGenerator
18 & "ALL"
17 & "ALL"
19 & "YOUR"
18 & "YOUR"
20 & "BASE"
19 & "BASE"
@@ -23,23 +22,20 @@ import Test.QuickCheck.Instances ()
23 & "TO"
22 & "TO"
24 & "US"
23 & "US"
25
24
26−"Foo" =:= record
25+"Foo" =:= record ParserAndGenerator
26+ ^ "Shmuux" [t|XmlQuux|]
27 + "Bar"
27 + "Bar"
28 ? "Baz" [t|Text|]
28 ? "Baz" [t|Text|]
29 !% "Quux"
29 !% "Quux"
30 ?% "Muux" [t|XmlQuux|]
30 ?% "Muux" [t|XmlQuux|]
31
31
32−"Root" =:= record
32+"Root" =:= record ParserAndGenerator
33− ! "Foo"
33+ ! "{http://example.com/ns/my-namespace}Foo"
34−
35−deriving instance Generic XmlRoot
36
34
37instance Arbitrary XmlRoot where
35instance Arbitrary XmlRoot where
38 arbitrary = genericArbitrary
36 arbitrary = genericArbitrary
39 shrink = genericShrink
37 shrink = genericShrink
40
38
41−deriving instance Generic XmlFoo
42−
43instance Arbitrary XmlFoo where
39instance Arbitrary XmlFoo where
44 arbitrary = genericArbitrary
40 arbitrary = genericArbitrary
45 shrink = genericShrink
41 shrink = genericShrink
xml-isogen.cabal+14−2
@@ -1,5 +1,5 @@
1name: xml-isogen
1name: xml-isogen
2−version: 0.2.1
2+version: 0.3.2
3synopsis: Generate XML-isomorphic types
3synopsis: Generate XML-isomorphic types
4description:
4description:
5 TemplateHaskell generators for XML-isomorphic data types, including
5 TemplateHaskell generators for XML-isomorphic data types, including
@@ -18,7 +18,8 @@ cabal-version: >=1.22
18homepage: https://github.com/typeable/xml-isogen
18homepage: https://github.com/typeable/xml-isogen
19tested-with: GHC == 7.10.3
19tested-with: GHC == 7.10.3
20 , GHC == 8.0.2
20 , GHC == 8.0.2
21− , GHC == 8.2.1
21+ , GHC == 8.2.2
22+ , GHC == 8.4.1
22extra-source-files: CHANGELOG.md
23extra-source-files: CHANGELOG.md
23 , README.md
24 , README.md
24
25
@@ -29,24 +30,34 @@ source-repository head
29library
30library
30 exposed-modules: Data.THGen.Enum
31 exposed-modules: Data.THGen.Enum
31 , Data.THGen.XML
32 , Data.THGen.XML
33+ , Data.THGen.XML.Internal
32 , Text.XML.ParentAttributes
34 , Text.XML.ParentAttributes
35+ , Text.XML.Nillable
33 other-modules: Data.THGen.Compat
36 other-modules: Data.THGen.Compat
37+ , Data.THGen.Orphans
38+ , Text.XML.DOM.Parser.Internal.Content
34 build-depends: QuickCheck >= 2.8
39 build-depends: QuickCheck >= 2.8
35 , base >=4.8 && <5
40 , base >=4.8 && <5
36 , dom-parser >= 2.0.0
41 , dom-parser >= 2.0.0
42+ , deepseq
37 , lens >= 4.13
43 , lens >= 4.13
38 , mtl >= 2.2
44 , mtl >= 2.2
45+ , scientific
39 , semigroups >= 0.18
46 , semigroups >= 0.18
40 , template-haskell >= 2.10
47 , template-haskell >= 2.10
41 , text >= 1.2
48 , text >= 1.2
42 , xml-conduit >= 1.0
49 , xml-conduit >= 1.0
43 , xml-conduit-writer >= 0.1
50 , xml-conduit-writer >= 0.1
44
51
52+ ghc-options: -Wall
53+
45 hs-source-dirs: src
54 hs-source-dirs: src
46
55
47 default-language: Haskell2010
56 default-language: Haskell2010
48 default-extensions: CPP
57 default-extensions: CPP
58+ , DeriveTraversable
49 , FlexibleInstances
59 , FlexibleInstances
60+ , GeneralizedNewtypeDeriving
50 , LambdaCase
61 , LambdaCase
51 , TemplateHaskell
62 , TemplateHaskell
52 , TupleSections
63 , TupleSections
@@ -60,6 +71,7 @@ test-suite spec
60 build-depends: base
71 build-depends: base
61 , QuickCheck
72 , QuickCheck
62 , data-default
73 , data-default
74+ , deepseq
63 , dom-parser
75 , dom-parser
64 , generic-arbitrary
76 , generic-arbitrary
65 , hspec
77 , hspec