@@ -1,4 +1,5 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
1+{-# LANGUAGE UndecidableInstances #-}
2+{-# LANGUAGE FunctionalDependencies #-}
@@ -22,7 +23,7 @@ wrapper around the field type:
25−> "Color" =:= enum Both
26+> "Color" =:= enum
@@ -40,7 +41,7 @@ to be either @R@, @G@ or @B@.
43−> "Message" =:= record Both
44+> "Message" =:= record
44> ! "author"
45> ! "author"
45> + "recipient"
46> + "recipient"
46> ? "message" [t|Text|]
47> ? "message" [t|Text|]
@@ -67,10 +68,10 @@ enumeration is exhaustive (contains only the listed constructors) or
67non-exhaustive (also contains a constructor for unknown values; this
68non-exhaustive (also contains a constructor for unknown values; this
68is the default):
69is the default):
70−> "Enum1" Exhaustive =:= enum Generator
71+> "Enum1" Exhaustive =:= enum
73−> "Enum2" NonExhaustive =:= enum Generator
74+> "Enum2" NonExhaustive =:= enum
76To define a record, use the `record` function followed by the name of
77To define a record, use the `record` function followed by the name of
@@ -78,7 +79,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
79inferred automatically by taking all of the uppercase letters in the
79name. You can override it manually like so:
80name. You can override it manually like so:
81−> "Reference" "ref" =:= record Parser
82+> "Reference" "ref" =:= record
84To describe a record field you must supply its name as it appears
85To describe a record field you must supply its name as it appears
@@ -93,14 +94,10 @@ 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
94if the field is called @"author"@ its type will be @Author@. You can
94override the type by specifying it in quasiquotes like so:
95override the type by specifying it in quasiquotes like so:
96−> "Message" =:= record Both
97+> "Message" =:= record
97−> ! "author" [t|Person|].
98+> ! "author" [t|Person|]
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.
@@ -108,7 +105,6 @@ module Data.THGen.XML
108 ( Exhaustiveness(..)
105 ( Exhaustiveness(..)
109 , PrefixName(..)
106 , PrefixName(..)
110 , ExhaustivenessName(..)
107 , ExhaustivenessName(..)
@@ -118,15 +114,326 @@ module Data.THGen.XML
123 -- Re-exports
118 -- Re-exports
126− , P.Integer
121+ , Integer
124+import Control.Lens hiding (repeated, enum, (&))
125+import Control.Lens.Internal.FieldTH (makeFieldOpticsForDec)
126+import qualified Data.Char as C
127+import Data.List.NonEmpty (NonEmpty)
128+import Data.Maybe (maybeToList, mapMaybe)
130+import Data.THGen.Compat
129import Data.THGen.Enum
131import Data.THGen.Enum
130−import Data.THGen.XML.Internal
131−import Data.Text
132+import qualified Data.Text as T
132−import qualified Prelude as P
133+import qualified Language.Haskell.TH as TH
134+import Prelude hiding ((+), (*))
135+import Text.XML.DOM.Parser
136+import Text.XML.ParentAttributes
137+import qualified Text.XML.Writer as XW
138+import qualified Text.XML as X
141+ = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
142+ | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)
143+ | XmlFieldPluralRepeated -- Occurs 0 or more times (List)
144+ | XmlFieldPluralMultiplied -- Occurs 1 or more times (NonEmpty)
146+data XmlAttributePlural
147+ = XmlAttributePluralMandatory -- Occurs exactly 1 time (Identity)
148+ | XmlAttributePluralOptional -- Occurs 0 or 1 times (Maybe)
150+data PrefixName = PrefixName String String
152+data IsoXmlDescPreField = IsoXmlDescPreField String TH.TypeQ
154+data IsoXmlDescPreAttribute = IsoXmlDescPreAttribute String TH.TypeQ
156+data IsoXmlDescField = IsoXmlDescField XmlFieldPlural String TH.TypeQ
158+data IsoXmlDescAttribute = IsoXmlDescAttribute XmlAttributePlural String TH.TypeQ
160+data IsoXmlDescRecordPart
161+ = IsoXmlDescRecordField IsoXmlDescField
162+ | IsoXmlDescRecordAttribute IsoXmlDescAttribute
164+newtype IsoXmlDescRecord = IsoXmlDescRecord [IsoXmlDescRecordPart]
166+makePrisms ''IsoXmlDescRecord
168+data ExhaustivenessName = ExhaustivenessName String Exhaustiveness
170+newtype IsoXmlDescEnumCon
171+ = IsoXmlDescEnumCon { unIsoXmlDescEnumCon :: String }
173+instance IsString IsoXmlDescEnumCon where
174+ fromString = IsoXmlDescEnumCon
176+data IsoXmlDescEnum = IsoXmlDescEnum [IsoXmlDescEnumCon]
178+makePrisms ''IsoXmlDescEnum
183+ -> IsoXmlDescPreField
185+appendField plural xrec (IsoXmlDescPreField name ty) =
186+ let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty
187+ in over _IsoXmlDescRecord (xfield:) xrec
190+ :: XmlAttributePlural
192+ -> IsoXmlDescPreAttribute
194+appendAttribute plural xrec (IsoXmlDescPreAttribute name ty) =
195+ let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty
196+ in over _IsoXmlDescRecord (xattribute:) xrec
198+(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
199+(!) = appendField XmlFieldPluralMandatory
200+(?) = appendField XmlFieldPluralOptional
201+(*) = appendField XmlFieldPluralRepeated
202+(+) = appendField XmlFieldPluralMultiplied
204+(!%), (?%) :: IsoXmlDescRecord -> IsoXmlDescPreAttribute -> IsoXmlDescRecord
205+(!%) = appendAttribute XmlAttributePluralMandatory
206+(?%) = appendAttribute XmlAttributePluralOptional
215+appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
216+appendEnumCon xenum xenumcon =
217+ over _IsoXmlDescEnum (xenumcon:) xenum
219+(&) :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
224+class Description name desc | desc -> name where
225+ (=:=) :: name -> desc -> TH.DecsQ
229+instance Description PrefixName IsoXmlDescRecord where
230+ prefixName =:= descRecord =
231+ let descRecordParts = descRecord ^. _IsoXmlDescRecord
232+ in isoXmlGenerateRecord prefixName (reverse descRecordParts)
234+record :: IsoXmlDescRecord
235+record = IsoXmlDescRecord []
237+enum :: IsoXmlDescEnum
238+enum = IsoXmlDescEnum []
240+instance Description ExhaustivenessName IsoXmlDescEnum where
241+ exhaustivenessName =:= descEnum =
242+ let descEnumCons = descEnum ^. _IsoXmlDescEnum
243+ in isoXmlGenerateEnum exhaustivenessName (reverse descEnumCons)
245+instance IsString (TH.TypeQ -> IsoXmlDescPreField) where
246+ fromString = IsoXmlDescPreField
248+instance IsString IsoXmlDescPreField where
249+ fromString name = IsoXmlDescPreField name ty
251+ ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)
253+instance IsString (TH.TypeQ -> IsoXmlDescPreAttribute) where
254+ fromString = IsoXmlDescPreAttribute
256+instance IsString IsoXmlDescPreAttribute where
257+ fromString name = IsoXmlDescPreAttribute name ty
259+ ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)
261+instance s ~ String => IsString (s -> PrefixName) where
262+ fromString = PrefixName
264+instance IsString PrefixName where
265+ fromString strName = PrefixName strName (makeNamePrefix strName)
267+instance e ~ Exhaustiveness => IsString (e -> ExhaustivenessName) where
268+ fromString = ExhaustivenessName
270+instance IsString ExhaustivenessName where
271+ fromString strName = ExhaustivenessName strName NonExhaustive
273+makeNamePrefix :: String -> String
274+makeNamePrefix = map C.toLower . filter C.isUpper
276+funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ
277+funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]
280+ :: ExhaustivenessName -> [IsoXmlDescEnumCon] -> TH.DecsQ
281+isoXmlGenerateEnum (ExhaustivenessName strName' exh) enumCons = do
283+ strName = "Xml" ++ strName'
284+ strVals = map unIsoXmlDescEnumCon enumCons
285+ enumDesc = EnumDesc exh strName strVals
286+ name = TH.mkName strName
287+ enumDecls <- enumGenerate enumDesc
291+ [t|XW.ToXML $(TH.conT name)|]
292+ [funSimple 'XW.toXML [e|XW.toXML . T.pack . show|]]
293+ toXmlAttributeInst <- do
296+ [t|ToXmlAttribute $(TH.conT name)|]
297+ [funSimple 'toXmlAttribute [e|T.pack . show|]]
301+ [t|FromDom $(TH.conT name)|]
302+ [funSimple 'fromDom [e|parseContent readContent|]]
303+ fromAttributeInst <- do
306+ [t|FromAttribute $(TH.conT name)|]
307+ [funSimple 'fromAttribute [e|readContent|]]
308+ return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
309+ fromDomInst, fromAttributeInst]
311+isoXmlGenerateRecord :: PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ
312+isoXmlGenerateRecord (PrefixName strName' strPrefix') descRecordParts = do
314+ strName = "Xml" ++ strName'
315+ strPrefix = "x" ++ strPrefix'
316+ name = TH.mkName strName
317+ fieldName str = "_" ++ strPrefix ++ over _head C.toUpper str
321+ descRecordPart <- descRecordParts
322+ return $ case descRecordPart of
323+ IsoXmlDescRecordField descField ->
325+ IsoXmlDescField fieldPlural fieldStrName fieldType = descField
326+ fName = TH.mkName (fieldName fieldStrName)
327+ fType = case fieldPlural of
328+ XmlFieldPluralMandatory -> fieldType
329+ XmlFieldPluralOptional -> [t| Maybe $fieldType |]
330+ XmlFieldPluralRepeated -> [t| [$fieldType] |]
331+ XmlFieldPluralMultiplied -> [t| NonEmpty $fieldType |]
333+ varStrictType fName (strictType fType)
334+ IsoXmlDescRecordAttribute descAttribute ->
337+ attributePlural attributeStrName attributeType = descAttribute
338+ fName = TH.mkName (fieldName attributeStrName)
339+ fType = case attributePlural of
340+ XmlAttributePluralMandatory -> attributeType
341+ XmlAttributePluralOptional -> [t| Maybe $attributeType |]
343+ varStrictType fName (strictType fType)
346+ [TH.recC name fields]
348+ lensDecls <- makeFieldOpticsForDec lensRules dataDecl
351+ exprHeader = [e|pure $(TH.conE name)|]
352+ exprRecordParts = do
353+ descRecordPart <- descRecordParts
354+ return $ case descRecordPart of
355+ IsoXmlDescRecordField descField ->
357+ IsoXmlDescField fieldPlural fieldStrName _ = descField
358+ exprFieldStrName = TH.litE (TH.stringL fieldStrName)
359+ fieldParse = case fieldPlural of
360+ XmlFieldPluralMandatory -> [e|inElem|]
361+ _ -> [e|inElemTrav|]
363+ [e|$fieldParse $exprFieldStrName fromDom|]
364+ IsoXmlDescRecordAttribute descAttribute ->
366+ IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute
367+ exprAttributeStrName = TH.litE (TH.stringL attributeStrName)
368+ attributeParse = case attributePlural of
369+ XmlAttributePluralMandatory -> [e|parseAttribute|]
370+ XmlAttributePluralOptional -> [e|parseAttributeMaybe|]
372+ [e|$attributeParse $exprAttributeStrName fromAttribute|]
373+ fromDomExpr = foldl (\e fe -> [e| $e <*> $fe |]) exprHeader exprRecordParts
376+ [t|FromDom $(TH.conT name)|]
377+ [ funSimple 'fromDom fromDomExpr ]
380+ objName <- TH.newName strPrefix
383+ descRecordPart <- descRecordParts
384+ IsoXmlDescField fieldPlural fieldStrName _ <-
385+ maybeToList $ case descRecordPart of
386+ IsoXmlDescRecordField descField -> Just descField
389+ fName = TH.mkName (fieldName fieldStrName)
390+ exprFieldStrName = TH.litE (TH.stringL fieldStrName)
391+ exprForField = case fieldPlural of
392+ XmlFieldPluralMandatory -> [e|id|]
394+ exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
396+ [e|(\a -> XW.elementA $exprFieldStrName (toXmlParentAttributes a) a)|]
397+ return [e|$exprForField $exprFieldRender $exprFieldValue|]
399+ = TH.lamE [if null exprFields then TH.wildP else TH.varP objName]
400+ $ foldr (\fe e -> [e|$fe *> $e|]) [e|return ()|] exprFields
403+ [t|XW.ToXML $(TH.conT name)|]
404+ [funSimple 'XW.toXML toXmlExpr]
406+ toXmlParentAttributesInst <- do
407+ objName <- TH.newName strPrefix
410+ descRecordPart <- descRecordParts
411+ IsoXmlDescAttribute attributePlural attributeStrName _ <-
412+ maybeToList $ case descRecordPart of
413+ IsoXmlDescRecordAttribute descAttribute -> Just descAttribute
416+ fName = TH.mkName (fieldName attributeStrName)
417+ exprAttrStrName = TH.litE (TH.stringL attributeStrName)
418+ exprAttrValue = [e|$(TH.varE fName) $(TH.varE objName)|]
419+ exprAttrWrap = case attributePlural of
420+ XmlAttributePluralMandatory -> [e|Just . toXmlAttribute|]
421+ XmlAttributePluralOptional -> [e|fmap toXmlAttribute|]
422+ return [e|($exprAttrStrName, $exprAttrWrap $exprAttrValue)|]
423+ toXmlParentAttributesExpr
424+ = TH.lamE [if null exprAttributes then TH.wildP else TH.varP objName]
425+ $ [e|mapMaybe distribPair $(TH.listE exprAttributes)|]
426+#if __GLASGOW_HASKELL__ < 800
429+ TH.instanceWithOverlapD (Just TH.Overlapping)
432+ [t|ToXmlParentAttributes $(TH.conT name)|]
433+ [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]
435+ return $ [dataDecl] ++ lensDecls ++
436+ [fromDomInst, toXmlInst, toXmlParentAttributesInst]
438+distribPair :: Functor f => (a, f b) -> f (a, b)
439+distribPair (a, fb) = (a,) <$> fb