git.iko.soy/xml-isogen
on master help sign in
swap
bb8d0088 ahead, 0 behind
3 files changed+438−348
since splitsnapshots
unifiedsplit
src/Data/THGen/XML.hs+18−344 src/Data/THGen/XML/Internal.hs+416 test/TestDefs.hs+4−4
src/Data/THGen/XML.hs+18−344
@@ -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 Both
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 Both
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 Both
97+> ! "author" [t|Person|].
9998> ...
10099
100+Both @record@ and @enum@ take a @GenType@ argument which tells it to generate
101+generator, parser or both. It's being used to optimize compilation time by
102+skipping the unnecessary TH instance generation.
103+
101104-}
102105
103106
@@ -105,6 +108,7 @@ module Data.THGen.XML
105108 ( Exhaustiveness(..)
106109 , PrefixName(..)
107110 , ExhaustivenessName(..)
111+ , GenType(..)
108112 , record
109113 , enum
110114 , (!)
@@ -117,342 +121,12 @@ module Data.THGen.XML
117121 , (^)
118122 , (=:=)
119123 -- Re-exports
120− , T.Text
121− , Int
122− , Integer
124+ , Text
125+ , P.Int
126+ , P.Integer
123127 ) where
124128
125−import Control.DeepSeq
126−import Control.Lens hiding (repeated, enum, (&))
127−import Control.Lens.Internal.FieldTH (makeFieldOpticsForDec)
128−import qualified Data.Char as C
129−import Data.List.NonEmpty (NonEmpty)
130−import Data.Maybe (maybeToList, mapMaybe)
131−import Data.String
132−import Data.THGen.Compat
133129import Data.THGen.Enum
134130import Data.THGen.XML.Internal
135−import qualified Data.Text as T
136−import GHC.Generics (Generic)
137−import qualified Language.Haskell.TH as TH
138−import Prelude hiding ((+), (*), (^))
139−import qualified Text.XML as X
140−import Text.XML.DOM.Parser hiding (parseContent)
141−import Text.XML.DOM.Parser.Internal.Content
142−import Text.XML.ParentAttributes
143−import qualified Text.XML.Writer as XW
144−
145−
146−appendField
147− :: XmlFieldPlural
148− -> IsoXmlDescRecord
149− -> IsoXmlDescPreField
150− -> IsoXmlDescRecord
151−appendField plural xrec (IsoXmlDescPreField name ty) =
152− let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty
153− in over _IsoXmlDescRecord (xfield:) xrec
154−
155−appendAttribute
156− :: XmlAttributePlural
157− -> IsoXmlDescRecord
158− -> IsoXmlDescPreAttribute
159− -> IsoXmlDescRecord
160−appendAttribute plural xrec (IsoXmlDescPreAttribute name ty) =
161− let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty
162− in over _IsoXmlDescRecord (xattribute:) xrec
163−
164−appendContent
165− :: IsoXmlDescRecord
166− -> IsoXmlDescPreContent
167− -> IsoXmlDescRecord
168−appendContent xrec (IsoXmlDescPreContent name ty) =
169− let xcontent = IsoXmlDescRecordContent $ IsoXmlDescContent name ty
170− in over _IsoXmlDescRecord (xcontent:) xrec
171−
172−(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
173−(!) = appendField XmlFieldPluralMandatory
174−(?) = appendField XmlFieldPluralOptional
175−(*) = appendField XmlFieldPluralRepeated
176−(+) = appendField XmlFieldPluralMultiplied
177−
178−(!%), (?%) :: IsoXmlDescRecord -> IsoXmlDescPreAttribute -> IsoXmlDescRecord
179−(!%) = appendAttribute XmlAttributePluralMandatory
180−(?%) = appendAttribute XmlAttributePluralOptional
181−
182−(^) :: IsoXmlDescRecord -> IsoXmlDescPreContent -> IsoXmlDescRecord
183−(^) = appendContent
184−
185−infixl 2 !
186−infixl 2 ?
187−infixl 2 *
188−infixl 2 +
189−infixl 2 !%
190−infixl 2 ?%
191−infixl 2 ^
192−
193−appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
194−appendEnumCon xenum xenumcon =
195− over _IsoXmlDescEnum (xenumcon:) xenum
196−
197−(&) :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
198−(&) = appendEnumCon
199−
200−infixl 2 &
201−
202−class Description name desc | desc -> name where
203− (=:=) :: name -> desc -> TH.DecsQ
204−
205−infix 0 =:=
206−
207−instance Description PrefixName IsoXmlDescRecord where
208− prefixName =:= descRecord =
209− let descRecordParts = descRecord ^. _IsoXmlDescRecord
210− in isoXmlGenerateDatatype prefixName (reverse descRecordParts)
211−
212−record :: IsoXmlDescRecord
213−record = IsoXmlDescRecord []
214−
215−enum :: IsoXmlDescEnum
216−enum = IsoXmlDescEnum []
217−
218−instance Description ExhaustivenessName IsoXmlDescEnum where
219− exhaustivenessName =:= descEnum =
220− let descEnumCons = descEnum ^. _IsoXmlDescEnum
221− in isoXmlGenerateEnum exhaustivenessName (reverse descEnumCons)
222−
223−instance IsString (TH.TypeQ -> IsoXmlDescPreField) where
224− fromString = IsoXmlDescPreField
225−
226−instance IsString IsoXmlDescPreField where
227− fromString name = IsoXmlDescPreField name ty
228− where
229− ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper (xmlLocalName name))
230−
231−instance IsString (TH.TypeQ -> IsoXmlDescPreAttribute) where
232− fromString = IsoXmlDescPreAttribute
233−
234−instance IsString (TH.TypeQ -> IsoXmlDescPreContent) where
235− fromString = IsoXmlDescPreContent
236−
237−instance IsString IsoXmlDescPreAttribute where
238− fromString name = IsoXmlDescPreAttribute name ty
239− where
240− ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)
241−
242−instance IsString IsoXmlDescPreContent where
243− fromString name = IsoXmlDescPreContent name ty
244− where
245− ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)
246−
247−instance s ~ String => IsString (s -> PrefixName) where
248− fromString = PrefixName
249−
250−instance IsString PrefixName where
251− fromString strName = PrefixName strName (makeNamePrefix strName)
252−
253−instance e ~ Exhaustiveness => IsString (e -> ExhaustivenessName) where
254− fromString = ExhaustivenessName
255−
256−instance IsString ExhaustivenessName where
257− fromString strName = ExhaustivenessName strName NonExhaustive
258−
259−makeNamePrefix :: String -> String
260−makeNamePrefix = map C.toLower . filter C.isUpper
261−
262−funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ
263−funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]
264−
265−isoXmlGenerateEnum
266− :: ExhaustivenessName -> [IsoXmlDescEnumCon] -> TH.DecsQ
267−isoXmlGenerateEnum (ExhaustivenessName strName' exh) enumCons = do
268− let
269− strName = "Xml" ++ strName'
270− strVals = map unIsoXmlDescEnumCon enumCons
271− enumDesc = EnumDesc exh strName strVals
272− name = TH.mkName strName
273− enumDecls <- enumGenerate enumDesc
274− toXmlInst <- do
275− TH.instanceD
276− (return [])
277− [t|XW.ToXML $(TH.conT name)|]
278− [funSimple 'XW.toXML [e|XW.toXML . T.pack . show|]]
279− toXmlAttributeInst <- do
280− TH.instanceD
281− (return [])
282− [t|ToXmlAttribute $(TH.conT name)|]
283− [funSimple 'toXmlAttribute [e|T.pack . show|]]
284− fromDomInst <- do
285− TH.instanceD
286− (return [])
287− [t|FromDom $(TH.conT name)|]
288− [funSimple 'fromDom [e|parseContent readContent|]]
289− fromAttributeInst <- do
290− TH.instanceD
291− (return [])
292− [t|FromAttribute $(TH.conT name)|]
293− [funSimple 'fromAttribute [e|readContent|]]
294− return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
295− fromDomInst, fromAttributeInst]
296−
297−isoXmlGenerateDatatype :: PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ
298−isoXmlGenerateDatatype (PrefixName strName' strPrefix') descRecordParts = do
299− let
300− isNewtype = length descRecordParts == 1
301− strName = "Xml" ++ strName'
302− strPrefix = "x" ++ strPrefix'
303− name = TH.mkName strName
304− fieldName str = "_" ++ strPrefix ++ over _head C.toUpper str
305− termDecl <- do
306− let
307− fields = do
308− descRecordPart <- descRecordParts
309− return $ case descRecordPart of
310− IsoXmlDescRecordField descField ->
311− let
312− IsoXmlDescField fieldPlural rawName fieldType = descField
313− fieldStrName = xmlLocalName rawName
314− fName = TH.mkName (fieldName fieldStrName)
315− fType = case fieldPlural of
316− XmlFieldPluralMandatory -> fieldType
317− XmlFieldPluralOptional -> [t| Maybe $fieldType |]
318− XmlFieldPluralRepeated -> [t| [$fieldType] |]
319− XmlFieldPluralMultiplied -> [t| NonEmpty $fieldType |]
320− in if isNewtype
321− then varStrictType fName (nonStrictType fType)
322− else varStrictType fName (strictType fType)
323− IsoXmlDescRecordAttribute descAttribute ->
324− let
325− IsoXmlDescAttribute
326− attributePlural attributeStrName attributeType = descAttribute
327− fName = TH.mkName (fieldName attributeStrName)
328− fType = case attributePlural of
329− XmlAttributePluralMandatory -> attributeType
330− XmlAttributePluralOptional -> [t| Maybe $attributeType |]
331− in if isNewtype
332− then varStrictType fName (nonStrictType fType)
333− else varStrictType fName (strictType fType)
334− IsoXmlDescRecordContent descContent ->
335− let
336− IsoXmlDescContent contentStrName contentType = descContent
337− fName = TH.mkName (fieldName contentStrName)
338− fType = contentType
339− in if isNewtype
340− then varStrictType fName (nonStrictType fType)
341− else varStrictType fName (strictType fType)
342− if isNewtype
343− -- generate a newtype instead to do less allocations later
344− then newtypeD name (TH.recC name fields) [''Eq, ''Show, ''Generic]
345− else dataD name [TH.recC name fields] [''Eq, ''Show, ''Generic]
346− lensDecls <- makeFieldOpticsForDec lensRules termDecl
347− nfDataInst <- do
348− TH.instanceD
349− (return [])
350− [t|NFData $(TH.conT name)|]
351− [ ]
352− fromDomInst <- do
353− let
354− exprHeader = [e|pure $(TH.conE name)|]
355− exprRecordParts = do
356− descRecordPart <- descRecordParts
357− return $ case descRecordPart of
358− IsoXmlDescRecordField descField ->
359− let
360− IsoXmlDescField fieldPlural rawName _ = descField
361− fieldStrName = xmlLocalName rawName
362− exprFieldStrName = TH.litE (TH.stringL fieldStrName)
363− fieldParse = case fieldPlural of
364− XmlFieldPluralMandatory -> [e|inElem|]
365− _ -> [e|inElemTrav|]
366− in
367− [e|$fieldParse $exprFieldStrName fromDom|]
368− IsoXmlDescRecordAttribute descAttribute ->
369− let
370− IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute
371− exprAttributeStrName = TH.litE (TH.stringL attributeStrName)
372− attributeParse = case attributePlural of
373− XmlAttributePluralMandatory -> [e|parseAttribute|]
374− XmlAttributePluralOptional -> [e|parseAttributeMaybe|]
375− in
376− [e|$attributeParse $exprAttributeStrName fromAttribute|]
377− IsoXmlDescRecordContent _ -> [e|parseContent fromAttribute|]
378− fromDomExpr = foldl (\e fe -> [e| $e <*> $fe |]) exprHeader exprRecordParts
379− TH.instanceD
380− (return [])
381− [t|FromDom $(TH.conT name)|]
382− [ funSimple 'fromDom fromDomExpr ]
383−
384− toXmlInst <- do
385− objName <- TH.newName strPrefix
386− let
387− exprFields = do
388− descRecordPart <- descRecordParts
389− case descRecordPart of
390− IsoXmlDescRecordField (IsoXmlDescField fieldPlural rawName _) -> do
391− let
392− fieldStrName = xmlLocalName rawName
393− fName = TH.mkName (fieldName fieldStrName)
394− exprFieldStrName = TH.litE (TH.stringL rawName)
395− exprForField = case fieldPlural of
396− XmlFieldPluralMandatory -> [e|id|]
397− _ -> [e|traverse|]
398− exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
399− exprFieldRender =
400− [e|(\a ->
401− XW.elementA $exprFieldStrName (toXmlParentAttributes a) a)|]
402− return [e|$exprForField $exprFieldRender $exprFieldValue|]
403− IsoXmlDescRecordContent (IsoXmlDescContent rawName _) -> do
404− let
405− fieldStrName = xmlLocalName rawName
406− fName = TH.mkName (fieldName fieldStrName)
407− exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
408− return [e|XW.content . toXmlAttribute $ $exprFieldValue|]
409− _ -> []
410− toXmlExpr
411− = TH.lamE [if null exprFields then TH.wildP else TH.varP objName]
412− $ foldr (\fe e -> [e|$fe *> $e|]) [e|return ()|] exprFields
413− TH.instanceD
414− (return [])
415− [t|XW.ToXML $(TH.conT name)|]
416− [funSimple 'XW.toXML toXmlExpr]
417−
418− toXmlParentAttributesInst <- do
419− objName <- TH.newName strPrefix
420− let
421− exprAttributes = do
422− descRecordPart <- descRecordParts
423− IsoXmlDescAttribute attributePlural attributeStrName _ <-
424− maybeToList $ case descRecordPart of
425− IsoXmlDescRecordAttribute descAttribute -> Just descAttribute
426− _ -> Nothing
427− let
428− fName = TH.mkName (fieldName attributeStrName)
429− exprAttrStrName = TH.litE (TH.stringL attributeStrName)
430− exprAttrValue = [e|$(TH.varE fName) $(TH.varE objName)|]
431− exprAttrWrap = case attributePlural of
432− XmlAttributePluralMandatory -> [e|Just . toXmlAttribute|]
433− XmlAttributePluralOptional -> [e|fmap toXmlAttribute|]
434− return [e|($exprAttrStrName, $exprAttrWrap $exprAttrValue)|]
435− toXmlParentAttributesExpr
436− = TH.lamE [if null exprAttributes then TH.wildP else TH.varP objName]
437− $ [e|mapMaybe distribPair $(TH.listE exprAttributes)|]
438−#if __GLASGOW_HASKELL__ < 800
439− TH.instanceD
440−#else
441− TH.instanceWithOverlapD (Just TH.Overlapping)
442−#endif
443− (return [])
444− [t|ToXmlParentAttributes $(TH.conT name)|]
445− [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]
446−
447− return $ [termDecl] ++ lensDecls ++
448− [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]
449−
450−distribPair :: Functor f => (a, f b) -> f (a, b)
451−distribPair (a, fb) = (a,) <$> fb
452−
453−-- | Get a local part of (possibly) fully qualified 'X.Name':
454−--
455−-- >>> xmlLocalName "{http://example.com/ns/my-namespace}my-name"
456−-- "my-name"
457−xmlLocalName :: String -> String
458−xmlLocalName = T.unpack . X.nameLocalName . fromString
131+import Data.Text
132+import qualified Prelude as P
src/Data/THGen/XML/Internal.hsnew file+416
@@ -0,0 +1,416 @@
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, (&))
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
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+
27+data GenType = Parser | Generator | Both
28+
29+data XmlFieldPlural
30+ = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
31+ | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)
32+ | XmlFieldPluralRepeated -- Occurs 0 or more times (List)
33+ | XmlFieldPluralMultiplied -- Occurs 1 or more times (NonEmpty)
34+
35+data XmlAttributePlural
36+ = XmlAttributePluralMandatory -- Occurs exactly 1 time (Identity)
37+ | XmlAttributePluralOptional -- Occurs 0 or 1 times (Maybe)
38+
39+data PrefixName = PrefixName String String
40+
41+data IsoXmlDescPreField = IsoXmlDescPreField String TH.TypeQ
42+
43+data IsoXmlDescPreAttribute = IsoXmlDescPreAttribute String TH.TypeQ
44+
45+data IsoXmlDescPreContent = IsoXmlDescPreContent String TH.TypeQ
46+
47+data IsoXmlDescField = IsoXmlDescField XmlFieldPlural String TH.TypeQ
48+
49+data IsoXmlDescAttribute = IsoXmlDescAttribute XmlAttributePlural String TH.TypeQ
50+
51+data IsoXmlDescContent = IsoXmlDescContent String TH.TypeQ
52+
53+data IsoXmlDescRecordPart
54+ = IsoXmlDescRecordField IsoXmlDescField
55+ | IsoXmlDescRecordAttribute IsoXmlDescAttribute
56+ | IsoXmlDescRecordContent IsoXmlDescContent
57+
58+data IsoXmlDescRecord = IsoXmlDescRecord GenType [IsoXmlDescRecordPart]
59+
60+makePrisms ''IsoXmlDescRecord
61+
62+data ExhaustivenessName = ExhaustivenessName String Exhaustiveness
63+
64+newtype IsoXmlDescEnumCon
65+ = IsoXmlDescEnumCon { unIsoXmlDescEnumCon :: String }
66+
67+instance IsString IsoXmlDescEnumCon where
68+ fromString = IsoXmlDescEnumCon
69+
70+data IsoXmlDescEnum = IsoXmlDescEnum GenType [IsoXmlDescEnumCon]
71+
72+makePrisms ''IsoXmlDescEnum
73+
74+appendField
75+ :: XmlFieldPlural
76+ -> IsoXmlDescRecord
77+ -> IsoXmlDescPreField
78+ -> IsoXmlDescRecord
79+appendField plural (IsoXmlDescRecord genType fields) (IsoXmlDescPreField name ty) =
80+ let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty
81+ in IsoXmlDescRecord genType (xfield:fields)
82+
83+appendAttribute
84+ :: XmlAttributePlural
85+ -> IsoXmlDescRecord
86+ -> IsoXmlDescPreAttribute
87+ -> IsoXmlDescRecord
88+appendAttribute plural (IsoXmlDescRecord genType fields) (IsoXmlDescPreAttribute name ty) =
89+ let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty
90+ in IsoXmlDescRecord genType (xattribute:fields)
91+
92+appendContent
93+ :: IsoXmlDescRecord
94+ -> IsoXmlDescPreContent
95+ -> IsoXmlDescRecord
96+appendContent (IsoXmlDescRecord genType fields) (IsoXmlDescPreContent name ty) =
97+ let xcontent = IsoXmlDescRecordContent $ IsoXmlDescContent name ty
98+ in IsoXmlDescRecord genType (xcontent:fields)
99+
100+(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
101+(!) = appendField XmlFieldPluralMandatory
102+(?) = appendField XmlFieldPluralOptional
103+(*) = appendField XmlFieldPluralRepeated
104+(+) = appendField XmlFieldPluralMultiplied
105+
106+(!%), (?%) :: IsoXmlDescRecord -> IsoXmlDescPreAttribute -> IsoXmlDescRecord
107+(!%) = appendAttribute XmlAttributePluralMandatory
108+(?%) = appendAttribute XmlAttributePluralOptional
109+
110+(^) :: IsoXmlDescRecord -> IsoXmlDescPreContent -> IsoXmlDescRecord
111+(^) = appendContent
112+
113+infixl 2 !
114+infixl 2 ?
115+infixl 2 *
116+infixl 2 +
117+infixl 2 !%
118+infixl 2 ?%
119+infixl 2 ^
120+
121+appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
122+appendEnumCon (IsoXmlDescEnum genType enumCons) xenumcon =
123+ IsoXmlDescEnum genType (xenumcon:enumCons)
124+
125+(&) :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
126+(&) = appendEnumCon
127+
128+infixl 2 &
129+
130+class Description name desc | desc -> name where
131+ (=:=) :: name -> desc -> TH.DecsQ
132+
133+infix 0 =:=
134+
135+instance Description PrefixName IsoXmlDescRecord where
136+ prefixName =:= (IsoXmlDescRecord genType descRecordParts) =
137+ isoXmlGenerateDatatype genType prefixName (reverse descRecordParts)
138+
139+record :: GenType -> IsoXmlDescRecord
140+record gt = IsoXmlDescRecord gt []
141+
142+enum :: GenType -> IsoXmlDescEnum
143+enum gt = IsoXmlDescEnum gt []
144+
145+instance Description ExhaustivenessName IsoXmlDescEnum where
146+ exhaustivenessName =:= (IsoXmlDescEnum genType descEnumCons) =
147+ isoXmlGenerateEnum genType exhaustivenessName (reverse descEnumCons)
148+
149+instance IsString (TH.TypeQ -> IsoXmlDescPreField) where
150+ fromString = IsoXmlDescPreField
151+
152+instance IsString IsoXmlDescPreField where
153+ fromString name = IsoXmlDescPreField name ty
154+ where
155+ ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper (xmlLocalName name))
156+
157+instance IsString (TH.TypeQ -> IsoXmlDescPreAttribute) where
158+ fromString = IsoXmlDescPreAttribute
159+
160+instance IsString (TH.TypeQ -> IsoXmlDescPreContent) where
161+ fromString = IsoXmlDescPreContent
162+
163+instance IsString IsoXmlDescPreAttribute where
164+ fromString name = IsoXmlDescPreAttribute name ty
165+ where
166+ ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)
167+
168+instance IsString IsoXmlDescPreContent where
169+ fromString name = IsoXmlDescPreContent name ty
170+ where
171+ ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)
172+
173+instance s ~ String => IsString (s -> PrefixName) where
174+ fromString = PrefixName
175+
176+instance IsString PrefixName where
177+ fromString strName = PrefixName strName (makeNamePrefix strName)
178+
179+instance e ~ Exhaustiveness => IsString (e -> ExhaustivenessName) where
180+ fromString = ExhaustivenessName
181+
182+instance IsString ExhaustivenessName where
183+ fromString strName = ExhaustivenessName strName NonExhaustive
184+
185+makeNamePrefix :: String -> String
186+makeNamePrefix = map C.toLower . filter C.isUpper
187+
188+funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ
189+funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]
190+
191+isoXmlGenerateEnum
192+ :: GenType
193+ -> ExhaustivenessName
194+ -> [IsoXmlDescEnumCon]
195+ -> TH.DecsQ
196+isoXmlGenerateEnum genType (ExhaustivenessName strName' exh) enumCons = do
197+ let
198+ strName = "Xml" ++ strName'
199+ strVals = map unIsoXmlDescEnumCon enumCons
200+ enumDesc = EnumDesc exh strName strVals
201+ name = TH.mkName strName
202+ enumDecls <- enumGenerate enumDesc
203+ let
204+ genToXmlInst = do
205+ TH.instanceD
206+ (return [])
207+ [t|XW.ToXML $(TH.conT name)|]
208+ [funSimple 'XW.toXML [e|XW.toXML . T.pack . show|]]
209+ genToXmlAttributeInst = do
210+ TH.instanceD
211+ (return [])
212+ [t|ToXmlAttribute $(TH.conT name)|]
213+ [funSimple 'toXmlAttribute [e|T.pack . show|]]
214+ genFromDomInst = do
215+ TH.instanceD
216+ (return [])
217+ [t|FromDom $(TH.conT name)|]
218+ [funSimple 'fromDom [e|parseContent readContent|]]
219+ genFromAttributeInst = do
220+ TH.instanceD
221+ (return [])
222+ [t|FromAttribute $(TH.conT name)|]
223+ [funSimple 'fromAttribute [e|readContent|]]
224+ case genType of
225+ Generator -> do
226+ toXmlInst <- genToXmlInst
227+ toXmlAttributeInst <- genToXmlAttributeInst
228+ return $ enumDecls ++ [toXmlInst, toXmlAttributeInst]
229+ Parser -> do
230+ fromDomInst <- genFromDomInst
231+ fromAttributeInst <- genFromAttributeInst
232+ return $ enumDecls ++ [fromDomInst, fromAttributeInst]
233+ Both -> do
234+ toXmlInst <- genToXmlInst
235+ toXmlAttributeInst <- genToXmlAttributeInst
236+ fromDomInst <- genFromDomInst
237+ fromAttributeInst <- genFromAttributeInst
238+ return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
239+ fromDomInst, fromAttributeInst]
240+
241+isoXmlGenerateDatatype :: GenType -> PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ
242+isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts = do
243+ let
244+ isNewtype = length descRecordParts == 1
245+ strName = "Xml" ++ strName'
246+ strPrefix = "x" ++ strPrefix'
247+ name = TH.mkName strName
248+ fieldName str = "_" ++ strPrefix ++ over _head C.toUpper str
249+ termDecl <- do
250+ let
251+ fields = do
252+ descRecordPart <- descRecordParts
253+ return $ case descRecordPart of
254+ IsoXmlDescRecordField descField ->
255+ let
256+ IsoXmlDescField fieldPlural rawName fieldType = descField
257+ fieldStrName = xmlLocalName rawName
258+ fName = TH.mkName (fieldName fieldStrName)
259+ fType = case fieldPlural of
260+ XmlFieldPluralMandatory -> fieldType
261+ XmlFieldPluralOptional -> [t| Maybe $fieldType |]
262+ XmlFieldPluralRepeated -> [t| [$fieldType] |]
263+ XmlFieldPluralMultiplied -> [t| NonEmpty $fieldType |]
264+ in if isNewtype
265+ then THC.varStrictType fName (THC.nonStrictType fType)
266+ else THC.varStrictType fName (THC.strictType fType)
267+ IsoXmlDescRecordAttribute descAttribute ->
268+ let
269+ IsoXmlDescAttribute
270+ attributePlural attributeStrName attributeType = descAttribute
271+ fName = TH.mkName (fieldName attributeStrName)
272+ fType = case attributePlural of
273+ XmlAttributePluralMandatory -> attributeType
274+ XmlAttributePluralOptional -> [t| Maybe $attributeType |]
275+ in if isNewtype
276+ then THC.varStrictType fName (THC.nonStrictType fType)
277+ else THC.varStrictType fName (THC.strictType fType)
278+ IsoXmlDescRecordContent descContent ->
279+ let
280+ IsoXmlDescContent contentStrName contentType = descContent
281+ fName = TH.mkName (fieldName contentStrName)
282+ fType = contentType
283+ in if isNewtype
284+ then THC.varStrictType fName (THC.nonStrictType fType)
285+ else THC.varStrictType fName (THC.strictType fType)
286+ if isNewtype
287+ -- generate a newtype instead to do less allocations later
288+ then THC.newtypeD name (TH.recC name fields) [''Eq, ''Show, ''Generic]
289+ else THC.dataD name [TH.recC name fields] [''Eq, ''Show, ''Generic]
290+ lensDecls <- makeFieldOpticsForDec lensRules termDecl
291+ nfDataInst <- do
292+ TH.instanceD
293+ (return [])
294+ [t|NFData $(TH.conT name)|]
295+ [ ]
296+
297+ let
298+ genFromDomInst = do
299+ let
300+ exprHeader = [e|pure $(TH.conE name)|]
301+ exprRecordParts = do
302+ descRecordPart <- descRecordParts
303+ return $ case descRecordPart of
304+ IsoXmlDescRecordField descField ->
305+ let
306+ IsoXmlDescField fieldPlural rawName _ = descField
307+ fieldStrName = xmlLocalName rawName
308+ exprFieldStrName = TH.litE (TH.stringL fieldStrName)
309+ fieldParse = case fieldPlural of
310+ XmlFieldPluralMandatory -> [e|inElem|]
311+ _ -> [e|inElemTrav|]
312+ in
313+ [e|$fieldParse $exprFieldStrName fromDom|]
314+ IsoXmlDescRecordAttribute descAttribute ->
315+ let
316+ IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute
317+ exprAttributeStrName = TH.litE (TH.stringL attributeStrName)
318+ attributeParse = case attributePlural of
319+ XmlAttributePluralMandatory -> [e|parseAttribute|]
320+ XmlAttributePluralOptional -> [e|parseAttributeMaybe|]
321+ in
322+ [e|$attributeParse $exprAttributeStrName fromAttribute|]
323+ IsoXmlDescRecordContent _ -> [e|parseContent fromAttribute|]
324+ fromDomExpr = foldl (\e fe -> [e| $e <*> $fe |]) exprHeader exprRecordParts
325+ TH.instanceD
326+ (return [])
327+ [t|FromDom $(TH.conT name)|]
328+ [ funSimple 'fromDom fromDomExpr ]
329+
330+ genToXmlInst = do
331+ objName <- TH.newName strPrefix
332+ let
333+ exprFields = do
334+ descRecordPart <- descRecordParts
335+ case descRecordPart of
336+ IsoXmlDescRecordField (IsoXmlDescField fieldPlural rawName _) -> do
337+ let
338+ fieldStrName = xmlLocalName rawName
339+ fName = TH.mkName (fieldName fieldStrName)
340+ exprFieldStrName = TH.litE (TH.stringL rawName)
341+ exprForField = case fieldPlural of
342+ XmlFieldPluralMandatory -> [e|id|]
343+ _ -> [e|traverse|]
344+ exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
345+ exprFieldRender =
346+ [e|(\a ->
347+ XW.elementA $exprFieldStrName (toXmlParentAttributes a) a)|]
348+ return [e|$exprForField $exprFieldRender $exprFieldValue|]
349+ IsoXmlDescRecordContent (IsoXmlDescContent rawName _) -> do
350+ let
351+ fieldStrName = xmlLocalName rawName
352+ fName = TH.mkName (fieldName fieldStrName)
353+ exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
354+ return [e|XW.content . toXmlAttribute $ $exprFieldValue|]
355+ _ -> []
356+ toXmlExpr
357+ = TH.lamE [if null exprFields then TH.wildP else TH.varP objName]
358+ $ foldr (\fe e -> [e|$fe *> $e|]) [e|return ()|] exprFields
359+ TH.instanceD
360+ (return [])
361+ [t|XW.ToXML $(TH.conT name)|]
362+ [funSimple 'XW.toXML toXmlExpr]
363+ genToXmlParentAttributeInst = do
364+ objName <- TH.newName strPrefix
365+ let
366+ exprAttributes = do
367+ descRecordPart <- descRecordParts
368+ IsoXmlDescAttribute attributePlural attributeStrName _ <-
369+ maybeToList $ case descRecordPart of
370+ IsoXmlDescRecordAttribute descAttribute -> Just descAttribute
371+ _ -> Nothing
372+ let
373+ fName = TH.mkName (fieldName attributeStrName)
374+ exprAttrStrName = TH.litE (TH.stringL attributeStrName)
375+ exprAttrValue = [e|$(TH.varE fName) $(TH.varE objName)|]
376+ exprAttrWrap = case attributePlural of
377+ XmlAttributePluralMandatory -> [e|Just . toXmlAttribute|]
378+ XmlAttributePluralOptional -> [e|fmap toXmlAttribute|]
379+ return [e|($exprAttrStrName, $exprAttrWrap $exprAttrValue)|]
380+ toXmlParentAttributesExpr
381+ = TH.lamE [if null exprAttributes then TH.wildP else TH.varP objName]
382+ $ [e|mapMaybe distribPair $(TH.listE exprAttributes)|]
383+#if __GLASGOW_HASKELL__ < 800
384+ TH.instanceD
385+#else
386+ TH.instanceWithOverlapD (Just TH.Overlapping)
387+#endif
388+ (return [])
389+ [t|ToXmlParentAttributes $(TH.conT name)|]
390+ [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]
391+
392+ case genType of
393+ Generator -> do
394+ toXmlInst <- genToXmlInst
395+ toXmlParentAttributesInst <- genToXmlParentAttributeInst
396+ return $ [termDecl] ++ lensDecls ++
397+ [toXmlInst, toXmlParentAttributesInst, nfDataInst]
398+ Parser -> do
399+ fromDomInst <- genFromDomInst
400+ return $ [termDecl] ++ lensDecls ++ [fromDomInst, nfDataInst]
401+ Both -> do
402+ toXmlInst <- genToXmlInst
403+ toXmlParentAttributesInst <- genToXmlParentAttributeInst
404+ fromDomInst <- genFromDomInst
405+ return $ [termDecl] ++ lensDecls ++
406+ [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]
407+
408+distribPair :: Functor f => (a, f b) -> f (a, b)
409+distribPair (a, fb) = (a,) <$> fb
410+
411+-- | Get a local part of (possibly) fully qualified 'X.Name':
412+--
413+-- >>> xmlLocalName "{http://example.com/ns/my-namespace}my-name"
414+-- "my-name"
415+xmlLocalName :: String -> String
416+xmlLocalName = T.unpack . X.nameLocalName . fromString
test/TestDefs.hs+4−4
@@ -9,11 +9,11 @@ import Data.THGen.XML
99import Test.QuickCheck.Arbitrary.Generic
1010import Test.QuickCheck.Instances ()
1111
12−"Bar" =:= enum
12+"Bar" =:= enum Both
1313 & "baroque"
1414 & "bartender"
1515
16−"Quux" Exhaustive =:= enum
16+"Quux" Exhaustive =:= enum Both
1717 & "ALL"
1818 & "YOUR"
1919 & "BASE"
@@ -22,14 +22,14 @@ import Test.QuickCheck.Instances ()
2222 & "TO"
2323 & "US"
2424
25−"Foo" =:= record
25+"Foo" =:= record Both
2626 ^ "Shmuux" [t|XmlQuux|]
2727 + "Bar"
2828 ? "Baz" [t|Text|]
2929 !% "Quux"
3030 ?% "Muux" [t|XmlQuux|]
3131
32−"Root" =:= record
32+"Root" =:= record Both
3333 ! "{http://example.com/ns/my-namespace}Foo"
3434
3535instance Arbitrary XmlRoot where