git.iko.soy/typeable/xml-isogen
on master help sign in
Do not generate useless code
5ee3f5cDenis Redozubov
src/Data/THGen/XML/Internal.hs+175−143
compare with master
unifiedsplit
@@ -23,6 +23,8 @@ import Text.XML.ParentAttributes
23import qualified Text.XML.Writer as XW
23import qualified Text.XML.Writer as XW
24
24
25
25
26+data GenType = Parser | Generator | Both
27+
26data XmlFieldPlural
28data XmlFieldPlural
27 = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
29 = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
28 | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)
30 | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)
@@ -52,7 +54,7 @@ data IsoXmlDescRecordPart
52 | IsoXmlDescRecordAttribute IsoXmlDescAttribute
54 | IsoXmlDescRecordAttribute IsoXmlDescAttribute
53 | IsoXmlDescRecordContent IsoXmlDescContent
55 | IsoXmlDescRecordContent IsoXmlDescContent
54
56
55−newtype IsoXmlDescRecord = IsoXmlDescRecord [IsoXmlDescRecordPart]
57+data IsoXmlDescRecord = IsoXmlDescRecord GenType [IsoXmlDescRecordPart]
56
58
57makePrisms ''IsoXmlDescRecord
59makePrisms ''IsoXmlDescRecord
58
60
@@ -64,7 +66,7 @@ newtype IsoXmlDescEnumCon
64instance IsString IsoXmlDescEnumCon where
66instance IsString IsoXmlDescEnumCon where
65 fromString = IsoXmlDescEnumCon
67 fromString = IsoXmlDescEnumCon
66
68
67−data IsoXmlDescEnum = IsoXmlDescEnum [IsoXmlDescEnumCon]
69+data IsoXmlDescEnum = IsoXmlDescEnum GenType [IsoXmlDescEnumCon]
68
70
69makePrisms ''IsoXmlDescEnum
71makePrisms ''IsoXmlDescEnum
70
72
@@ -73,26 +75,26 @@ appendField
73 -> IsoXmlDescRecord
75 -> IsoXmlDescRecord
74 -> IsoXmlDescPreField
76 -> IsoXmlDescPreField
75 -> IsoXmlDescRecord
77 -> IsoXmlDescRecord
76−appendField plural xrec (IsoXmlDescPreField name ty) =
78+appendField plural (IsoXmlDescRecord genType fields) (IsoXmlDescPreField name ty) =
77 let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty
79 let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty
78− in over _IsoXmlDescRecord (xfield:) xrec
80+ in IsoXmlDescRecord genType (xfield:fields)
79
81
80appendAttribute
82appendAttribute
81 :: XmlAttributePlural
83 :: XmlAttributePlural
82 -> IsoXmlDescRecord
84 -> IsoXmlDescRecord
83 -> IsoXmlDescPreAttribute
85 -> IsoXmlDescPreAttribute
84 -> IsoXmlDescRecord
86 -> IsoXmlDescRecord
85−appendAttribute plural xrec (IsoXmlDescPreAttribute name ty) =
87+appendAttribute plural (IsoXmlDescRecord genType fields) (IsoXmlDescPreAttribute name ty) =
86 let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty
88 let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty
87− in over _IsoXmlDescRecord (xattribute:) xrec
89+ in IsoXmlDescRecord genType (xattribute:fields)
88
90
89appendContent
91appendContent
90 :: IsoXmlDescRecord
92 :: IsoXmlDescRecord
91 -> IsoXmlDescPreContent
93 -> IsoXmlDescPreContent
92 -> IsoXmlDescRecord
94 -> IsoXmlDescRecord
93−appendContent xrec (IsoXmlDescPreContent name ty) =
95+appendContent (IsoXmlDescRecord genType fields) (IsoXmlDescPreContent name ty) =
94 let xcontent = IsoXmlDescRecordContent $ IsoXmlDescContent name ty
96 let xcontent = IsoXmlDescRecordContent $ IsoXmlDescContent name ty
95− in over _IsoXmlDescRecord (xcontent:) xrec
97+ in IsoXmlDescRecord genType (xcontent:fields)
96
98
97(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
99(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
98(!) = appendField XmlFieldPluralMandatory
100(!) = appendField XmlFieldPluralMandatory
@@ -116,8 +118,8 @@ infixl 2 ?%
116infixl 2 ^
118infixl 2 ^
117
119
118appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
120appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
119−appendEnumCon xenum xenumcon =
121+appendEnumCon (IsoXmlDescEnum genType enumCons) xenumcon =
120− over _IsoXmlDescEnum (xenumcon:) xenum
122+ IsoXmlDescEnum genType (xenumcon:enumCons)
121
123
122(&) :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
124(&) :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
123(&) = appendEnumCon
125(&) = appendEnumCon
@@ -130,20 +132,18 @@ class Description name desc | desc -> name where
130infix 0 =:=
132infix 0 =:=
131
133
132instance Description PrefixName IsoXmlDescRecord where
134instance Description PrefixName IsoXmlDescRecord where
133− prefixName =:= descRecord =
135+ prefixName =:= (IsoXmlDescRecord genType descRecordParts) =
134− let descRecordParts = descRecord ^. _IsoXmlDescRecord
135− in isoXmlGenerateDatatype prefixName (reverse descRecordParts)
136+ isoXmlGenerateDatatype genType prefixName (reverse descRecordParts)
136
137
137−record :: IsoXmlDescRecord
138+record :: GenType -> IsoXmlDescRecord
138−record = IsoXmlDescRecord []
139+record gt = IsoXmlDescRecord gt []
139
140
140−enum :: IsoXmlDescEnum
141+enum :: GenType -> IsoXmlDescEnum
141−enum = IsoXmlDescEnum []
142+enum gt = IsoXmlDescEnum gt []
142
143
143instance Description ExhaustivenessName IsoXmlDescEnum where
144instance Description ExhaustivenessName IsoXmlDescEnum where
144− exhaustivenessName =:= descEnum =
145+ exhaustivenessName =:= (IsoXmlDescEnum genType descEnumCons) =
145− let descEnumCons = descEnum ^. _IsoXmlDescEnum
146− in isoXmlGenerateEnum exhaustivenessName (reverse descEnumCons)
146+ isoXmlGenerateEnum genType exhaustivenessName (reverse descEnumCons)
147
147
148instance IsString (TH.TypeQ -> IsoXmlDescPreField) where
148instance IsString (TH.TypeQ -> IsoXmlDescPreField) where
149 fromString = IsoXmlDescPreField
149 fromString = IsoXmlDescPreField
@@ -188,39 +188,57 @@ funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ
188funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]
188funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]
189
189
190isoXmlGenerateEnum
190isoXmlGenerateEnum
191+ :: GenType
191− :: ExhaustivenessName -> [IsoXmlDescEnumCon] -> TH.DecsQ
192+ -> ExhaustivenessName
193+ -> [IsoXmlDescEnumCon]
194+ -> TH.DecsQ
192−isoXmlGenerateEnum (ExhaustivenessName strName' exh) enumCons = do
195+isoXmlGenerateEnum genType (ExhaustivenessName strName' exh) enumCons = do
193 let
196 let
194 strName = "Xml" ++ strName'
197 strName = "Xml" ++ strName'
195 strVals = map unIsoXmlDescEnumCon enumCons
198 strVals = map unIsoXmlDescEnumCon enumCons
196 enumDesc = EnumDesc exh strName strVals
199 enumDesc = EnumDesc exh strName strVals
197 name = TH.mkName strName
200 name = TH.mkName strName
198 enumDecls <- enumGenerate enumDesc
201 enumDecls <- enumGenerate enumDesc
199− toXmlInst <- do
202+ let
203+ genToXmlInst = do
200− TH.instanceD
204+ TH.instanceD
201− (return [])
205+ (return [])
202− [t|XW.ToXML $(TH.conT name)|]
206+ [t|XW.ToXML $(TH.conT name)|]
203− [funSimple 'XW.toXML [e|XW.toXML . T.pack . show|]]
207+ [funSimple 'XW.toXML [e|XW.toXML . T.pack . show|]]
204− toXmlAttributeInst <- do
208+ genToXmlAttributeInst = do
205− TH.instanceD
209+ TH.instanceD
206− (return [])
210+ (return [])
207− [t|ToXmlAttribute $(TH.conT name)|]
211+ [t|ToXmlAttribute $(TH.conT name)|]
208− [funSimple 'toXmlAttribute [e|T.pack . show|]]
212+ [funSimple 'toXmlAttribute [e|T.pack . show|]]
209− fromDomInst <- do
213+ genFromDomInst = do
210− TH.instanceD
214+ TH.instanceD
211− (return [])
215+ (return [])
212− [t|FromDom $(TH.conT name)|]
216+ [t|FromDom $(TH.conT name)|]
213− [funSimple 'fromDom [e|parseContent readContent|]]
217+ [funSimple 'fromDom [e|parseContent readContent|]]
214− fromAttributeInst <- do
218+ genFromAttributeInst = do
215− TH.instanceD
219+ TH.instanceD
216− (return [])
220+ (return [])
217− [t|FromAttribute $(TH.conT name)|]
221+ [t|FromAttribute $(TH.conT name)|]
218− [funSimple 'fromAttribute [e|readContent|]]
222+ [funSimple 'fromAttribute [e|readContent|]]
223+ case genType of
224+ Generator -> do
225+ toXmlInst <- genToXmlInst
226+ toXmlAttributeInst <- genToXmlAttributeInst
219− return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
227+ return $ enumDecls ++ [toXmlInst, toXmlAttributeInst]
228+ Parser -> do
229+ fromDomInst <- genFromDomInst
230+ fromAttributeInst <- genFromAttributeInst
231+ return $ enumDecls ++ [fromDomInst, fromAttributeInst]
232+ Both -> do
233+ toXmlInst <- genToXmlInst
234+ toXmlAttributeInst <- genToXmlAttributeInst
235+ fromDomInst <- genFromDomInst
236+ fromAttributeInst <- genFromAttributeInst
237+ return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
220− fromDomInst, fromAttributeInst]
238+ fromDomInst, fromAttributeInst]
221−
239+
222−isoXmlGenerateDatatype :: PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ
240+isoXmlGenerateDatatype :: GenType -> PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ
223−isoXmlGenerateDatatype (PrefixName strName' strPrefix') descRecordParts = do
241+isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts = do
224 let
242 let
225 isNewtype = length descRecordParts == 1
243 isNewtype = length descRecordParts == 1
226 strName = "Xml" ++ strName'
244 strName = "Xml" ++ strName'
@@ -274,103 +292,117 @@ isoXmlGenerateDatatype (PrefixName strName' strPrefix') descRecordParts = do
274 (return [])
292 (return [])
275 [t|NFData $(TH.conT name)|]
293 [t|NFData $(TH.conT name)|]
276 [ ]
294 [ ]
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−
343− toXmlParentAttributesInst <- do
344− objName <- TH.newName strPrefix
345− let
346− exprAttributes = do
347− descRecordPart <- descRecordParts
348− IsoXmlDescAttribute attributePlural attributeStrName _ <-
349− maybeToList $ case descRecordPart of
350− IsoXmlDescRecordAttribute descAttribute -> Just descAttribute
351− _ -> Nothing
352− let
353− fName = TH.mkName (fieldName attributeStrName)
354− exprAttrStrName = TH.litE (TH.stringL attributeStrName)
355− exprAttrValue = [e|$(TH.varE fName) $(TH.varE objName)|]
356− exprAttrWrap = case attributePlural of
357− XmlAttributePluralMandatory -> [e|Just . toXmlAttribute|]
358− XmlAttributePluralOptional -> [e|fmap toXmlAttribute|]
359− return [e|($exprAttrStrName, $exprAttrWrap $exprAttrValue)|]
360− toXmlParentAttributesExpr
361− = TH.lamE [if null exprAttributes then TH.wildP else TH.varP objName]
362− $ [e|mapMaybe distribPair $(TH.listE exprAttributes)|]
363−#if __GLASGOW_HASKELL__ < 800
364− TH.instanceD
365−#else
366− TH.instanceWithOverlapD (Just TH.Overlapping)
367−#endif
368− (return [])
369− [t|ToXmlParentAttributes $(TH.conT name)|]
370− [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]
371
295
296+ let
297+ genFromDomInst = do
298+ let
299+ exprHeader = [e|pure $(TH.conE name)|]
300+ exprRecordParts = do
301+ descRecordPart <- descRecordParts
302+ return $ case descRecordPart of
303+ IsoXmlDescRecordField descField ->
304+ let
305+ IsoXmlDescField fieldPlural rawName _ = descField
306+ fieldStrName = xmlLocalName rawName
307+ exprFieldStrName = TH.litE (TH.stringL fieldStrName)
308+ fieldParse = case fieldPlural of
309+ XmlFieldPluralMandatory -> [e|inElem|]
310+ _ -> [e|inElemTrav|]
311+ in
312+ [e|$fieldParse $exprFieldStrName fromDom|]
313+ IsoXmlDescRecordAttribute descAttribute ->
314+ let
315+ IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute
316+ exprAttributeStrName = TH.litE (TH.stringL attributeStrName)
317+ attributeParse = case attributePlural of
318+ XmlAttributePluralMandatory -> [e|parseAttribute|]
319+ XmlAttributePluralOptional -> [e|parseAttributeMaybe|]
320+ in
321+ [e|$attributeParse $exprAttributeStrName fromAttribute|]
322+ IsoXmlDescRecordContent _ -> [e|parseContent fromAttribute|]
323+ fromDomExpr = foldl (\e fe -> [e| $e <*> $fe |]) exprHeader exprRecordParts
324+ TH.instanceD
325+ (return [])
326+ [t|FromDom $(TH.conT name)|]
327+ [ funSimple 'fromDom fromDomExpr ]
328+
329+ genToXmlInst = do
330+ objName <- TH.newName strPrefix
331+ let
332+ exprFields = do
333+ descRecordPart <- descRecordParts
334+ case descRecordPart of
335+ IsoXmlDescRecordField (IsoXmlDescField fieldPlural rawName _) -> do
336+ let
337+ fieldStrName = xmlLocalName rawName
338+ fName = TH.mkName (fieldName fieldStrName)
339+ exprFieldStrName = TH.litE (TH.stringL rawName)
340+ exprForField = case fieldPlural of
341+ XmlFieldPluralMandatory -> [e|id|]
342+ _ -> [e|traverse|]
343+ exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
344+ exprFieldRender =
345+ [e|(\a ->
346+ XW.elementA $exprFieldStrName (toXmlParentAttributes a) a)|]
347+ return [e|$exprForField $exprFieldRender $exprFieldValue|]
348+ IsoXmlDescRecordContent (IsoXmlDescContent rawName _) -> do
349+ let
350+ fieldStrName = xmlLocalName rawName
351+ fName = TH.mkName (fieldName fieldStrName)
352+ exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
353+ return [e|XW.content . toXmlAttribute $ $exprFieldValue|]
354+ _ -> []
355+ toXmlExpr
356+ = TH.lamE [if null exprFields then TH.wildP else TH.varP objName]
357+ $ foldr (\fe e -> [e|$fe *> $e|]) [e|return ()|] exprFields
358+ TH.instanceD
359+ (return [])
360+ [t|XW.ToXML $(TH.conT name)|]
361+ [funSimple 'XW.toXML toXmlExpr]
362+ genToXmlParentAttributeInst = do
363+ objName <- TH.newName strPrefix
364+ let
365+ exprAttributes = do
366+ descRecordPart <- descRecordParts
367+ IsoXmlDescAttribute attributePlural attributeStrName _ <-
368+ maybeToList $ case descRecordPart of
369+ IsoXmlDescRecordAttribute descAttribute -> Just descAttribute
370+ _ -> Nothing
371+ let
372+ fName = TH.mkName (fieldName attributeStrName)
373+ exprAttrStrName = TH.litE (TH.stringL attributeStrName)
374+ exprAttrValue = [e|$(TH.varE fName) $(TH.varE objName)|]
375+ exprAttrWrap = case attributePlural of
376+ XmlAttributePluralMandatory -> [e|Just . toXmlAttribute|]
377+ XmlAttributePluralOptional -> [e|fmap toXmlAttribute|]
378+ return [e|($exprAttrStrName, $exprAttrWrap $exprAttrValue)|]
379+ toXmlParentAttributesExpr
380+ = TH.lamE [if null exprAttributes then TH.wildP else TH.varP objName]
381+ $ [e|mapMaybe distribPair $(TH.listE exprAttributes)|]
382+ #if __GLASGOW_HASKELL__ < 800
383+ TH.instanceD
384+ #else
385+ TH.instanceWithOverlapD (Just TH.Overlapping)
386+ #endif
387+ (return [])
388+ [t|ToXmlParentAttributes $(TH.conT name)|]
389+ [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]
390+
391+ case genType of
392+ Generator -> do
393+ toXmlInst <- genToXmlInst
394+ toXmlParentAttributesInst <- genToXmlParentAttributeInst
372− return $ [termDecl] ++ lensDecls ++
395+ return $ [termDecl] ++ lensDecls ++
396+ [toXmlInst, toXmlParentAttributesInst, nfDataInst]
397+ Parser -> do
398+ fromDomInst <- genFromDomInst
399+ return $ [termDecl] ++ lensDecls ++ [fromDomInst, nfDataInst]
400+ Both -> do
401+ toXmlInst <- genToXmlInst
402+ toXmlParentAttributesInst <- genToXmlParentAttributeInst
403+ fromDomInst <- genFromDomInst
404+ return $ [termDecl] ++ lensDecls ++
373− [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]
405+ [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]
374
406
375distribPair :: Functor f => (a, f b) -> f (a, b)
407distribPair :: Functor f => (a, f b) -> f (a, b)
376distribPair (a, fb) = (a,) <$> fb
408distribPair (a, fb) = (a,) <$> fb