@@ -1,5 +1,4 @@
1−{-# LANGUAGE UndecidableInstances #-}
2−{-# LANGUAGE FunctionalDependencies #-}
1+{-# LANGUAGE NoImplicitPrelude #-}
32
43{- |
54
@@ -23,7 +22,7 @@ wrapper around the field type:
2322
2423Example 1.
2524
26−> "Color" =:= enum
25+> "Color" =:= enum Both
2726> & "R"
2827> & "G"
2928> & "B"
@@ -41,7 +40,7 @@ to be either @R@, @G@ or @B@.
4140
4241Example 2.
4342
44−> "Message" =:= record
43+> "Message" =:= record Both
4544> ! "author"
4645> + "recipient"
4746> ? "message" [t|Text|]
@@ -68,10 +67,10 @@ enumeration is exhaustive (contains only the listed constructors) or
6867non-exhaustive (also contains a constructor for unknown values; this
6968is the default):
7069
71−> "Enum1" Exhaustive =:= enum
70+> "Enum1" Exhaustive =:= enum Generator
7271> ...
7372
74−> "Enum2" NonExhaustive =:= enum
73+> "Enum2" NonExhaustive =:= enum Generator
7574> ...
7675
7776To define a record, use the `record` function followed by the name of
@@ -79,7 +78,7 @@ the data type to be generated. The prefix for the record fields is
7978inferred automatically by taking all of the uppercase letters in the
8079name. You can override it manually like so:
8180
82−> "Reference" "ref" =:= record
81+> "Reference" "ref" =:= record Parser
8382> ...
8483
8584To describe a record field you must supply its name as it appears
@@ -94,10 +93,14 @@ The type of the field is inferred automatically from its name, so
9493if the field is called @"author"@ its type will be @Author@. You can
9594override the type by specifying it in quasiquotes like so:
9695
97−> "Message" =:= record
98−> ! "author" [t|Person|]
96+> "Message" =:= record Both
97+> ! "author" [t|Person|].
9998> ...
10099
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+
101104-}
102105
103106
@@ -105,6 +108,7 @@ module Data.THGen.XML
105108 ( Exhaustiveness(..)
106109 , PrefixName(..)
107110 , ExhaustivenessName(..)
111+ , GenType(..)
108112 , record
109113 , enum
110114 , (!)
@@ -117,386 +121,12 @@ module Data.THGen.XML
117121 , (^)
118122 , (=:=)
119123 -- Re-exports
120− , T.Text
121− , Int
122− , Integer
124+ , Text
125+ , P.Int
126+ , P.Integer
123127 ) where
124128
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
133129import Data.THGen.Enum
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
130+import Data.THGen.XML.Internal
131+import Data.Text
132+import qualified Prelude as P