@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE UndecidableInstances #-}
23{-# LANGUAGE FunctionalDependencies #-}
34
@@ -23,6 +24,8 @@ import Text.XML.ParentAttributes
2324import qualified Text.XML.Writer as XW
2425
2526
27+data GenType = Parser | Generator | Both
28+
2629data XmlFieldPlural
2730 = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
2831 | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)
@@ -52,7 +55,7 @@ data IsoXmlDescRecordPart
5255 | IsoXmlDescRecordAttribute IsoXmlDescAttribute
5356 | IsoXmlDescRecordContent IsoXmlDescContent
5457
55−newtype IsoXmlDescRecord = IsoXmlDescRecord [IsoXmlDescRecordPart]
58+data IsoXmlDescRecord = IsoXmlDescRecord GenType [IsoXmlDescRecordPart]
5659
5760makePrisms ''IsoXmlDescRecord
5861
@@ -64,7 +67,7 @@ newtype IsoXmlDescEnumCon
6467instance IsString IsoXmlDescEnumCon where
6568 fromString = IsoXmlDescEnumCon
6669
67−data IsoXmlDescEnum = IsoXmlDescEnum [IsoXmlDescEnumCon]
70+data IsoXmlDescEnum = IsoXmlDescEnum GenType [IsoXmlDescEnumCon]
6871
6972makePrisms ''IsoXmlDescEnum
7073
@@ -73,26 +76,26 @@ appendField
7376 -> IsoXmlDescRecord
7477 -> IsoXmlDescPreField
7578 -> IsoXmlDescRecord
76−appendField plural xrec (IsoXmlDescPreField name ty) =
79+appendField plural (IsoXmlDescRecord genType fields) (IsoXmlDescPreField name ty) =
7780 let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty
78− in over _IsoXmlDescRecord (xfield:) xrec
81+ in IsoXmlDescRecord genType (xfield:fields)
7982
8083appendAttribute
8184 :: XmlAttributePlural
8285 -> IsoXmlDescRecord
8386 -> IsoXmlDescPreAttribute
8487 -> IsoXmlDescRecord
85−appendAttribute plural xrec (IsoXmlDescPreAttribute name ty) =
88+appendAttribute plural (IsoXmlDescRecord genType fields) (IsoXmlDescPreAttribute name ty) =
8689 let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty
87− in over _IsoXmlDescRecord (xattribute:) xrec
90+ in IsoXmlDescRecord genType (xattribute:fields)
8891
8992appendContent
9093 :: IsoXmlDescRecord
9194 -> IsoXmlDescPreContent
9295 -> IsoXmlDescRecord
93−appendContent xrec (IsoXmlDescPreContent name ty) =
96+appendContent (IsoXmlDescRecord genType fields) (IsoXmlDescPreContent name ty) =
9497 let xcontent = IsoXmlDescRecordContent $ IsoXmlDescContent name ty
95− in over _IsoXmlDescRecord (xcontent:) xrec
98+ in IsoXmlDescRecord genType (xcontent:fields)
9699
97100(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
98101(!) = appendField XmlFieldPluralMandatory
@@ -116,8 +119,8 @@ infixl 2 ?%
116119infixl 2 ^
117120
118121appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
119−appendEnumCon xenum xenumcon =
120− over _IsoXmlDescEnum (xenumcon:) xenum
122+appendEnumCon (IsoXmlDescEnum genType enumCons) xenumcon =
123+ IsoXmlDescEnum genType (xenumcon:enumCons)
121124
122125(&) :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
123126(&) = appendEnumCon
@@ -130,20 +133,18 @@ class Description name desc | desc -> name where
130133infix 0 =:=
131134
132135instance Description PrefixName IsoXmlDescRecord where
133− prefixName =:= descRecord =
134− let descRecordParts = descRecord ^. _IsoXmlDescRecord
135− in isoXmlGenerateDatatype prefixName (reverse descRecordParts)
136+ prefixName =:= (IsoXmlDescRecord genType descRecordParts) =
137+ isoXmlGenerateDatatype genType prefixName (reverse descRecordParts)
136138
137−record :: IsoXmlDescRecord
138−record = IsoXmlDescRecord []
139+record :: GenType -> IsoXmlDescRecord
140+record gt = IsoXmlDescRecord gt []
139141
140−enum :: IsoXmlDescEnum
141−enum = IsoXmlDescEnum []
142+enum :: GenType -> IsoXmlDescEnum
143+enum gt = IsoXmlDescEnum gt []
142144
143145instance Description ExhaustivenessName IsoXmlDescEnum where
144− exhaustivenessName =:= descEnum =
145− let descEnumCons = descEnum ^. _IsoXmlDescEnum
146− in isoXmlGenerateEnum exhaustivenessName (reverse descEnumCons)
146+ exhaustivenessName =:= (IsoXmlDescEnum genType descEnumCons) =
147+ isoXmlGenerateEnum genType exhaustivenessName (reverse descEnumCons)
147148
148149instance IsString (TH.TypeQ -> IsoXmlDescPreField) where
149150 fromString = IsoXmlDescPreField
@@ -188,39 +189,57 @@ funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ
188189funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]
189190
190191isoXmlGenerateEnum
191− :: ExhaustivenessName -> [IsoXmlDescEnumCon] -> TH.DecsQ
192−isoXmlGenerateEnum (ExhaustivenessName strName' exh) enumCons = do
192+ :: GenType
193+ -> ExhaustivenessName
194+ -> [IsoXmlDescEnumCon]
195+ -> TH.DecsQ
196+isoXmlGenerateEnum genType (ExhaustivenessName strName' exh) enumCons = do
193197 let
194198 strName = "Xml" ++ strName'
195199 strVals = map unIsoXmlDescEnumCon enumCons
196200 enumDesc = EnumDesc exh strName strVals
197201 name = TH.mkName strName
198202 enumDecls <- enumGenerate enumDesc
199− toXmlInst <- do
200− TH.instanceD
201− (return [])
202− [t|XW.ToXML $(TH.conT name)|]
203− [funSimple 'XW.toXML [e|XW.toXML . T.pack . show|]]
204− toXmlAttributeInst <- do
205− TH.instanceD
206− (return [])
207− [t|ToXmlAttribute $(TH.conT name)|]
208− [funSimple 'toXmlAttribute [e|T.pack . show|]]
209− fromDomInst <- do
210− TH.instanceD
211− (return [])
212− [t|FromDom $(TH.conT name)|]
213− [funSimple 'fromDom [e|parseContent readContent|]]
214− fromAttributeInst <- do
215− TH.instanceD
216− (return [])
217− [t|FromAttribute $(TH.conT name)|]
218− [funSimple 'fromAttribute [e|readContent|]]
219− return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
220− fromDomInst, fromAttributeInst]
221−
222−isoXmlGenerateDatatype :: PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ
223−isoXmlGenerateDatatype (PrefixName strName' strPrefix') descRecordParts = do
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
224243 let
225244 isNewtype = length descRecordParts == 1
226245 strName = "Xml" ++ strName'
@@ -274,103 +293,117 @@ isoXmlGenerateDatatype (PrefixName strName' strPrefix') descRecordParts = do
274293 (return [])
275294 [t|NFData $(TH.conT name)|]
276295 [ ]
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]
342296
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)|]
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)|]
363383#if __GLASGOW_HASKELL__ < 800
364− TH.instanceD
384+ TH.instanceD
365385#else
366− TH.instanceWithOverlapD (Just TH.Overlapping)
386+ TH.instanceWithOverlapD (Just TH.Overlapping)
367387#endif
368− (return [])
369− [t|ToXmlParentAttributes $(TH.conT name)|]
370− [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]
371−
372− return $ [termDecl] ++ lensDecls ++
373− [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]
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]
374407
375408distribPair :: Functor f => (a, f b) -> f (a, b)
376409distribPair (a, fb) = (a,) <$> fb