@@ -1,5 +1,4 @@
1−{-# LANGUAGE UndecidableInstances #-}
2−{-# LANGUAGE FunctionalDependencies #-}
1+{-# LANGUAGE NoImplicitPrelude #-}
32
43{- |
54
@@ -117,386 +116,12 @@ module Data.THGen.XML
117116 , (^)
118117 , (=:=)
119118 -- Re-exports
120− , T.Text
121− , Int
122− , Integer
119+ , Text
120+ , P.Int
121+ , P.Integer
123122 ) where
124123
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
133124import 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
125+import Data.THGen.XML.Internal
126+import Data.Text
127+import qualified Prelude as P