@@ -23,6 +23,8 @@ import Text.XML.ParentAttributes
2323import qualified Text.XML.Writer as XW
2424
2525
26+data GenType = Parser | Generator | Both
27+
2628data XmlFieldPlural
2729 = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
2830 | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)
@@ -52,7 +54,7 @@ data IsoXmlDescRecordPart
5254 | IsoXmlDescRecordAttribute IsoXmlDescAttribute
5355 | IsoXmlDescRecordContent IsoXmlDescContent
5456
55−newtype IsoXmlDescRecord = IsoXmlDescRecord [IsoXmlDescRecordPart]
57+data IsoXmlDescRecord = IsoXmlDescRecord GenType [IsoXmlDescRecordPart]
5658
5759makePrisms ''IsoXmlDescRecord
5860
@@ -64,7 +66,7 @@ newtype IsoXmlDescEnumCon
6466instance IsString IsoXmlDescEnumCon where
6567 fromString = IsoXmlDescEnumCon
6668
67−data IsoXmlDescEnum = IsoXmlDescEnum [IsoXmlDescEnumCon]
69+data IsoXmlDescEnum = IsoXmlDescEnum GenType [IsoXmlDescEnumCon]
6870
6971makePrisms ''IsoXmlDescEnum
7072
@@ -73,26 +75,26 @@ appendField
7375 -> IsoXmlDescRecord
7476 -> IsoXmlDescPreField
7577 -> IsoXmlDescRecord
76−appendField plural xrec (IsoXmlDescPreField name ty) =
78+appendField plural (IsoXmlDescRecord genType fields) (IsoXmlDescPreField name ty) =
7779 let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty
78− in over _IsoXmlDescRecord (xfield:) xrec
80+ in IsoXmlDescRecord genType (xfield:fields)
7981
8082appendAttribute
8183 :: XmlAttributePlural
8284 -> IsoXmlDescRecord
8385 -> IsoXmlDescPreAttribute
8486 -> IsoXmlDescRecord
85−appendAttribute plural xrec (IsoXmlDescPreAttribute name ty) =
87+appendAttribute plural (IsoXmlDescRecord genType fields) (IsoXmlDescPreAttribute name ty) =
8688 let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty
87− in over _IsoXmlDescRecord (xattribute:) xrec
89+ in IsoXmlDescRecord genType (xattribute:fields)
8890
8991appendContent
9092 :: IsoXmlDescRecord
9193 -> IsoXmlDescPreContent
9294 -> IsoXmlDescRecord
93−appendContent xrec (IsoXmlDescPreContent name ty) =
95+appendContent (IsoXmlDescRecord genType fields) (IsoXmlDescPreContent name ty) =
9496 let xcontent = IsoXmlDescRecordContent $ IsoXmlDescContent name ty
95− in over _IsoXmlDescRecord (xcontent:) xrec
97+ in IsoXmlDescRecord genType (xcontent:fields)
9698
9799(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
98100(!) = appendField XmlFieldPluralMandatory
@@ -116,8 +118,8 @@ infixl 2 ?%
116118infixl 2 ^
117119
118120appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
119−appendEnumCon xenum xenumcon =
120− over _IsoXmlDescEnum (xenumcon:) xenum
121+appendEnumCon (IsoXmlDescEnum genType enumCons) xenumcon =
122+ IsoXmlDescEnum genType (xenumcon:enumCons)
121123
122124(&) :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
123125(&) = appendEnumCon
@@ -130,20 +132,18 @@ class Description name desc | desc -> name where
130132infix 0 =:=
131133
132134instance Description PrefixName IsoXmlDescRecord where
133− prefixName =:= descRecord =
134− let descRecordParts = descRecord ^. _IsoXmlDescRecord
135− in isoXmlGenerateDatatype prefixName (reverse descRecordParts)
135+ prefixName =:= (IsoXmlDescRecord genType descRecordParts) =
136+ isoXmlGenerateDatatype genType prefixName (reverse descRecordParts)
136137
137−record :: IsoXmlDescRecord
138−record = IsoXmlDescRecord []
138+record :: GenType -> IsoXmlDescRecord
139+record gt = IsoXmlDescRecord gt []
139140
140−enum :: IsoXmlDescEnum
141−enum = IsoXmlDescEnum []
141+enum :: GenType -> IsoXmlDescEnum
142+enum gt = IsoXmlDescEnum gt []
142143
143144instance Description ExhaustivenessName IsoXmlDescEnum where
144− exhaustivenessName =:= descEnum =
145− let descEnumCons = descEnum ^. _IsoXmlDescEnum
146− in isoXmlGenerateEnum exhaustivenessName (reverse descEnumCons)
145+ exhaustivenessName =:= (IsoXmlDescEnum genType descEnumCons) =
146+ isoXmlGenerateEnum genType exhaustivenessName (reverse descEnumCons)
147147
148148instance IsString (TH.TypeQ -> IsoXmlDescPreField) where
149149 fromString = IsoXmlDescPreField
@@ -188,39 +188,57 @@ funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ
188188funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]
189189
190190isoXmlGenerateEnum
191− :: ExhaustivenessName -> [IsoXmlDescEnumCon] -> TH.DecsQ
192−isoXmlGenerateEnum (ExhaustivenessName strName' exh) enumCons = do
191+ :: GenType
192+ -> ExhaustivenessName
193+ -> [IsoXmlDescEnumCon]
194+ -> TH.DecsQ
195+isoXmlGenerateEnum genType (ExhaustivenessName strName' exh) enumCons = do
193196 let
194197 strName = "Xml" ++ strName'
195198 strVals = map unIsoXmlDescEnumCon enumCons
196199 enumDesc = EnumDesc exh strName strVals
197200 name = TH.mkName strName
198201 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
202+ let
203+ genToXmlInst = do
204+ TH.instanceD
205+ (return [])
206+ [t|XW.ToXML $(TH.conT name)|]
207+ [funSimple 'XW.toXML [e|XW.toXML . T.pack . show|]]
208+ genToXmlAttributeInst = do
209+ TH.instanceD
210+ (return [])
211+ [t|ToXmlAttribute $(TH.conT name)|]
212+ [funSimple 'toXmlAttribute [e|T.pack . show|]]
213+ genFromDomInst = do
214+ TH.instanceD
215+ (return [])
216+ [t|FromDom $(TH.conT name)|]
217+ [funSimple 'fromDom [e|parseContent readContent|]]
218+ genFromAttributeInst = do
219+ TH.instanceD
220+ (return [])
221+ [t|FromAttribute $(TH.conT name)|]
222+ [funSimple 'fromAttribute [e|readContent|]]
223+ case genType of
224+ Generator -> do
225+ toXmlInst <- genToXmlInst
226+ toXmlAttributeInst <- genToXmlAttributeInst
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,
238+ fromDomInst, fromAttributeInst]
239+
240+isoXmlGenerateDatatype :: GenType -> PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ
241+isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts = do
224242 let
225243 isNewtype = length descRecordParts == 1
226244 strName = "Xml" ++ strName'
@@ -274,103 +292,117 @@ isoXmlGenerateDatatype (PrefixName strName' strPrefix') descRecordParts = do
274292 (return [])
275293 [t|NFData $(TH.conT name)|]
276294 [ ]
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]
371295
372− return $ [termDecl] ++ lensDecls ++
373− [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]
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
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 ++
405+ [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]
374406
375407distribPair :: Functor f => (a, f b) -> f (a, b)
376408distribPair (a, fb) = (a,) <$> fb