git.iko.soy/typeable/xml-isogen
on master help sign in
swap
e7de36963 ahead, 0 behind
23 files changed+1201−360
since splitsnapshots
unifiedsplit
.gitignore+5 .travis.yml+27 CHANGELOG.md+27 README.md+292 ghc-802.yaml+12 ghc-822.yaml+5 ghc-844.yaml+7 release+35 shell.nix+17 src/Data/THGen/Compat.hs+61 src/Data/THGen/Enum.hs+17−10 src/Data/THGen/Orphans.hs+11 src/Data/THGen/XML.hs+23−326 src/Data/THGen/XML/Internal.hs+457 src/Text/XML/DOM/Parser/Internal/Content.hs+28 src/Text/XML/Nillable.hs+41 stack-10.0.yaml+8 stack-18.18.yaml+9 stack-19.6.yaml+9 stack.yaml+7−7 test/Main.hs+26−1 test/TestDefs.hs+25−5 xml-isogen.cabal+52−11
.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.ymlnew file+27
@@ -0,0 +1,27 @@
1+sudo: false
2+
3+language: generic
4+
5+env:
6+ - STACK_YAML=stack.yaml
7+ - STACK_YAML=ghc-802.yaml
8+ - STACK_YAML=ghc-822.yaml
9+ - STACK_YAML=ghc-844.yaml
10+
11+cache:
12+ directories:
13+ - $HOME/.stack
14+
15+addons:
16+ apt:
17+ packages:
18+ - libgmp-dev
19+
20+before_install:
21+# Download and unpack the stack executable
22+- mkdir -p ~/.local/bin
23+- export PATH=$HOME/.local/bin:$PATH
24+- travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
25+
26+script:
27+- stack --no-terminal --install-ghc test --haddock --no-haddock-deps
CHANGELOG.md+27
@@ -1,3 +1,30 @@
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+
16+0.2.1
17+------
18+
19+* Workaround for the GHC 8.2.1 attribute generation bug
20+
21+* Add tests checking run-time behaviour of generated code
22+
23+0.2.0
24+-------
25+
26+* Builds with GHC 7.10.3, 8.0.2 and 8.2.1
27+
1280.1.0
229-------
330
README.mdnew file+292
@@ -0,0 +1,292 @@
1+# xml-isogen
2+
3+[![Build Status](https://travis-ci.org/typeable/xml-isogen.svg?branch=master)](https://travis-ci.org/typeable/xml-isogen)
4+
5+TemplateHaskell generators for XML-isomorphic data types, including
6+instances for parsing and rendering. A convenient DSL to define those
7+types.
8+
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.yamlnew file+12
@@ -0,0 +1,12 @@
1+nix:
2+ packages:
3+ - zlib
4+
5+resolver: lts-9.21
6+
7+packages:
8+- .
9+
10+extra-deps:
11+- dom-parser-3.0.0
12+- generic-arbitrary-0.1.0
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.hsnew file+61
@@ -0,0 +1,61 @@
1+{-# LANGUAGE CPP #-}
2+
3+module Data.THGen.Compat
4+ ( dataD
5+ , newtypeD
6+ , nonStrictType
7+ , strictType
8+ , varStrictType
9+ ) where
10+
11+import qualified Language.Haskell.TH as TH
12+
13+dataD :: TH.Name -> [TH.ConQ] -> [TH.Name] -> TH.DecQ
14+#if MIN_VERSION_template_haskell(2,12,0)
15+dataD name cons derivs = TH.dataD (return []) name [] Nothing cons [derivCls]
16+ where
17+ derivCls = TH.derivClause Nothing $ fmap TH.conT derivs
18+#elif MIN_VERSION_template_haskell(2,11,0)
19+dataD name cons derivs = TH.dataD (return []) name [] Nothing cons derivCls
20+ where
21+ derivCls = traverse TH.conT derivs
22+#else
23+dataD name = TH.dataD (return []) name []
24+#endif
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+
47+#if MIN_VERSION_template_haskell(2,11,0)
48+strictType :: TH.TypeQ -> TH.BangTypeQ
49+strictType = TH.bangType (TH.bang TH.noSourceUnpackedness TH.sourceStrict)
50+#else
51+strictType :: TH.TypeQ -> TH.StrictTypeQ
52+strictType = TH.strictType TH.isStrict
53+#endif
54+
55+#if MIN_VERSION_template_haskell(2,11,0)
56+varStrictType :: TH.Name -> TH.BangTypeQ -> TH.VarBangTypeQ
57+varStrictType = TH.varBangType
58+#else
59+varStrictType :: TH.Name -> TH.StrictTypeQ -> TH.VarStrictTypeQ
60+varStrictType = TH.varStrictType
61+#endif
src/Data/THGen/Enum.hs+17−10
@@ -25,13 +25,17 @@ module Data.THGen.Enum
2525 ) where
2626
2727import Control.Applicative
28−import Control.Lens (over, _head)
28+import Control.DeepSeq
29+import Control.Lens (over, _head, (<&>))
2930import Control.Monad
3031import qualified Data.Char as C
32+import Data.THGen.Compat
33+import GHC.Generics (Generic)
3134import qualified Language.Haskell.TH as TH
3235import qualified Test.QuickCheck as QC
3336import qualified Text.Read as R
3437
38+
3539data Exhaustiveness = Exhaustive | NonExhaustive
3640 deriving (Eq, Ord, Show)
3741
@@ -62,11 +66,11 @@ mangleEnumConName
6266 . words
6367
6468enumGenerate :: EnumDesc -> TH.DecsQ
65−enumGenerate (EnumDesc exh strName strVals') = do
69+enumGenerate (EnumDesc exh strName strVals) = do
6670 let
6771 name = TH.mkName strName
68− strVals = map mangleEnumConName strVals'
69− vals = map (\strVal -> TH.mkName (strName ++ strVal)) strVals
72+ vals = strVals <&> \strVal ->
73+ TH.mkName (strName ++ mangleEnumConName strVal)
7074 unknownVal = TH.mkName ("Unknown" ++ strName)
7175 dataDecl <- do
7276 let
@@ -74,13 +78,11 @@ enumGenerate (EnumDesc exh strName strVals') = do
7478 unknownConstr = case exh of
7579 Exhaustive -> []
7680 NonExhaustive ->
77− [TH.normalC unknownVal [TH.strictType TH.isStrict [t|String|]]]
78− TH.dataD
79− (return [])
81+ [TH.normalC unknownVal [strictType [t|String|]]]
82+ dataD
8083 name
81− []
8284 (constrs ++ unknownConstr)
83− ([''Eq, ''Ord] ++ if (exh == Exhaustive) then [''Enum, ''Bounded] else [])
85+ ([''Eq, ''Ord, ''Generic] ++ if (exh == Exhaustive) then [''Enum, ''Bounded] else [])
8486 showInstDecl <- do
8587 unknownMatch <- case exh of
8688 Exhaustive -> return []
@@ -127,4 +129,9 @@ enumGenerate (EnumDesc exh strName strVals') = do
127129 (return [])
128130 [t|QC.Arbitrary $(TH.conT name)|]
129131 [funSimple 'QC.arbitrary arbExpr]
130− 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−326
@@ -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,325 +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.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
130130import Data.THGen.Enum
131−import qualified Data.Text as T
132−import qualified Language.Haskell.TH as TH
133−import Prelude hiding ((+), (*))
134−import Text.XML.DOM.Parser
135−import Text.XML.ParentAttributes
136−import qualified Text.XML.Writer as XW
137−import qualified Text.XML as X
138−
139−data XmlFieldPlural
140− = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
141− | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)
142− | XmlFieldPluralRepeated -- Occurs 0 or more times (List)
143− | XmlFieldPluralMultiplied -- Occurs 1 or more times (NonEmpty)
144−
145−data XmlAttributePlural
146− = XmlAttributePluralMandatory -- Occurs exactly 1 time (Identity)
147− | XmlAttributePluralOptional -- Occurs 0 or 1 times (Maybe)
148−
149−data PrefixName = PrefixName String String
150−
151−data IsoXmlDescPreField = IsoXmlDescPreField String TH.TypeQ
152−
153−data IsoXmlDescPreAttribute = IsoXmlDescPreAttribute String TH.TypeQ
154−
155−data IsoXmlDescField = IsoXmlDescField XmlFieldPlural String TH.TypeQ
156−
157−data IsoXmlDescAttribute = IsoXmlDescAttribute XmlAttributePlural String TH.TypeQ
158−
159−data IsoXmlDescRecordPart
160− = IsoXmlDescRecordField IsoXmlDescField
161− | IsoXmlDescRecordAttribute IsoXmlDescAttribute
162−
163−newtype IsoXmlDescRecord = IsoXmlDescRecord [IsoXmlDescRecordPart]
164−
165−makePrisms ''IsoXmlDescRecord
166−
167−data ExhaustivenessName = ExhaustivenessName String Exhaustiveness
168−
169−newtype IsoXmlDescEnumCon
170− = IsoXmlDescEnumCon { unIsoXmlDescEnumCon :: String }
171−
172−instance IsString IsoXmlDescEnumCon where
173− fromString = IsoXmlDescEnumCon
174−
175−data IsoXmlDescEnum = IsoXmlDescEnum [IsoXmlDescEnumCon]
176−
177−makePrisms ''IsoXmlDescEnum
178−
179−appendField
180− :: XmlFieldPlural
181− -> IsoXmlDescRecord
182− -> IsoXmlDescPreField
183− -> IsoXmlDescRecord
184−appendField plural xrec (IsoXmlDescPreField name ty) =
185− let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty
186− in over _IsoXmlDescRecord (xfield:) xrec
187−
188−appendAttribute
189− :: XmlAttributePlural
190− -> IsoXmlDescRecord
191− -> IsoXmlDescPreAttribute
192− -> IsoXmlDescRecord
193−appendAttribute plural xrec (IsoXmlDescPreAttribute name ty) =
194− let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty
195− in over _IsoXmlDescRecord (xattribute:) xrec
196−
197−(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
198−(!) = appendField XmlFieldPluralMandatory
199−(?) = appendField XmlFieldPluralOptional
200−(*) = appendField XmlFieldPluralRepeated
201−(+) = appendField XmlFieldPluralMultiplied
202−
203−(!%), (?%) :: IsoXmlDescRecord -> IsoXmlDescPreAttribute -> IsoXmlDescRecord
204−(!%) = appendAttribute XmlAttributePluralMandatory
205−(?%) = appendAttribute XmlAttributePluralOptional
206−
207−infixl 2 !
208−infixl 2 ?
209−infixl 2 *
210−infixl 2 +
211−infixl 2 !%
212−infixl 2 ?%
213−
214−appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
215−appendEnumCon xenum xenumcon =
216− over _IsoXmlDescEnum (xenumcon:) xenum
217−
218−(&) :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
219−(&) = appendEnumCon
220−
221−infixl 2 &
222−
223−class Description name desc | desc -> name where
224− (=:=) :: name -> desc -> TH.DecsQ
225−
226−infix 0 =:=
227−
228−instance Description PrefixName IsoXmlDescRecord where
229− prefixName =:= descRecord =
230− let descRecordParts = descRecord ^. _IsoXmlDescRecord
231− in isoXmlGenerateRecord prefixName (reverse descRecordParts)
232−
233−record :: IsoXmlDescRecord
234−record = IsoXmlDescRecord []
235−
236−enum :: IsoXmlDescEnum
237−enum = IsoXmlDescEnum []
238−
239−instance Description ExhaustivenessName IsoXmlDescEnum where
240− exhaustivenessName =:= descEnum =
241− let descEnumCons = descEnum ^. _IsoXmlDescEnum
242− in isoXmlGenerateEnum exhaustivenessName (reverse descEnumCons)
243−
244−instance IsString (TH.TypeQ -> IsoXmlDescPreField) where
245− fromString = IsoXmlDescPreField
246−
247−instance IsString IsoXmlDescPreField where
248− fromString name = IsoXmlDescPreField name ty
249− where
250− ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)
251−
252−instance IsString (TH.TypeQ -> IsoXmlDescPreAttribute) where
253− fromString = IsoXmlDescPreAttribute
254−
255−instance IsString IsoXmlDescPreAttribute where
256− fromString name = IsoXmlDescPreAttribute name ty
257− where
258− ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)
259−
260−instance s ~ String => IsString (s -> PrefixName) where
261− fromString = PrefixName
262−
263−instance IsString PrefixName where
264− fromString strName = PrefixName strName (makeNamePrefix strName)
265−
266−instance e ~ Exhaustiveness => IsString (e -> ExhaustivenessName) where
267− fromString = ExhaustivenessName
268−
269−instance IsString ExhaustivenessName where
270− fromString strName = ExhaustivenessName strName NonExhaustive
271−
272−makeNamePrefix :: String -> String
273−makeNamePrefix = map C.toLower . filter C.isUpper
274−
275−funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ
276−funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]
277−
278−isoXmlGenerateEnum
279− :: ExhaustivenessName -> [IsoXmlDescEnumCon] -> TH.DecsQ
280−isoXmlGenerateEnum (ExhaustivenessName strName' exh) enumCons = do
281− let
282− strName = "Xml" ++ strName'
283− strVals = map unIsoXmlDescEnumCon enumCons
284− enumDesc = EnumDesc exh strName strVals
285− name = TH.mkName strName
286− enumDecls <- enumGenerate enumDesc
287− toXmlInst <- do
288− TH.instanceD
289− (return [])
290− [t|XW.ToXML $(TH.conT name)|]
291− [funSimple 'XW.toXML [e|XW.toXML . T.pack . show|]]
292− toXmlAttributeInst <- do
293− TH.instanceD
294− (return [])
295− [t|ToXmlAttribute $(TH.conT name)|]
296− [funSimple 'toXmlAttribute [e|T.pack . show|]]
297− fromDomInst <- do
298− TH.instanceD
299− (return [])
300− [t|FromDom $(TH.conT name)|]
301− [funSimple 'fromDom [e|parseContent readContent|]]
302− fromAttributeInst <- do
303− TH.instanceD
304− (return [])
305− [t|FromAttribute $(TH.conT name)|]
306− [funSimple 'fromAttribute [e|readContent|]]
307− return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
308− fromDomInst, fromAttributeInst]
309−
310−isoXmlGenerateRecord :: PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ
311−isoXmlGenerateRecord (PrefixName strName' strPrefix') descRecordParts = do
312− let
313− strName = "Xml" ++ strName'
314− strPrefix = "x" ++ strPrefix'
315− name = TH.mkName strName
316− fieldName str = "_" ++ strPrefix ++ over _head C.toUpper str
317− dataDecl <- do
318− let
319− fields = do
320− descRecordPart <- descRecordParts
321− return $ case descRecordPart of
322− IsoXmlDescRecordField descField ->
323− let
324− IsoXmlDescField fieldPlural fieldStrName fieldType = descField
325− fName = TH.mkName (fieldName fieldStrName)
326− fType = case fieldPlural of
327− XmlFieldPluralMandatory -> fieldType
328− XmlFieldPluralOptional -> [t| Maybe $fieldType |]
329− XmlFieldPluralRepeated -> [t| [$fieldType] |]
330− XmlFieldPluralMultiplied -> [t| NonEmpty $fieldType |]
331− in
332− TH.varStrictType fName (TH.strictType TH.isStrict fType)
333− IsoXmlDescRecordAttribute descAttribute ->
334− let
335− IsoXmlDescAttribute
336− attributePlural attributeStrName attributeType = descAttribute
337− fName = TH.mkName (fieldName attributeStrName)
338− fType = case attributePlural of
339− XmlAttributePluralMandatory -> attributeType
340− XmlAttributePluralOptional -> [t| Maybe $attributeType |]
341− in
342− TH.varStrictType fName (TH.strictType TH.isStrict fType)
343− TH.dataD
344− (return [])
345− name
346− []
347− [TH.recC name fields]
348− [''Eq, ''Show]
349− lensDecls <- makeFieldOpticsForDec lensRules dataDecl
350− fromDomInst <- do
351− let
352− exprHeader = [e|pure $(TH.conE name)|]
353− exprRecordParts = do
354− descRecordPart <- descRecordParts
355− return $ case descRecordPart of
356− IsoXmlDescRecordField descField ->
357− let
358− IsoXmlDescField fieldPlural fieldStrName _ = descField
359− exprFieldStrName = TH.litE (TH.stringL fieldStrName)
360− fieldParse = case fieldPlural of
361− XmlFieldPluralMandatory -> [e|inElem|]
362− _ -> [e|inElemTrav|]
363− in
364− [e|$fieldParse $exprFieldStrName fromDom|]
365− IsoXmlDescRecordAttribute descAttribute ->
366− let
367− IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute
368− exprAttributeStrName = TH.litE (TH.stringL attributeStrName)
369− attributeParse = case attributePlural of
370− XmlAttributePluralMandatory -> [e|parseAttribute|]
371− XmlAttributePluralOptional -> [e|parseAttributeMaybe|]
372− in
373− [e|$attributeParse $exprAttributeStrName fromAttribute|]
374− fromDomExpr = foldl (\e fe -> [e| $e <*> $fe |]) exprHeader exprRecordParts
375− TH.instanceD
376− (return [])
377− [t|FromDom $(TH.conT name)|]
378− [ funSimple 'fromDom fromDomExpr ]
379−
380− toXmlInst <- do
381− objName <- TH.newName strPrefix
382− let
383− exprFields = do
384− descRecordPart <- descRecordParts
385− IsoXmlDescField fieldPlural fieldStrName _ <-
386− maybeToList $ case descRecordPart of
387− IsoXmlDescRecordField descField -> Just descField
388− _ -> Nothing
389− let
390− fName = TH.mkName (fieldName fieldStrName)
391− exprFieldStrName = TH.litE (TH.stringL fieldStrName)
392− exprForField = case fieldPlural of
393− XmlFieldPluralMandatory -> [e|id|]
394− _ -> [e|traverse|]
395− exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
396− exprFieldRender = [e|mkElement $exprFieldStrName|]
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− TH.instanceD
427− (return [])
428− [t|ToXmlParentAttributes $(TH.conT name)|]
429− [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]
430−
431− return $ [dataDecl] ++ lensDecls ++
432− [fromDomInst, toXmlInst, toXmlParentAttributesInst]
433−
434−mkElement :: (XW.ToXML a, ToXmlParentAttributes a) => X.Name -> a -> XW.XML
435−mkElement name a = XW.elementA name (toXmlParentAttributes a) (XW.toXML a)
436−
437−distribPair :: Functor f => (a, f b) -> f (a, b)
438−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
stack-10.0.yamlnew file+8
@@ -0,0 +1,8 @@
1+nix:
2+ packages:
3+ - zlib
4+
5+resolver: lts-10.0
6+extra-deps:
7+- dom-parser-3.0.0
8+- generic-arbitrary-0.1.0
stack-18.18.yamlnew file+9
@@ -0,0 +1,9 @@
1+nix:
2+ packages:
3+ - zlib
4+
5+resolver: lts-18.18
6+extra-deps:
7+- git: https://github.com/typeable/dom-parser.git
8+ commit: 7d556ba528bfa216e99714f8a0d4d00f452803a9
9+- xml-lens-0.3.1
stack-19.6.yamlnew file+9
@@ -0,0 +1,9 @@
1+nix:
2+ packages:
3+ - zlib
4+
5+resolver: lts-19.6
6+extra-deps:
7+- git: https://github.com/typeable/dom-parser.git
8+ commit: 7d556ba528bfa216e99714f8a0d4d00f452803a9
9+- xml-lens-0.3.1
stack.yaml+7−7
@@ -1,9 +1,9 @@
1−resolver: lts-6.27
2−
3−packages:
4−- "."
1+nix:
2+ packages:
3+ - zlib
54
5+resolver: lts-20.16
66extra-deps:
7−- dom-parser-2.0.0
8−- type-fun-0.0.1
9−- open-union-0.2.0.0
7+ - git: https://github.com/typeable/dom-parser.git
8+ commit: 7d556ba528bfa216e99714f8a0d4d00f452803a9
9+ - xml-lens-0.3.1
test/Main.hs+26−1
@@ -1,6 +1,31 @@
1+{-# OPTIONS -fno-warn-unused-imports #-}
12module Main where
23
4+import Control.Exception
5+import Text.XML
6+import Data.Default
7+import System.IO.Unsafe
8+import Test.Hspec
9+import Test.Hspec.QuickCheck
10+import Test.QuickCheck
311import TestDefs
12+import Text.XML.DOM.Parser
13+import Text.XML.Writer
14+
15+isomorphicFoo :: XmlRoot -> Property
16+isomorphicFoo a = a === isogen
17+ where
18+ isogen :: XmlRoot
19+ isogen =
20+ let
21+ doc = document "Root" $ toXML a
22+ res = case runDomParser doc fromDom of
23+ Left e -> unsafePerformIO $ do
24+ pprint doc
25+ throwIO e
26+ Right a' -> a'
27+ in res
428
529main :: IO ()
6−main = return ()
30+main = hspec $ do
31+ prop "isomorphic" isomorphicFoo
test/TestDefs.hs+25−5
@@ -1,18 +1,19 @@
11{-# LANGUAGE NoImplicitPrelude #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE TemplateHaskell #-}
42
53{-# OPTIONS -ddump-splices #-}
64
75module TestDefs where
86
7+-- import Data.List.NonEmpty
98import Data.THGen.XML
9+import Test.QuickCheck.Arbitrary.Generic
10+import Test.QuickCheck.Instances ()
1011
11−"Bar" =:= enum
12+"Bar" =:= enum ParserAndGenerator
1213 & "baroque"
1314 & "bartender"
1415
15−"Quux" Exhaustive =:= enum
16+"Quux" Exhaustive =:= enum ParserAndGenerator
1617 & "ALL"
1718 & "YOUR"
1819 & "BASE"
@@ -21,7 +22,26 @@ import Data.THGen.XML
2122 & "TO"
2223 & "US"
2324
24−"Foo" =:= record
25+"Foo" =:= record ParserAndGenerator
26+ ^ "Shmuux" [t|XmlQuux|]
2527 + "Bar"
2628 ? "Baz" [t|Text|]
2729 !% "Quux"
30+ ?% "Muux" [t|XmlQuux|]
31+
32+"Root" =:= record ParserAndGenerator
33+ ! "{http://example.com/ns/my-namespace}Foo"
34+
35+instance Arbitrary XmlRoot where
36+ arbitrary = genericArbitrary
37+ shrink = genericShrink
38+
39+instance Arbitrary XmlFoo where
40+ arbitrary = genericArbitrary
41+ shrink = genericShrink
42+
43+#if __GLASGOW_HASKELL__ < 800
44+instance Arbitrary (NonEmpty XmlBar) where
45+ arbitrary = genericArbitrary
46+ shrink = genericShrink
47+#endif
xml-isogen.cabal+52−11
@@ -1,5 +1,5 @@
11name: xml-isogen
2−version: 0.1.0
2+version: 0.3.2
33synopsis: Generate XML-isomorphic types
44description:
55 TemplateHaskell generators for XML-isomorphic data types, including
@@ -14,39 +14,80 @@ author: Typeable.io contributors
1414maintainer: makeit@typeable.io
1515category: Data
1616build-type: Simple
17−extra-source-files: CHANGELOG.md
1817cabal-version: >=1.22
18+homepage: https://github.com/typeable/xml-isogen
19+tested-with: GHC == 7.10.3
20+ , GHC == 8.0.2
21+ , GHC == 8.2.2
22+ , GHC == 8.4.1
23+extra-source-files: CHANGELOG.md
24+ , README.md
25+
26+source-repository head
27+ type: git
28+ location: git@github.com:typeable/xml-isogen.git
1929
2030library
2131 exposed-modules: Data.THGen.Enum
22− Data.THGen.XML
23− Text.XML.ParentAttributes
24−
32+ , Data.THGen.XML
33+ , Data.THGen.XML.Internal
34+ , Text.XML.ParentAttributes
35+ , Text.XML.Nillable
36+ other-modules: Data.THGen.Compat
37+ , Data.THGen.Orphans
38+ , Text.XML.DOM.Parser.Internal.Content
2539 build-depends: QuickCheck >= 2.8
2640 , base >=4.8 && <5
2741 , dom-parser >= 2.0.0
42+ , deepseq
2843 , lens >= 4.13
2944 , mtl >= 2.2
45+ , scientific
3046 , semigroups >= 0.18
3147 , template-haskell >= 2.10
3248 , text >= 1.2
3349 , xml-conduit >= 1.0
3450 , xml-conduit-writer >= 0.1
3551
52+ ghc-options: -Wall
53+
3654 hs-source-dirs: src
3755
3856 default-language: Haskell2010
39− default-extensions: TemplateHaskell
40− LambdaCase
41− FlexibleInstances
42− TypeFamilies
43− TupleSections
57+ default-extensions: CPP
58+ , DeriveTraversable
59+ , FlexibleInstances
60+ , GeneralizedNewtypeDeriving
61+ , LambdaCase
62+ , TemplateHaskell
63+ , TupleSections
64+ , TypeFamilies
4465
4566test-suite spec
4667 type: exitcode-stdio-1.0
4768 hs-source-dirs: test
4869 main-is: Main.hs
4970 other-modules: TestDefs
50− build-depends: base, xml-isogen
71+ build-depends: base
72+ , QuickCheck
73+ , data-default
74+ , deepseq
75+ , dom-parser
76+ , generic-arbitrary
77+ , hspec
78+ , quickcheck-instances
79+ , semigroups
80+ , xml-conduit
81+ , xml-conduit-writer
82+ , xml-isogen
5183 default-language: Haskell2010
84+ default-extensions: CPP
85+ , DeriveGeneric
86+ , FlexibleInstances
87+ , LambdaCase
88+ , OverloadedStrings
89+ , StandaloneDeriving
90+ , TemplateHaskell
91+ , TupleSections
92+ , TypeFamilies
5293 ghc-options: -Wall -fno-warn-missing-signatures