git.iko.soy/xml-isogen
on master help sign in
Merge pull request #18 from typeable/generator-type
bb8d008Denis Redozubov
src/Data/THGen/XML.hs+12−7
unifiedsplit
@@ -22,7 +22,7 @@ wrapper around the field type:
22
22
23Example 1.
23Example 1.
24
24
25−> "Color" =:= enum
25+> "Color" =:= enum Both
26> & "R"
26> & "R"
27> & "G"
27> & "G"
28> & "B"
28> & "B"
@@ -40,7 +40,7 @@ to be either @R@, @G@ or @B@.
40
40
41Example 2.
41Example 2.
42
42
43−> "Message" =:= record
43+> "Message" =:= record Both
44> ! "author"
44> ! "author"
45> + "recipient"
45> + "recipient"
46> ? "message" [t|Text|]
46> ? "message" [t|Text|]
@@ -67,10 +67,10 @@ enumeration is exhaustive (contains only the listed constructors) or
67non-exhaustive (also contains a constructor for unknown values; this
67non-exhaustive (also contains a constructor for unknown values; this
68is the default):
68is the default):
69
69
70−> "Enum1" Exhaustive =:= enum
70+> "Enum1" Exhaustive =:= enum Generator
71> ...
71> ...
72
72
73−> "Enum2" NonExhaustive =:= enum
73+> "Enum2" NonExhaustive =:= enum Generator
74> ...
74> ...
75
75
76To 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
@@ -78,7 +78,7 @@ the data type to be generated. The prefix for the record fields is
78inferred automatically by taking all of the uppercase letters in the
78inferred automatically by taking all of the uppercase letters in the
79name. You can override it manually like so:
79name. You can override it manually like so:
80
80
81−> "Reference" "ref" =:= record
81+> "Reference" "ref" =:= record Parser
82> ...
82> ...
83
83
84To 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
@@ -93,10 +93,14 @@ The type of the field is inferred automatically from its name, so
93if 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
94override the type by specifying it in quasiquotes like so:
94override the type by specifying it in quasiquotes like so:
95
95
96−> "Message" =:= record
96+> "Message" =:= record Both
97−> ! "author" [t|Person|]
97+> ! "author" [t|Person|].
98> ...
98> ...
99
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+
100-}
104-}
101
105
102
106
@@ -104,6 +108,7 @@ module Data.THGen.XML
104 ( Exhaustiveness(..)
108 ( Exhaustiveness(..)
105 , PrefixName(..)
109 , PrefixName(..)
106 , ExhaustivenessName(..)
110 , ExhaustivenessName(..)
111+ , GenType(..)
107 , record
112 , record
108 , enum
113 , enum
109 , (!)
114 , (!)
src/Data/THGen/XML/Internal.hs+173−140
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE UndecidableInstances #-}
2{-# LANGUAGE UndecidableInstances #-}
2{-# LANGUAGE FunctionalDependencies #-}
3{-# LANGUAGE FunctionalDependencies #-}
3
4
@@ -23,6 +24,8 @@ import Text.XML.ParentAttributes
23import qualified Text.XML.Writer as XW
24import qualified Text.XML.Writer as XW
24
25
25
26
27+data GenType = Parser | Generator | Both
28+
26data XmlFieldPlural
29data XmlFieldPlural
27 = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
30 = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
28 | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)
31 | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)
@@ -52,7 +55,7 @@ data IsoXmlDescRecordPart
52 | IsoXmlDescRecordAttribute IsoXmlDescAttribute
55 | IsoXmlDescRecordAttribute IsoXmlDescAttribute
53 | IsoXmlDescRecordContent IsoXmlDescContent
56 | IsoXmlDescRecordContent IsoXmlDescContent
54
57
55−newtype IsoXmlDescRecord = IsoXmlDescRecord [IsoXmlDescRecordPart]
58+data IsoXmlDescRecord = IsoXmlDescRecord GenType [IsoXmlDescRecordPart]
56
59
57makePrisms ''IsoXmlDescRecord
60makePrisms ''IsoXmlDescRecord
58
61
@@ -64,7 +67,7 @@ newtype IsoXmlDescEnumCon
64instance IsString IsoXmlDescEnumCon where
67instance IsString IsoXmlDescEnumCon where
65 fromString = IsoXmlDescEnumCon
68 fromString = IsoXmlDescEnumCon
66
69
67−data IsoXmlDescEnum = IsoXmlDescEnum [IsoXmlDescEnumCon]
70+data IsoXmlDescEnum = IsoXmlDescEnum GenType [IsoXmlDescEnumCon]
68
71
69makePrisms ''IsoXmlDescEnum
72makePrisms ''IsoXmlDescEnum
70
73
@@ -73,26 +76,26 @@ appendField
73 -> IsoXmlDescRecord
76 -> IsoXmlDescRecord
74 -> IsoXmlDescPreField
77 -> IsoXmlDescPreField
75 -> IsoXmlDescRecord
78 -> IsoXmlDescRecord
76−appendField plural xrec (IsoXmlDescPreField name ty) =
79+appendField plural (IsoXmlDescRecord genType fields) (IsoXmlDescPreField name ty) =
77 let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty
80 let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty
78− in over _IsoXmlDescRecord (xfield:) xrec
81+ in IsoXmlDescRecord genType (xfield:fields)
79
82
80appendAttribute
83appendAttribute
81 :: XmlAttributePlural
84 :: XmlAttributePlural
82 -> IsoXmlDescRecord
85 -> IsoXmlDescRecord
83 -> IsoXmlDescPreAttribute
86 -> IsoXmlDescPreAttribute
84 -> IsoXmlDescRecord
87 -> IsoXmlDescRecord
85−appendAttribute plural xrec (IsoXmlDescPreAttribute name ty) =
88+appendAttribute plural (IsoXmlDescRecord genType fields) (IsoXmlDescPreAttribute name ty) =
86 let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty
89 let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty
87− in over _IsoXmlDescRecord (xattribute:) xrec
90+ in IsoXmlDescRecord genType (xattribute:fields)
88
91
89appendContent
92appendContent
90 :: IsoXmlDescRecord
93 :: IsoXmlDescRecord
91 -> IsoXmlDescPreContent
94 -> IsoXmlDescPreContent
92 -> IsoXmlDescRecord
95 -> IsoXmlDescRecord
93−appendContent xrec (IsoXmlDescPreContent name ty) =
96+appendContent (IsoXmlDescRecord genType fields) (IsoXmlDescPreContent name ty) =
94 let xcontent = IsoXmlDescRecordContent $ IsoXmlDescContent name ty
97 let xcontent = IsoXmlDescRecordContent $ IsoXmlDescContent name ty
95− in over _IsoXmlDescRecord (xcontent:) xrec
98+ in IsoXmlDescRecord genType (xcontent:fields)
96
99
97(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
100(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
98(!) = appendField XmlFieldPluralMandatory
101(!) = appendField XmlFieldPluralMandatory
@@ -116,8 +119,8 @@ infixl 2 ?%
116infixl 2 ^
119infixl 2 ^
117
120
118appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
121appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
119−appendEnumCon xenum xenumcon =
122+appendEnumCon (IsoXmlDescEnum genType enumCons) xenumcon =
120− over _IsoXmlDescEnum (xenumcon:) xenum
123+ IsoXmlDescEnum genType (xenumcon:enumCons)
121
124
122(&) :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
125(&) :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
123(&) = appendEnumCon
126(&) = appendEnumCon
@@ -130,20 +133,18 @@ class Description name desc | desc -> name where
130infix 0 =:=
133infix 0 =:=
131
134
132instance Description PrefixName IsoXmlDescRecord where
135instance Description PrefixName IsoXmlDescRecord where
133− prefixName =:= descRecord =
136+ prefixName =:= (IsoXmlDescRecord genType descRecordParts) =
134− let descRecordParts = descRecord ^. _IsoXmlDescRecord
135− in isoXmlGenerateDatatype prefixName (reverse descRecordParts)
137+ isoXmlGenerateDatatype genType prefixName (reverse descRecordParts)
136
138
137−record :: IsoXmlDescRecord
139+record :: GenType -> IsoXmlDescRecord
138−record = IsoXmlDescRecord []
140+record gt = IsoXmlDescRecord gt []
139
141
140−enum :: IsoXmlDescEnum
142+enum :: GenType -> IsoXmlDescEnum
141−enum = IsoXmlDescEnum []
143+enum gt = IsoXmlDescEnum gt []
142
144
143instance Description ExhaustivenessName IsoXmlDescEnum where
145instance Description ExhaustivenessName IsoXmlDescEnum where
144− exhaustivenessName =:= descEnum =
146+ exhaustivenessName =:= (IsoXmlDescEnum genType descEnumCons) =
145− let descEnumCons = descEnum ^. _IsoXmlDescEnum
146− in isoXmlGenerateEnum exhaustivenessName (reverse descEnumCons)
147+ isoXmlGenerateEnum genType exhaustivenessName (reverse descEnumCons)
147
148
148instance IsString (TH.TypeQ -> IsoXmlDescPreField) where
149instance IsString (TH.TypeQ -> IsoXmlDescPreField) where
149 fromString = IsoXmlDescPreField
150 fromString = IsoXmlDescPreField
@@ -188,39 +189,57 @@ funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ
188funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]
189funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]
189
190
190isoXmlGenerateEnum
191isoXmlGenerateEnum
192+ :: GenType
191− :: ExhaustivenessName -> [IsoXmlDescEnumCon] -> TH.DecsQ
193+ -> ExhaustivenessName
194+ -> [IsoXmlDescEnumCon]
195+ -> TH.DecsQ
192−isoXmlGenerateEnum (ExhaustivenessName strName' exh) enumCons = do
196+isoXmlGenerateEnum genType (ExhaustivenessName strName' exh) enumCons = do
193 let
197 let
194 strName = "Xml" ++ strName'
198 strName = "Xml" ++ strName'
195 strVals = map unIsoXmlDescEnumCon enumCons
199 strVals = map unIsoXmlDescEnumCon enumCons
196 enumDesc = EnumDesc exh strName strVals
200 enumDesc = EnumDesc exh strName strVals
197 name = TH.mkName strName
201 name = TH.mkName strName
198 enumDecls <- enumGenerate enumDesc
202 enumDecls <- enumGenerate enumDesc
199− toXmlInst <- do
203+ let
204+ genToXmlInst = do
200− TH.instanceD
205+ TH.instanceD
201− (return [])
206+ (return [])
202− [t|XW.ToXML $(TH.conT name)|]
207+ [t|XW.ToXML $(TH.conT name)|]
203− [funSimple 'XW.toXML [e|XW.toXML . T.pack . show|]]
208+ [funSimple 'XW.toXML [e|XW.toXML . T.pack . show|]]
204− toXmlAttributeInst <- do
209+ genToXmlAttributeInst = do
205− TH.instanceD
210+ TH.instanceD
206− (return [])
211+ (return [])
207− [t|ToXmlAttribute $(TH.conT name)|]
212+ [t|ToXmlAttribute $(TH.conT name)|]
208− [funSimple 'toXmlAttribute [e|T.pack . show|]]
213+ [funSimple 'toXmlAttribute [e|T.pack . show|]]
209− fromDomInst <- do
214+ genFromDomInst = do
210− TH.instanceD
215+ TH.instanceD
211− (return [])
216+ (return [])
212− [t|FromDom $(TH.conT name)|]
217+ [t|FromDom $(TH.conT name)|]
213− [funSimple 'fromDom [e|parseContent readContent|]]
218+ [funSimple 'fromDom [e|parseContent readContent|]]
214− fromAttributeInst <- do
219+ genFromAttributeInst = do
215− TH.instanceD
220+ TH.instanceD
216− (return [])
221+ (return [])
217− [t|FromAttribute $(TH.conT name)|]
222+ [t|FromAttribute $(TH.conT name)|]
218− [funSimple 'fromAttribute [e|readContent|]]
223+ [funSimple 'fromAttribute [e|readContent|]]
224+ case genType of
225+ Generator -> do
226+ toXmlInst <- genToXmlInst
227+ toXmlAttributeInst <- genToXmlAttributeInst
219− return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
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,
220− fromDomInst, fromAttributeInst]
239+ fromDomInst, fromAttributeInst]
221−
240+
222−isoXmlGenerateDatatype :: PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ
241+isoXmlGenerateDatatype :: GenType -> PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ
223−isoXmlGenerateDatatype (PrefixName strName' strPrefix') descRecordParts = do
242+isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts = do
224 let
243 let
225 isNewtype = length descRecordParts == 1
244 isNewtype = length descRecordParts == 1
226 strName = "Xml" ++ strName'
245 strName = "Xml" ++ strName'
@@ -274,103 +293,117 @@ isoXmlGenerateDatatype (PrefixName strName' strPrefix') descRecordParts = do
274 (return [])
293 (return [])
275 [t|NFData $(TH.conT name)|]
294 [t|NFData $(TH.conT name)|]
276 [ ]
295 [ ]
277− fromDomInst <- do
278− let
279− exprHeader = [e|pure $(TH.conE name)|]
280− exprRecordParts = do
281− descRecordPart <- descRecordParts
282− return $ case descRecordPart of
283− IsoXmlDescRecordField descField ->
284− let
285− IsoXmlDescField fieldPlural rawName _ = descField
286− fieldStrName = xmlLocalName rawName
287− exprFieldStrName = TH.litE (TH.stringL fieldStrName)
288− fieldParse = case fieldPlural of
289− XmlFieldPluralMandatory -> [e|inElem|]
290− _ -> [e|inElemTrav|]
291− in
292− [e|$fieldParse $exprFieldStrName fromDom|]
293− IsoXmlDescRecordAttribute descAttribute ->
294− let
295− IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute
296− exprAttributeStrName = TH.litE (TH.stringL attributeStrName)
297− attributeParse = case attributePlural of
298− XmlAttributePluralMandatory -> [e|parseAttribute|]
299− XmlAttributePluralOptional -> [e|parseAttributeMaybe|]
300− in
301− [e|$attributeParse $exprAttributeStrName fromAttribute|]
302− IsoXmlDescRecordContent _ -> [e|parseContent fromAttribute|]
303− fromDomExpr = foldl (\e fe -> [e| $e <*> $fe |]) exprHeader exprRecordParts
304− TH.instanceD
305− (return [])
306− [t|FromDom $(TH.conT name)|]
307− [ funSimple 'fromDom fromDomExpr ]
308−
309− toXmlInst <- do
310− objName <- TH.newName strPrefix
311− let
312− exprFields = do
313− descRecordPart <- descRecordParts
314− case descRecordPart of
315− IsoXmlDescRecordField (IsoXmlDescField fieldPlural rawName _) -> do
316− let
317− fieldStrName = xmlLocalName rawName
318− fName = TH.mkName (fieldName fieldStrName)
319− exprFieldStrName = TH.litE (TH.stringL rawName)
320− exprForField = case fieldPlural of
321− XmlFieldPluralMandatory -> [e|id|]
322− _ -> [e|traverse|]
323− exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
324− exprFieldRender =
325− [e|(\a ->
326− XW.elementA $exprFieldStrName (toXmlParentAttributes a) a)|]
327− return [e|$exprForField $exprFieldRender $exprFieldValue|]
328− IsoXmlDescRecordContent (IsoXmlDescContent rawName _) -> do
329− let
330− fieldStrName = xmlLocalName rawName
331− fName = TH.mkName (fieldName fieldStrName)
332− exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
333− return [e|XW.content . toXmlAttribute $ $exprFieldValue|]
334− _ -> []
335− toXmlExpr
336− = TH.lamE [if null exprFields then TH.wildP else TH.varP objName]
337− $ foldr (\fe e -> [e|$fe *> $e|]) [e|return ()|] exprFields
338− TH.instanceD
339− (return [])
340− [t|XW.ToXML $(TH.conT name)|]
341− [funSimple 'XW.toXML toXmlExpr]
342
296
343− toXmlParentAttributesInst <- do
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
344− objName <- TH.newName strPrefix
331+ objName <- TH.newName strPrefix
345− let
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
346− exprAttributes = do
366+ exprAttributes = do
347− descRecordPart <- descRecordParts
367+ descRecordPart <- descRecordParts
348− IsoXmlDescAttribute attributePlural attributeStrName _ <-
368+ IsoXmlDescAttribute attributePlural attributeStrName _ <-
349− maybeToList $ case descRecordPart of
369+ maybeToList $ case descRecordPart of
350− IsoXmlDescRecordAttribute descAttribute -> Just descAttribute
370+ IsoXmlDescRecordAttribute descAttribute -> Just descAttribute
351− _ -> Nothing
371+ _ -> Nothing
352− let
372+ let
353− fName = TH.mkName (fieldName attributeStrName)
373+ fName = TH.mkName (fieldName attributeStrName)
354− exprAttrStrName = TH.litE (TH.stringL attributeStrName)
374+ exprAttrStrName = TH.litE (TH.stringL attributeStrName)
355− exprAttrValue = [e|$(TH.varE fName) $(TH.varE objName)|]
375+ exprAttrValue = [e|$(TH.varE fName) $(TH.varE objName)|]
356− exprAttrWrap = case attributePlural of
376+ exprAttrWrap = case attributePlural of
357− XmlAttributePluralMandatory -> [e|Just . toXmlAttribute|]
377+ XmlAttributePluralMandatory -> [e|Just . toXmlAttribute|]
358− XmlAttributePluralOptional -> [e|fmap toXmlAttribute|]
378+ XmlAttributePluralOptional -> [e|fmap toXmlAttribute|]
359− return [e|($exprAttrStrName, $exprAttrWrap $exprAttrValue)|]
379+ return [e|($exprAttrStrName, $exprAttrWrap $exprAttrValue)|]
360− toXmlParentAttributesExpr
380+ toXmlParentAttributesExpr
361− = TH.lamE [if null exprAttributes then TH.wildP else TH.varP objName]
381+ = TH.lamE [if null exprAttributes then TH.wildP else TH.varP objName]
362− $ [e|mapMaybe distribPair $(TH.listE exprAttributes)|]
382+ $ [e|mapMaybe distribPair $(TH.listE exprAttributes)|]
363#if __GLASGOW_HASKELL__ < 800
383#if __GLASGOW_HASKELL__ < 800
364− TH.instanceD
384+ TH.instanceD
365#else
385#else
366− TH.instanceWithOverlapD (Just TH.Overlapping)
386+ TH.instanceWithOverlapD (Just TH.Overlapping)
367#endif
387#endif
368− (return [])
388+ (return [])
369− [t|ToXmlParentAttributes $(TH.conT name)|]
389+ [t|ToXmlParentAttributes $(TH.conT name)|]
370− [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]
390+ [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]
371−
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
372− return $ [termDecl] ++ lensDecls ++
400+ return $ [termDecl] ++ lensDecls ++ [fromDomInst, nfDataInst]
401+ Both -> do
402+ toXmlInst <- genToXmlInst
403+ toXmlParentAttributesInst <- genToXmlParentAttributeInst
404+ fromDomInst <- genFromDomInst
405+ return $ [termDecl] ++ lensDecls ++
373− [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]
406+ [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]
374
407
375distribPair :: Functor f => (a, f b) -> f (a, b)
408distribPair :: Functor f => (a, f b) -> f (a, b)
376distribPair (a, fb) = (a,) <$> fb
409distribPair (a, fb) = (a,) <$> fb
test/TestDefs.hs+4−4
@@ -9,11 +9,11 @@ import Data.THGen.XML
9import Test.QuickCheck.Arbitrary.Generic
9import Test.QuickCheck.Arbitrary.Generic
10import Test.QuickCheck.Instances ()
10import Test.QuickCheck.Instances ()
11
11
12−"Bar" =:= enum
12+"Bar" =:= enum Both
13 & "baroque"
13 & "baroque"
14 & "bartender"
14 & "bartender"
15
15
16−"Quux" Exhaustive =:= enum
16+"Quux" Exhaustive =:= enum Both
17 & "ALL"
17 & "ALL"
18 & "YOUR"
18 & "YOUR"
19 & "BASE"
19 & "BASE"
@@ -22,14 +22,14 @@ import Test.QuickCheck.Instances ()
22 & "TO"
22 & "TO"
23 & "US"
23 & "US"
24
24
25−"Foo" =:= record
25+"Foo" =:= record Both
26 ^ "Shmuux" [t|XmlQuux|]
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 Both
33 ! "{http://example.com/ns/my-namespace}Foo"
33 ! "{http://example.com/ns/my-namespace}Foo"
34
34
35instance Arbitrary XmlRoot where
35instance Arbitrary XmlRoot where