@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
21{-# LANGUAGE UndecidableInstances #-}
32{-# LANGUAGE FunctionalDependencies #-}
43
@@ -24,8 +23,6 @@ import Text.XML.ParentAttributes
2423import qualified Text.XML.Writer as XW
2524
2625
27−data GenType = Parser | Generator | Both
28−
2926data XmlFieldPlural
3027 = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
3128 | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)
@@ -55,7 +52,7 @@ data IsoXmlDescRecordPart
5552 | IsoXmlDescRecordAttribute IsoXmlDescAttribute
5653 | IsoXmlDescRecordContent IsoXmlDescContent
5754
58−data IsoXmlDescRecord = IsoXmlDescRecord GenType [IsoXmlDescRecordPart]
55+newtype IsoXmlDescRecord = IsoXmlDescRecord [IsoXmlDescRecordPart]
5956
6057makePrisms ''IsoXmlDescRecord
6158
@@ -67,7 +64,7 @@ newtype IsoXmlDescEnumCon
6764instance IsString IsoXmlDescEnumCon where
6865 fromString = IsoXmlDescEnumCon
6966
70−data IsoXmlDescEnum = IsoXmlDescEnum GenType [IsoXmlDescEnumCon]
67+data IsoXmlDescEnum = IsoXmlDescEnum [IsoXmlDescEnumCon]
7168
7269makePrisms ''IsoXmlDescEnum
7370
@@ -76,26 +73,26 @@ appendField
7673 -> IsoXmlDescRecord
7774 -> IsoXmlDescPreField
7875 -> IsoXmlDescRecord
79−appendField plural (IsoXmlDescRecord genType fields) (IsoXmlDescPreField name ty) =
76+appendField plural xrec (IsoXmlDescPreField name ty) =
8077 let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty
81− in IsoXmlDescRecord genType (xfield:fields)
78+ in over _IsoXmlDescRecord (xfield:) xrec
8279
8380appendAttribute
8481 :: XmlAttributePlural
8582 -> IsoXmlDescRecord
8683 -> IsoXmlDescPreAttribute
8784 -> IsoXmlDescRecord
88−appendAttribute plural (IsoXmlDescRecord genType fields) (IsoXmlDescPreAttribute name ty) =
85+appendAttribute plural xrec (IsoXmlDescPreAttribute name ty) =
8986 let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty
90− in IsoXmlDescRecord genType (xattribute:fields)
87+ in over _IsoXmlDescRecord (xattribute:) xrec
9188
9289appendContent
9390 :: IsoXmlDescRecord
9491 -> IsoXmlDescPreContent
9592 -> IsoXmlDescRecord
96−appendContent (IsoXmlDescRecord genType fields) (IsoXmlDescPreContent name ty) =
93+appendContent xrec (IsoXmlDescPreContent name ty) =
9794 let xcontent = IsoXmlDescRecordContent $ IsoXmlDescContent name ty
98− in IsoXmlDescRecord genType (xcontent:fields)
95+ in over _IsoXmlDescRecord (xcontent:) xrec
9996
10097(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
10198(!) = appendField XmlFieldPluralMandatory
@@ -119,8 +116,8 @@ infixl 2 ?%
119116infixl 2 ^
120117
121118appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
122−appendEnumCon (IsoXmlDescEnum genType enumCons) xenumcon =
123− IsoXmlDescEnum genType (xenumcon:enumCons)
119+appendEnumCon xenum xenumcon =
120+ over _IsoXmlDescEnum (xenumcon:) xenum
124121
125122(&) :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
126123(&) = appendEnumCon
@@ -133,18 +130,20 @@ class Description name desc | desc -> name where
133130infix 0 =:=
134131
135132instance Description PrefixName IsoXmlDescRecord where
136− prefixName =:= (IsoXmlDescRecord genType descRecordParts) =
137− isoXmlGenerateDatatype genType prefixName (reverse descRecordParts)
133+ prefixName =:= descRecord =
134+ let descRecordParts = descRecord ^. _IsoXmlDescRecord
135+ in isoXmlGenerateDatatype prefixName (reverse descRecordParts)
138136
139−record :: GenType -> IsoXmlDescRecord
140−record gt = IsoXmlDescRecord gt []
137+record :: IsoXmlDescRecord
138+record = IsoXmlDescRecord []
141139
142−enum :: GenType -> IsoXmlDescEnum
143−enum gt = IsoXmlDescEnum gt []
140+enum :: IsoXmlDescEnum
141+enum = IsoXmlDescEnum []
144142
145143instance Description ExhaustivenessName IsoXmlDescEnum where
146− exhaustivenessName =:= (IsoXmlDescEnum genType descEnumCons) =
147− isoXmlGenerateEnum genType exhaustivenessName (reverse descEnumCons)
144+ exhaustivenessName =:= descEnum =
145+ let descEnumCons = descEnum ^. _IsoXmlDescEnum
146+ in isoXmlGenerateEnum exhaustivenessName (reverse descEnumCons)
148147
149148instance IsString (TH.TypeQ -> IsoXmlDescPreField) where
150149 fromString = IsoXmlDescPreField
@@ -189,57 +188,39 @@ funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ
189188funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]
190189
191190isoXmlGenerateEnum
192− :: GenType
193− -> ExhaustivenessName
194− -> [IsoXmlDescEnumCon]
195− -> TH.DecsQ
196−isoXmlGenerateEnum genType (ExhaustivenessName strName' exh) enumCons = do
191+ :: ExhaustivenessName -> [IsoXmlDescEnumCon] -> TH.DecsQ
192+isoXmlGenerateEnum (ExhaustivenessName strName' exh) enumCons = do
197193 let
198194 strName = "Xml" ++ strName'
199195 strVals = map unIsoXmlDescEnumCon enumCons
200196 enumDesc = EnumDesc exh strName strVals
201197 name = TH.mkName strName
202198 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
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
243224 let
244225 isNewtype = length descRecordParts == 1
245226 strName = "Xml" ++ strName'
@@ -293,117 +274,103 @@ isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts
293274 (return [])
294275 [t|NFData $(TH.conT name)|]
295276 [ ]
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 ]
296308
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)|]
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)|]
383363#if __GLASGOW_HASKELL__ < 800
384− TH.instanceD
364+ TH.instanceD
385365#else
386− TH.instanceWithOverlapD (Just TH.Overlapping)
366+ TH.instanceWithOverlapD (Just TH.Overlapping)
387367#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]
368+ (return [])
369+ [t|ToXmlParentAttributes $(TH.conT name)|]
370+ [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]
371+
372+ return $ [termDecl] ++ lensDecls ++
373+ [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]
407374
408375distribPair :: Functor f => (a, f b) -> f (a, b)
409376distribPair (a, fb) = (a,) <$> fb