@@ -1,5 +1,4 @@
1−{-# LANGUAGE UndecidableInstances #-}
1+{-# LANGUAGE NoImplicitPrelude #-}
2−{-# LANGUAGE FunctionalDependencies #-}
@@ -117,386 +116,12 @@ module Data.THGen.XML
119 -- Re-exports
118 -- Re-exports
122− , Integer
121+ , P.Integer
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)
132−import Data.THGen.Compat
133import Data.THGen.Enum
124import Data.THGen.Enum
134−import qualified Data.Text as T
125+import Data.THGen.XML.Internal
135−import GHC.Generics (Generic)
126+import Data.Text
136−import qualified Language.Haskell.TH as TH
127+import qualified Prelude as P
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
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)
151−data XmlAttributePlural
152− = XmlAttributePluralMandatory -- Occurs exactly 1 time (Identity)
153− | XmlAttributePluralOptional -- Occurs 0 or 1 times (Maybe)
155−data PrefixName = PrefixName String String
157−data IsoXmlDescPreField = IsoXmlDescPreField String TH.TypeQ
159−data IsoXmlDescPreAttribute = IsoXmlDescPreAttribute String TH.TypeQ
161−data IsoXmlDescPreContent = IsoXmlDescPreContent String TH.TypeQ
163−data IsoXmlDescField = IsoXmlDescField XmlFieldPlural String TH.TypeQ
165−data IsoXmlDescAttribute = IsoXmlDescAttribute XmlAttributePlural String TH.TypeQ
167−data IsoXmlDescContent = IsoXmlDescContent String TH.TypeQ
169−data IsoXmlDescRecordPart
170− = IsoXmlDescRecordField IsoXmlDescField
171− | IsoXmlDescRecordAttribute IsoXmlDescAttribute
172− | IsoXmlDescRecordContent IsoXmlDescContent
174−newtype IsoXmlDescRecord = IsoXmlDescRecord [IsoXmlDescRecordPart]
176−makePrisms ''IsoXmlDescRecord
178−data ExhaustivenessName = ExhaustivenessName String Exhaustiveness
180−newtype IsoXmlDescEnumCon
181− = IsoXmlDescEnumCon { unIsoXmlDescEnumCon :: String }
183−instance IsString IsoXmlDescEnumCon where
184− fromString = IsoXmlDescEnumCon
186−data IsoXmlDescEnum = IsoXmlDescEnum [IsoXmlDescEnumCon]
188−makePrisms ''IsoXmlDescEnum
193− -> IsoXmlDescPreField
195−appendField plural xrec (IsoXmlDescPreField name ty) =
196− let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty
197− in over _IsoXmlDescRecord (xfield:) xrec
200− :: XmlAttributePlural
202− -> IsoXmlDescPreAttribute
204−appendAttribute plural xrec (IsoXmlDescPreAttribute name ty) =
205− let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty
206− in over _IsoXmlDescRecord (xattribute:) xrec
210− -> IsoXmlDescPreContent
212−appendContent xrec (IsoXmlDescPreContent name ty) =
213− let xcontent = IsoXmlDescRecordContent $ IsoXmlDescContent name ty
214− in over _IsoXmlDescRecord (xcontent:) xrec
216−(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
217−(!) = appendField XmlFieldPluralMandatory
218−(?) = appendField XmlFieldPluralOptional
219−(*) = appendField XmlFieldPluralRepeated
220−(+) = appendField XmlFieldPluralMultiplied
222−(!%), (?%) :: IsoXmlDescRecord -> IsoXmlDescPreAttribute -> IsoXmlDescRecord
223−(!%) = appendAttribute XmlAttributePluralMandatory
224−(?%) = appendAttribute XmlAttributePluralOptional
226−(^) :: IsoXmlDescRecord -> IsoXmlDescPreContent -> IsoXmlDescRecord
237−appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
238−appendEnumCon xenum xenumcon =
239− over _IsoXmlDescEnum (xenumcon:) xenum
241−(&) :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
246−class Description name desc | desc -> name where
247− (=:=) :: name -> desc -> TH.DecsQ
251−instance Description PrefixName IsoXmlDescRecord where
252− prefixName =:= descRecord =
253− let descRecordParts = descRecord ^. _IsoXmlDescRecord
254− in isoXmlGenerateDatatype prefixName (reverse descRecordParts)
256−record :: IsoXmlDescRecord
257−record = IsoXmlDescRecord []
259−enum :: IsoXmlDescEnum
260−enum = IsoXmlDescEnum []
262−instance Description ExhaustivenessName IsoXmlDescEnum where
263− exhaustivenessName =:= descEnum =
264− let descEnumCons = descEnum ^. _IsoXmlDescEnum
265− in isoXmlGenerateEnum exhaustivenessName (reverse descEnumCons)
267−instance IsString (TH.TypeQ -> IsoXmlDescPreField) where
268− fromString = IsoXmlDescPreField
270−instance IsString IsoXmlDescPreField where
271− fromString name = IsoXmlDescPreField name ty
273− ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper (xmlLocalName name))
275−instance IsString (TH.TypeQ -> IsoXmlDescPreAttribute) where
276− fromString = IsoXmlDescPreAttribute
278−instance IsString (TH.TypeQ -> IsoXmlDescPreContent) where
279− fromString = IsoXmlDescPreContent
281−instance IsString IsoXmlDescPreAttribute where
282− fromString name = IsoXmlDescPreAttribute name ty
284− ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)
286−instance IsString IsoXmlDescPreContent where
287− fromString name = IsoXmlDescPreContent name ty
289− ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)
291−instance s ~ String => IsString (s -> PrefixName) where
292− fromString = PrefixName
294−instance IsString PrefixName where
295− fromString strName = PrefixName strName (makeNamePrefix strName)
297−instance e ~ Exhaustiveness => IsString (e -> ExhaustivenessName) where
298− fromString = ExhaustivenessName
300−instance IsString ExhaustivenessName where
301− fromString strName = ExhaustivenessName strName NonExhaustive
303−makeNamePrefix :: String -> String
304−makeNamePrefix = map C.toLower . filter C.isUpper
306−funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ
307−funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]
310− :: ExhaustivenessName -> [IsoXmlDescEnumCon] -> TH.DecsQ
311−isoXmlGenerateEnum (ExhaustivenessName strName' exh) enumCons = do
313− strName = "Xml" ++ strName'
314− strVals = map unIsoXmlDescEnumCon enumCons
315− enumDesc = EnumDesc exh strName strVals
316− name = TH.mkName strName
317− enumDecls <- enumGenerate enumDesc
321− [t|XW.ToXML $(TH.conT name)|]
322− [funSimple 'XW.toXML [e|XW.toXML . T.pack . show|]]
323− toXmlAttributeInst <- do
326− [t|ToXmlAttribute $(TH.conT name)|]
327− [funSimple 'toXmlAttribute [e|T.pack . show|]]
331− [t|FromDom $(TH.conT name)|]
332− [funSimple 'fromDom [e|parseContent readContent|]]
333− fromAttributeInst <- do
336− [t|FromAttribute $(TH.conT name)|]
337− [funSimple 'fromAttribute [e|readContent|]]
338− return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
339− fromDomInst, fromAttributeInst]
341−isoXmlGenerateDatatype :: PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ
342−isoXmlGenerateDatatype (PrefixName strName' strPrefix') descRecordParts = do
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
352− descRecordPart <- descRecordParts
353− return $ case descRecordPart of
354− IsoXmlDescRecordField descField ->
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 |]
365− then varStrictType fName (nonStrictType fType)
366− else varStrictType fName (strictType fType)
367− IsoXmlDescRecordAttribute descAttribute ->
370− attributePlural attributeStrName attributeType = descAttribute
371− fName = TH.mkName (fieldName attributeStrName)
372− fType = case attributePlural of
373− XmlAttributePluralMandatory -> attributeType
374− XmlAttributePluralOptional -> [t| Maybe $attributeType |]
376− then varStrictType fName (nonStrictType fType)
377− else varStrictType fName (strictType fType)
378− IsoXmlDescRecordContent descContent ->
380− IsoXmlDescContent contentStrName contentType = descContent
381− fName = TH.mkName (fieldName contentStrName)
384− then varStrictType fName (nonStrictType fType)
385− else varStrictType fName (strictType fType)
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
394− [t|NFData $(TH.conT name)|]
398− exprHeader = [e|pure $(TH.conE name)|]
399− exprRecordParts = do
400− descRecordPart <- descRecordParts
401− return $ case descRecordPart of
402− IsoXmlDescRecordField descField ->
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|]
411− [e|$fieldParse $exprFieldStrName fromDom|]
412− IsoXmlDescRecordAttribute descAttribute ->
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|]
420− [e|$attributeParse $exprAttributeStrName fromAttribute|]
421− IsoXmlDescRecordContent _ -> [e|parseContent fromAttribute|]
422− fromDomExpr = foldl (\e fe -> [e| $e <*> $fe |]) exprHeader exprRecordParts
425− [t|FromDom $(TH.conT name)|]
426− [ funSimple 'fromDom fromDomExpr ]
429− objName <- TH.newName strPrefix
432− descRecordPart <- descRecordParts
433− case descRecordPart of
434− IsoXmlDescRecordField (IsoXmlDescField fieldPlural rawName _) -> do
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|]
442− exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
445− XW.elementA $exprFieldStrName (toXmlParentAttributes a) a)|]
446− return [e|$exprForField $exprFieldRender $exprFieldValue|]
447− IsoXmlDescRecordContent (IsoXmlDescContent rawName _) -> do
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|]
455− = TH.lamE [if null exprFields then TH.wildP else TH.varP objName]
456− $ foldr (\fe e -> [e|$fe *> $e|]) [e|return ()|] exprFields
459− [t|XW.ToXML $(TH.conT name)|]
460− [funSimple 'XW.toXML toXmlExpr]
462− toXmlParentAttributesInst <- do
463− objName <- TH.newName strPrefix
466− descRecordPart <- descRecordParts
467− IsoXmlDescAttribute attributePlural attributeStrName _ <-
468− maybeToList $ case descRecordPart of
469− IsoXmlDescRecordAttribute descAttribute -> Just descAttribute
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
485− TH.instanceWithOverlapD (Just TH.Overlapping)
488− [t|ToXmlParentAttributes $(TH.conT name)|]
489− [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]
491− return $ [termDecl] ++ lensDecls ++
492− [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]
494−distribPair :: Functor f => (a, f b) -> f (a, b)
495−distribPair (a, fb) = (a,) <$> fb
497−-- | Get a local part of (possibly) fully qualified 'X.Name':
499−-- >>> xmlLocalName "{http://example.com/ns/my-namespace}my-name"
501−xmlLocalName :: String -> String
502−xmlLocalName = T.unpack . X.nameLocalName . fromString