@@ -1,4 +1,5 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
1+{-# LANGUAGE UndecidableInstances #-}
2+{-# LANGUAGE FunctionalDependencies #-}
23
34{- |
45
@@ -22,7 +23,7 @@ wrapper around the field type:
2223
2324Example 1.
2425
25−> "Color" =:= enum Both
26+> "Color" =:= enum
2627> & "R"
2728> & "G"
2829> & "B"
@@ -40,7 +41,7 @@ to be either @R@, @G@ or @B@.
4041
4142Example 2.
4243
43−> "Message" =:= record Both
44+> "Message" =:= record
4445> ! "author"
4546> + "recipient"
4647> ? "message" [t|Text|]
@@ -67,10 +68,10 @@ enumeration is exhaustive (contains only the listed constructors) or
6768non-exhaustive (also contains a constructor for unknown values; this
6869is the default):
6970
70−> "Enum1" Exhaustive =:= enum Generator
71+> "Enum1" Exhaustive =:= enum
7172> ...
7273
73−> "Enum2" NonExhaustive =:= enum Generator
74+> "Enum2" NonExhaustive =:= enum
7475> ...
7576
7677To 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
7879inferred automatically by taking all of the uppercase letters in the
7980name. You can override it manually like so:
8081
81−> "Reference" "ref" =:= record Parser
82+> "Reference" "ref" =:= record
8283> ...
8384
8485To 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
9394if the field is called @"author"@ its type will be @Author@. You can
9495override the type by specifying it in quasiquotes like so:
9596
96−> "Message" =:= record Both
97−> ! "author" [t|Person|].
97+> "Message" =:= record
98+> ! "author" [t|Person|]
9899> ...
99100
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.
103−
104101-}
105102
106103
@@ -108,7 +105,6 @@ module Data.THGen.XML
108105 ( Exhaustiveness(..)
109106 , PrefixName(..)
110107 , ExhaustivenessName(..)
111− , GenType(..)
112108 , record
113109 , enum
114110 , (!)
@@ -121,12 +117,386 @@ module Data.THGen.XML
121117 , (^)
122118 , (=:=)
123119 -- Re-exports
124− , Text
125− , P.Int
126− , P.Integer
120+ , T.Text
121+ , Int
122+ , Integer
127123 ) where
128124
125+import Control.DeepSeq
126+import Control.Lens hiding (repeated, enum, (&))
127+import Control.Lens.Internal.FieldTH (makeFieldOpticsForDec)
128+import qualified Data.Char as C
129+import Data.List.NonEmpty (NonEmpty)
130+import Data.Maybe (maybeToList, mapMaybe)
131+import Data.String
132+import Data.THGen.Compat
129133import Data.THGen.Enum
130−import Data.THGen.XML.Internal
131−import Data.Text
132−import qualified Prelude as P
134+import qualified Data.Text as T
135+import GHC.Generics (Generic)
136+import qualified Language.Haskell.TH as TH
137+import Prelude hiding ((+), (*), (^))
138+import qualified Text.XML as X
139+import Text.XML.DOM.Parser hiding (parseContent)
140+import Text.XML.ParentAttributes
141+import qualified Text.XML.Writer as XW
142+import Text.XML.DOM.Parser.Internal.Content
143+
144+
145+data XmlFieldPlural
146+ = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
147+ | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)
148+ | XmlFieldPluralRepeated -- Occurs 0 or more times (List)
149+ | XmlFieldPluralMultiplied -- Occurs 1 or more times (NonEmpty)
150+
151+data XmlAttributePlural
152+ = XmlAttributePluralMandatory -- Occurs exactly 1 time (Identity)
153+ | XmlAttributePluralOptional -- Occurs 0 or 1 times (Maybe)
154+
155+data PrefixName = PrefixName String String
156+
157+data IsoXmlDescPreField = IsoXmlDescPreField String TH.TypeQ
158+
159+data IsoXmlDescPreAttribute = IsoXmlDescPreAttribute String TH.TypeQ
160+
161+data IsoXmlDescPreContent = IsoXmlDescPreContent String TH.TypeQ
162+
163+data IsoXmlDescField = IsoXmlDescField XmlFieldPlural String TH.TypeQ
164+
165+data IsoXmlDescAttribute = IsoXmlDescAttribute XmlAttributePlural String TH.TypeQ
166+
167+data IsoXmlDescContent = IsoXmlDescContent String TH.TypeQ
168+
169+data IsoXmlDescRecordPart
170+ = IsoXmlDescRecordField IsoXmlDescField
171+ | IsoXmlDescRecordAttribute IsoXmlDescAttribute
172+ | IsoXmlDescRecordContent IsoXmlDescContent
173+
174+newtype IsoXmlDescRecord = IsoXmlDescRecord [IsoXmlDescRecordPart]
175+
176+makePrisms ''IsoXmlDescRecord
177+
178+data ExhaustivenessName = ExhaustivenessName String Exhaustiveness
179+
180+newtype IsoXmlDescEnumCon
181+ = IsoXmlDescEnumCon { unIsoXmlDescEnumCon :: String }
182+
183+instance IsString IsoXmlDescEnumCon where
184+ fromString = IsoXmlDescEnumCon
185+
186+data IsoXmlDescEnum = IsoXmlDescEnum [IsoXmlDescEnumCon]
187+
188+makePrisms ''IsoXmlDescEnum
189+
190+appendField
191+ :: XmlFieldPlural
192+ -> IsoXmlDescRecord
193+ -> IsoXmlDescPreField
194+ -> IsoXmlDescRecord
195+appendField plural xrec (IsoXmlDescPreField name ty) =
196+ let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty
197+ in over _IsoXmlDescRecord (xfield:) xrec
198+
199+appendAttribute
200+ :: XmlAttributePlural
201+ -> IsoXmlDescRecord
202+ -> IsoXmlDescPreAttribute
203+ -> IsoXmlDescRecord
204+appendAttribute plural xrec (IsoXmlDescPreAttribute name ty) =
205+ let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty
206+ in over _IsoXmlDescRecord (xattribute:) xrec
207+
208+appendContent
209+ :: IsoXmlDescRecord
210+ -> IsoXmlDescPreContent
211+ -> IsoXmlDescRecord
212+appendContent xrec (IsoXmlDescPreContent name ty) =
213+ let xcontent = IsoXmlDescRecordContent $ IsoXmlDescContent name ty
214+ in over _IsoXmlDescRecord (xcontent:) xrec
215+
216+(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
217+(!) = appendField XmlFieldPluralMandatory
218+(?) = appendField XmlFieldPluralOptional
219+(*) = appendField XmlFieldPluralRepeated
220+(+) = appendField XmlFieldPluralMultiplied
221+
222+(!%), (?%) :: IsoXmlDescRecord -> IsoXmlDescPreAttribute -> IsoXmlDescRecord
223+(!%) = appendAttribute XmlAttributePluralMandatory
224+(?%) = appendAttribute XmlAttributePluralOptional
225+
226+(^) :: IsoXmlDescRecord -> IsoXmlDescPreContent -> IsoXmlDescRecord
227+(^) = appendContent
228+
229+infixl 2 !
230+infixl 2 ?
231+infixl 2 *
232+infixl 2 +
233+infixl 2 !%
234+infixl 2 ?%
235+infixl 2 ^
236+
237+appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
238+appendEnumCon xenum xenumcon =
239+ over _IsoXmlDescEnum (xenumcon:) xenum
240+
241+(&) :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
242+(&) = appendEnumCon
243+
244+infixl 2 &
245+
246+class Description name desc | desc -> name where
247+ (=:=) :: name -> desc -> TH.DecsQ
248+
249+infix 0 =:=
250+
251+instance Description PrefixName IsoXmlDescRecord where
252+ prefixName =:= descRecord =
253+ let descRecordParts = descRecord ^. _IsoXmlDescRecord
254+ in isoXmlGenerateDatatype prefixName (reverse descRecordParts)
255+
256+record :: IsoXmlDescRecord
257+record = IsoXmlDescRecord []
258+
259+enum :: IsoXmlDescEnum
260+enum = IsoXmlDescEnum []
261+
262+instance Description ExhaustivenessName IsoXmlDescEnum where
263+ exhaustivenessName =:= descEnum =
264+ let descEnumCons = descEnum ^. _IsoXmlDescEnum
265+ in isoXmlGenerateEnum exhaustivenessName (reverse descEnumCons)
266+
267+instance IsString (TH.TypeQ -> IsoXmlDescPreField) where
268+ fromString = IsoXmlDescPreField
269+
270+instance IsString IsoXmlDescPreField where
271+ fromString name = IsoXmlDescPreField name ty
272+ where
273+ ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper (xmlLocalName name))
274+
275+instance IsString (TH.TypeQ -> IsoXmlDescPreAttribute) where
276+ fromString = IsoXmlDescPreAttribute
277+
278+instance IsString (TH.TypeQ -> IsoXmlDescPreContent) where
279+ fromString = IsoXmlDescPreContent
280+
281+instance IsString IsoXmlDescPreAttribute where
282+ fromString name = IsoXmlDescPreAttribute name ty
283+ where
284+ ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)
285+
286+instance IsString IsoXmlDescPreContent where
287+ fromString name = IsoXmlDescPreContent name ty
288+ where
289+ ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)
290+
291+instance s ~ String => IsString (s -> PrefixName) where
292+ fromString = PrefixName
293+
294+instance IsString PrefixName where
295+ fromString strName = PrefixName strName (makeNamePrefix strName)
296+
297+instance e ~ Exhaustiveness => IsString (e -> ExhaustivenessName) where
298+ fromString = ExhaustivenessName
299+
300+instance IsString ExhaustivenessName where
301+ fromString strName = ExhaustivenessName strName NonExhaustive
302+
303+makeNamePrefix :: String -> String
304+makeNamePrefix = map C.toLower . filter C.isUpper
305+
306+funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ
307+funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]
308+
309+isoXmlGenerateEnum
310+ :: ExhaustivenessName -> [IsoXmlDescEnumCon] -> TH.DecsQ
311+isoXmlGenerateEnum (ExhaustivenessName strName' exh) enumCons = do
312+ let
313+ strName = "Xml" ++ strName'
314+ strVals = map unIsoXmlDescEnumCon enumCons
315+ enumDesc = EnumDesc exh strName strVals
316+ name = TH.mkName strName
317+ enumDecls <- enumGenerate enumDesc
318+ toXmlInst <- do
319+ TH.instanceD
320+ (return [])
321+ [t|XW.ToXML $(TH.conT name)|]
322+ [funSimple 'XW.toXML [e|XW.toXML . T.pack . show|]]
323+ toXmlAttributeInst <- do
324+ TH.instanceD
325+ (return [])
326+ [t|ToXmlAttribute $(TH.conT name)|]
327+ [funSimple 'toXmlAttribute [e|T.pack . show|]]
328+ fromDomInst <- do
329+ TH.instanceD
330+ (return [])
331+ [t|FromDom $(TH.conT name)|]
332+ [funSimple 'fromDom [e|parseContent readContent|]]
333+ fromAttributeInst <- do
334+ TH.instanceD
335+ (return [])
336+ [t|FromAttribute $(TH.conT name)|]
337+ [funSimple 'fromAttribute [e|readContent|]]
338+ return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
339+ fromDomInst, fromAttributeInst]
340+
341+isoXmlGenerateDatatype :: PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ
342+isoXmlGenerateDatatype (PrefixName strName' strPrefix') descRecordParts = do
343+ let
344+ isNewtype = length descRecordParts == 1
345+ strName = "Xml" ++ strName'
346+ strPrefix = "x" ++ strPrefix'
347+ name = TH.mkName strName
348+ fieldName str = "_" ++ strPrefix ++ over _head C.toUpper str
349+ termDecl <- do
350+ let
351+ fields = do
352+ descRecordPart <- descRecordParts
353+ return $ case descRecordPart of
354+ IsoXmlDescRecordField descField ->
355+ let
356+ IsoXmlDescField fieldPlural rawName fieldType = descField
357+ fieldStrName = xmlLocalName rawName
358+ fName = TH.mkName (fieldName fieldStrName)
359+ fType = case fieldPlural of
360+ XmlFieldPluralMandatory -> fieldType
361+ XmlFieldPluralOptional -> [t| Maybe $fieldType |]
362+ XmlFieldPluralRepeated -> [t| [$fieldType] |]
363+ XmlFieldPluralMultiplied -> [t| NonEmpty $fieldType |]
364+ in if isNewtype
365+ then varStrictType fName (nonStrictType fType)
366+ else varStrictType fName (strictType fType)
367+ IsoXmlDescRecordAttribute descAttribute ->
368+ let
369+ IsoXmlDescAttribute
370+ attributePlural attributeStrName attributeType = descAttribute
371+ fName = TH.mkName (fieldName attributeStrName)
372+ fType = case attributePlural of
373+ XmlAttributePluralMandatory -> attributeType
374+ XmlAttributePluralOptional -> [t| Maybe $attributeType |]
375+ in if isNewtype
376+ then varStrictType fName (nonStrictType fType)
377+ else varStrictType fName (strictType fType)
378+ IsoXmlDescRecordContent descContent ->
379+ let
380+ IsoXmlDescContent contentStrName contentType = descContent
381+ fName = TH.mkName (fieldName contentStrName)
382+ fType = contentType
383+ in if isNewtype
384+ then varStrictType fName (nonStrictType fType)
385+ else varStrictType fName (strictType fType)
386+ if isNewtype
387+ -- generate a newtype instead to do less allocations later
388+ then newtypeD name (TH.recC name fields) [''Eq, ''Show, ''Generic]
389+ else dataD name [TH.recC name fields] [''Eq, ''Show, ''Generic]
390+ lensDecls <- makeFieldOpticsForDec lensRules termDecl
391+ nfDataInst <- do
392+ TH.instanceD
393+ (return [])
394+ [t|NFData $(TH.conT name)|]
395+ [ ]
396+ fromDomInst <- do
397+ let
398+ exprHeader = [e|pure $(TH.conE name)|]
399+ exprRecordParts = do
400+ descRecordPart <- descRecordParts
401+ return $ case descRecordPart of
402+ IsoXmlDescRecordField descField ->
403+ let
404+ IsoXmlDescField fieldPlural rawName _ = descField
405+ fieldStrName = xmlLocalName rawName
406+ exprFieldStrName = TH.litE (TH.stringL fieldStrName)
407+ fieldParse = case fieldPlural of
408+ XmlFieldPluralMandatory -> [e|inElem|]
409+ _ -> [e|inElemTrav|]
410+ in
411+ [e|$fieldParse $exprFieldStrName fromDom|]
412+ IsoXmlDescRecordAttribute descAttribute ->
413+ let
414+ IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute
415+ exprAttributeStrName = TH.litE (TH.stringL attributeStrName)
416+ attributeParse = case attributePlural of
417+ XmlAttributePluralMandatory -> [e|parseAttribute|]
418+ XmlAttributePluralOptional -> [e|parseAttributeMaybe|]
419+ in
420+ [e|$attributeParse $exprAttributeStrName fromAttribute|]
421+ IsoXmlDescRecordContent _ -> [e|parseContent fromAttribute|]
422+ fromDomExpr = foldl (\e fe -> [e| $e <*> $fe |]) exprHeader exprRecordParts
423+ TH.instanceD
424+ (return [])
425+ [t|FromDom $(TH.conT name)|]
426+ [ funSimple 'fromDom fromDomExpr ]
427+
428+ toXmlInst <- do
429+ objName <- TH.newName strPrefix
430+ let
431+ exprFields = do
432+ descRecordPart <- descRecordParts
433+ case descRecordPart of
434+ IsoXmlDescRecordField (IsoXmlDescField fieldPlural rawName _) -> do
435+ let
436+ fieldStrName = xmlLocalName rawName
437+ fName = TH.mkName (fieldName fieldStrName)
438+ exprFieldStrName = TH.litE (TH.stringL rawName)
439+ exprForField = case fieldPlural of
440+ XmlFieldPluralMandatory -> [e|id|]
441+ _ -> [e|traverse|]
442+ exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
443+ exprFieldRender =
444+ [e|(\a ->
445+ XW.elementA $exprFieldStrName (toXmlParentAttributes a) a)|]
446+ return [e|$exprForField $exprFieldRender $exprFieldValue|]
447+ IsoXmlDescRecordContent (IsoXmlDescContent rawName _) -> do
448+ let
449+ fieldStrName = xmlLocalName rawName
450+ fName = TH.mkName (fieldName fieldStrName)
451+ exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
452+ return [e|XW.content . toXmlAttribute $ $exprFieldValue|]
453+ _ -> []
454+ toXmlExpr
455+ = TH.lamE [if null exprFields then TH.wildP else TH.varP objName]
456+ $ foldr (\fe e -> [e|$fe *> $e|]) [e|return ()|] exprFields
457+ TH.instanceD
458+ (return [])
459+ [t|XW.ToXML $(TH.conT name)|]
460+ [funSimple 'XW.toXML toXmlExpr]
461+
462+ toXmlParentAttributesInst <- do
463+ objName <- TH.newName strPrefix
464+ let
465+ exprAttributes = do
466+ descRecordPart <- descRecordParts
467+ IsoXmlDescAttribute attributePlural attributeStrName _ <-
468+ maybeToList $ case descRecordPart of
469+ IsoXmlDescRecordAttribute descAttribute -> Just descAttribute
470+ _ -> Nothing
471+ let
472+ fName = TH.mkName (fieldName attributeStrName)
473+ exprAttrStrName = TH.litE (TH.stringL attributeStrName)
474+ exprAttrValue = [e|$(TH.varE fName) $(TH.varE objName)|]
475+ exprAttrWrap = case attributePlural of
476+ XmlAttributePluralMandatory -> [e|Just . toXmlAttribute|]
477+ XmlAttributePluralOptional -> [e|fmap toXmlAttribute|]
478+ return [e|($exprAttrStrName, $exprAttrWrap $exprAttrValue)|]
479+ toXmlParentAttributesExpr
480+ = TH.lamE [if null exprAttributes then TH.wildP else TH.varP objName]
481+ $ [e|mapMaybe distribPair $(TH.listE exprAttributes)|]
482+#if __GLASGOW_HASKELL__ < 800
483+ TH.instanceD
484+#else
485+ TH.instanceWithOverlapD (Just TH.Overlapping)
486+#endif
487+ (return [])
488+ [t|ToXmlParentAttributes $(TH.conT name)|]
489+ [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]
490+
491+ return $ [termDecl] ++ lensDecls ++
492+ [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]
493+
494+distribPair :: Functor f => (a, f b) -> f (a, b)
495+distribPair (a, fb) = (a,) <$> fb
496+
497+-- | Get a local part of (possibly) fully qualified 'X.Name':
498+--
499+-- >>> xmlLocalName "{http://example.com/ns/my-namespace}my-name"
500+-- "my-name"
501+xmlLocalName :: String -> String
502+xmlLocalName = T.unpack . X.nameLocalName . fromString