@@ -1,457 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE UndecidableInstances #-}
3−{-# LANGUAGE FunctionalDependencies #-}
4−
5−module Data.THGen.XML.Internal where
6−
7−import Control.DeepSeq
8−import Control.Lens hiding (repeated, enum, (&), Strict)
9−import Control.Lens.Internal.FieldTH (makeFieldOpticsForDec)
10−import qualified Data.Char as C
11−import Data.List.NonEmpty (NonEmpty)
12−import Data.Maybe (maybeToList, mapMaybe)
13−import Data.String
14−import Data.THGen.Compat as THC
15−import Data.THGen.Enum
16−import qualified Data.Text as T
17−import GHC.Generics (Generic)
18−import Language.Haskell.TH as TH hiding (Strict)
19−import Prelude hiding ((+), (*), (^))
20−import qualified Text.XML as X
21−import Text.XML.DOM.Parser hiding (parseContent)
22−import Text.XML.DOM.Parser.Internal.Content
23−import Text.XML.ParentAttributes
24−import qualified Text.XML.Writer as XW
25−
26−data ParserMode
27− = Strict
28− | Lenient
29−
30−data GenType
31− = Parser
32− | Generator
33− | ParserAndGenerator
34− | LenientParser
35− | LenientParserAndGenerator
36−
37−isLenientType :: GenType -> Bool
38−isLenientType = \case
39− LenientParser -> True
40− LenientParserAndGenerator -> True
41− _ -> False
42−
43−data XmlFieldPlural
44− = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
45− | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)
46− | XmlFieldPluralRepeated -- Occurs 0 or more times (List)
47− | XmlFieldPluralMultiplied -- Occurs 1 or more times (NonEmpty)
48−
49−data XmlAttributePlural
50− = XmlAttributePluralMandatory -- Occurs exactly 1 time (Identity)
51− | XmlAttributePluralOptional -- Occurs 0 or 1 times (Maybe)
52−
53−data PrefixName = PrefixName String String
54−
55−data IsoXmlDescPreField = IsoXmlDescPreField String TH.TypeQ
56−
57−data IsoXmlDescPreAttribute = IsoXmlDescPreAttribute String TH.TypeQ
58−
59−data IsoXmlDescPreContent = IsoXmlDescPreContent String TH.TypeQ
60−
61−data IsoXmlDescField = IsoXmlDescField XmlFieldPlural String TH.TypeQ
62−
63−data IsoXmlDescAttribute = IsoXmlDescAttribute XmlAttributePlural String TH.TypeQ
64−
65−data IsoXmlDescContent = IsoXmlDescContent String TH.TypeQ
66−
67−data IsoXmlDescRecordPart
68− = IsoXmlDescRecordField IsoXmlDescField
69− | IsoXmlDescRecordAttribute IsoXmlDescAttribute
70− | IsoXmlDescRecordContent IsoXmlDescContent
71−
72−data IsoXmlDescRecord = IsoXmlDescRecord GenType [IsoXmlDescRecordPart]
73−
74−makePrisms ''IsoXmlDescRecord
75−
76−data ExhaustivenessName = ExhaustivenessName String Exhaustiveness
77−
78−newtype IsoXmlDescEnumCon
79− = IsoXmlDescEnumCon { unIsoXmlDescEnumCon :: String }
80−
81−instance IsString IsoXmlDescEnumCon where
82− fromString = IsoXmlDescEnumCon
83−
84−data IsoXmlDescEnum = IsoXmlDescEnum GenType [IsoXmlDescEnumCon]
85−
86−makePrisms ''IsoXmlDescEnum
87−
88−appendField
89− :: XmlFieldPlural
90− -> IsoXmlDescRecord
91− -> IsoXmlDescPreField
92− -> IsoXmlDescRecord
93−appendField plural (IsoXmlDescRecord genType fields) (IsoXmlDescPreField name ty) =
94− let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty
95− in IsoXmlDescRecord genType (xfield:fields)
96−
97−appendAttribute
98− :: XmlAttributePlural
99− -> IsoXmlDescRecord
100− -> IsoXmlDescPreAttribute
101− -> IsoXmlDescRecord
102−appendAttribute plural (IsoXmlDescRecord genType fields) (IsoXmlDescPreAttribute name ty) =
103− let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty
104− in IsoXmlDescRecord genType (xattribute:fields)
105−
106−appendContent
107− :: IsoXmlDescRecord
108− -> IsoXmlDescPreContent
109− -> IsoXmlDescRecord
110−appendContent (IsoXmlDescRecord genType fields) (IsoXmlDescPreContent name ty) =
111− let xcontent = IsoXmlDescRecordContent $ IsoXmlDescContent name ty
112− in IsoXmlDescRecord genType (xcontent:fields)
113−
114−(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
115−(!) = appendField XmlFieldPluralMandatory
116−(?) = appendField XmlFieldPluralOptional
117−(*) = appendField XmlFieldPluralRepeated
118−(+) = appendField XmlFieldPluralMultiplied
119−
120−(!%), (?%) :: IsoXmlDescRecord -> IsoXmlDescPreAttribute -> IsoXmlDescRecord
121−(!%) = appendAttribute XmlAttributePluralMandatory
122−(?%) = appendAttribute XmlAttributePluralOptional
123−
124−(^) :: IsoXmlDescRecord -> IsoXmlDescPreContent -> IsoXmlDescRecord
125−(^) = appendContent
126−
127−infixl 2 !
128−infixl 2 ?
129−infixl 2 *
130−infixl 2 +
131−infixl 2 !%
132−infixl 2 ?%
133−infixl 2 ^
134−
135−appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
136−appendEnumCon (IsoXmlDescEnum genType enumCons) xenumcon =
137− IsoXmlDescEnum genType (xenumcon:enumCons)
138−
139−(&) :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
140−(&) = appendEnumCon
141−
142−infixl 2 &
143−
144−class Description name desc | desc -> name where
145− (=:=) :: name -> desc -> TH.DecsQ
146−
147−infix 0 =:=
148−
149−instance Description PrefixName IsoXmlDescRecord where
150− prefixName =:= (IsoXmlDescRecord genType descRecordParts) =
151− isoXmlGenerateDatatype genType prefixName (reverse descRecordParts)
152−
153−record :: GenType -> IsoXmlDescRecord
154−record gt = IsoXmlDescRecord gt []
155−
156−enum :: GenType -> IsoXmlDescEnum
157−enum gt = IsoXmlDescEnum gt []
158−
159−instance Description ExhaustivenessName IsoXmlDescEnum where
160− exhaustivenessName =:= (IsoXmlDescEnum genType descEnumCons) =
161− isoXmlGenerateEnum genType exhaustivenessName (reverse descEnumCons)
162−
163−instance (m ~ Q) => IsString (m TH.Type -> IsoXmlDescPreField) where
164− fromString = IsoXmlDescPreField
165−
166−instance IsString IsoXmlDescPreField where
167− fromString name = IsoXmlDescPreField name ty
168− where
169− ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper (xmlLocalName name))
170−
171−instance (m ~ Q) => IsString (m TH.Type -> IsoXmlDescPreAttribute) where
172− fromString = IsoXmlDescPreAttribute
173−
174−instance (m ~ Q) => IsString (m Type -> IsoXmlDescPreContent) where
175− fromString = IsoXmlDescPreContent
176−
177−instance IsString IsoXmlDescPreAttribute where
178− fromString name = IsoXmlDescPreAttribute name ty
179− where
180− ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)
181−
182−instance IsString IsoXmlDescPreContent where
183− fromString name = IsoXmlDescPreContent name ty
184− where
185− ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)
186−
187−instance s ~ String => IsString (s -> PrefixName) where
188− fromString = PrefixName
189−
190−instance IsString PrefixName where
191− fromString strName = PrefixName strName (makeNamePrefix strName)
192−
193−instance e ~ Exhaustiveness => IsString (e -> ExhaustivenessName) where
194− fromString = ExhaustivenessName
195−
196−instance IsString ExhaustivenessName where
197− fromString strName = ExhaustivenessName strName NonExhaustive
198−
199−makeNamePrefix :: String -> String
200−makeNamePrefix = map C.toLower . filter (\c -> C.isUpper c || C.isDigit c)
201−
202−funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ
203−funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]
204−
205−isoXmlGenerateEnum
206− :: GenType
207− -> ExhaustivenessName
208− -> [IsoXmlDescEnumCon]
209− -> TH.DecsQ
210−isoXmlGenerateEnum genType (ExhaustivenessName strName' exh) enumCons = do
211− let
212− strName = "Xml" ++ strName'
213− strVals = map unIsoXmlDescEnumCon enumCons
214− enumDesc = EnumDesc exh strName strVals
215− name = TH.mkName strName
216− enumDecls <- enumGenerate enumDesc
217− let
218− genToXmlInst = do
219− TH.instanceD
220− (return [])
221− [t|XW.ToXML $(TH.conT name)|]
222− [funSimple 'XW.toXML [e|XW.toXML . T.pack . show|]]
223− genToXmlAttributeInst = do
224− TH.instanceD
225− (return [])
226− [t|ToXmlAttribute $(TH.conT name)|]
227− [funSimple 'toXmlAttribute [e|T.pack . show|]]
228− genFromDomInst mode = do
229− TH.instanceD
230− (return [])
231− [t|FromDom $(TH.conT name)|]
232− [case mode of
233− Strict -> funSimple 'fromDom [e|parseContent readContent|]
234− Lenient -> funSimple 'fromDom [e|ignoreBlank $ parseContent readContent|]
235− ]
236− genFromAttributeInst = do
237− TH.instanceD
238− (return [])
239− [t|FromAttribute $(TH.conT name)|]
240− [funSimple 'fromAttribute [e|readContent|]]
241− case genType of
242− Generator -> do
243− toXmlInst <- genToXmlInst
244− toXmlAttributeInst <- genToXmlAttributeInst
245− return $ enumDecls ++ [toXmlInst, toXmlAttributeInst]
246− Parser -> do
247− fromDomInst <- genFromDomInst Strict
248− fromAttributeInst <- genFromAttributeInst
249− return $ enumDecls ++ [fromDomInst, fromAttributeInst]
250− LenientParser -> do
251− fromDomInst <- genFromDomInst Lenient
252− fromAttributeInst <- genFromAttributeInst
253− return $ enumDecls ++ [fromDomInst, fromAttributeInst]
254− ParserAndGenerator -> do
255− toXmlInst <- genToXmlInst
256− toXmlAttributeInst <- genToXmlAttributeInst
257− fromDomInst <- genFromDomInst Strict
258− fromAttributeInst <- genFromAttributeInst
259− return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
260− fromDomInst, fromAttributeInst]
261− LenientParserAndGenerator -> do
262− toXmlInst <- genToXmlInst
263− toXmlAttributeInst <- genToXmlAttributeInst
264− fromDomInst <- genFromDomInst Lenient
265− fromAttributeInst <- genFromAttributeInst
266− return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
267− fromDomInst, fromAttributeInst]
268−
269−isoXmlGenerateDatatype :: GenType -> PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ
270−isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts = do
271− let
272− isNewtype = length descRecordParts == 1
273− strName = "Xml" ++ strName'
274− strPrefix = "x" ++ strPrefix'
275− name = TH.mkName strName
276− fieldName str = "_" ++ strPrefix ++ over _head C.toUpper str
277− termDecl <- do
278− let
279− fields = do
280− descRecordPart <- descRecordParts
281− return $ case descRecordPart of
282− IsoXmlDescRecordField descField ->
283− let
284− IsoXmlDescField fieldPlural rawName fieldType = descField
285− fieldStrName = xmlLocalName rawName
286− fName = TH.mkName (fieldName fieldStrName)
287− fType' = case fieldPlural of
288− XmlFieldPluralMandatory -> fieldType
289− XmlFieldPluralOptional -> [t| Maybe $fieldType |]
290− XmlFieldPluralRepeated -> [t| [$fieldType] |]
291− XmlFieldPluralMultiplied -> [t| NonEmpty $fieldType |]
292− fType = if isLenientType genType
293− then [t| Maybe $fType' |]
294− else fType'
295− in if isNewtype
296− then THC.varStrictType fName (THC.nonStrictType fType)
297− else THC.varStrictType fName (THC.strictType fType)
298− IsoXmlDescRecordAttribute descAttribute ->
299− let
300− IsoXmlDescAttribute
301− attributePlural attributeStrName attributeType = descAttribute
302− fName = TH.mkName (fieldName attributeStrName)
303− fType = case attributePlural of
304− XmlAttributePluralMandatory -> attributeType
305− XmlAttributePluralOptional -> [t| Maybe $attributeType |]
306− in if isNewtype
307− then THC.varStrictType fName (THC.nonStrictType fType)
308− else THC.varStrictType fName (THC.strictType fType)
309− IsoXmlDescRecordContent descContent ->
310− let
311− IsoXmlDescContent contentStrName contentType = descContent
312− fName = TH.mkName (fieldName contentStrName)
313− fType = contentType
314− in if isNewtype
315− then THC.varStrictType fName (THC.nonStrictType fType)
316− else THC.varStrictType fName (THC.strictType fType)
317− if isNewtype
318− -- generate a newtype instead to do less allocations later
319− then THC.newtypeD name (TH.recC name fields) [''Eq, ''Show, ''Generic]
320− else THC.dataD name [TH.recC name fields] [''Eq, ''Show, ''Generic]
321− lensDecls <- makeFieldOpticsForDec lensRules termDecl
322− nfDataInst <- do
323− TH.instanceD
324− (return [])
325− [t|NFData $(TH.conT name)|]
326− [ ]
327−
328− let
329− genFromDomInst mode = do
330− let
331− exprHeader = [e|pure $(TH.conE name)|]
332− exprRecordParts = do
333− descRecordPart <- descRecordParts
334− return $ case descRecordPart of
335− IsoXmlDescRecordField descField ->
336− let
337− IsoXmlDescField fieldPlural rawName _ = descField
338− fieldStrName = xmlLocalName rawName
339− exprFieldStrName = TH.litE (TH.stringL fieldStrName)
340− fieldParse = case fieldPlural of
341− XmlFieldPluralMandatory -> [e|inElem|]
342− _ -> [e|inElemTrav|]
343− in case mode of
344− Strict -> [e|$fieldParse $exprFieldStrName fromDom|]
345− Lenient -> [e|$fieldParse $exprFieldStrName (ignoreBlank fromDom)|]
346− IsoXmlDescRecordAttribute descAttribute ->
347− let
348− IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute
349− exprAttributeStrName = TH.litE (TH.stringL attributeStrName)
350− attributeParse = case attributePlural of
351− XmlAttributePluralMandatory -> [e|parseAttribute|]
352− XmlAttributePluralOptional -> [e|parseAttributeMaybe|]
353− in
354− [e|$attributeParse $exprAttributeStrName fromAttribute|]
355− IsoXmlDescRecordContent _ -> [e|parseContent fromAttribute|]
356− fromDomExpr = foldl (\e fe -> [e| $e <*> $fe |]) exprHeader exprRecordParts
357− TH.instanceD
358− (return [])
359− [t|FromDom $(TH.conT name)|]
360− [ funSimple 'fromDom fromDomExpr ]
361−
362− genToXmlInst = do
363− objName <- TH.newName strPrefix
364− let
365− exprFields = do
366− descRecordPart <- descRecordParts
367− case descRecordPart of
368− IsoXmlDescRecordField (IsoXmlDescField fieldPlural rawName _) -> do
369− let
370− fieldStrName = xmlLocalName rawName
371− fName = TH.mkName (fieldName fieldStrName)
372− exprFieldStrName = TH.litE (TH.stringL rawName)
373− exprForField = case fieldPlural of
374− XmlFieldPluralMandatory -> [e|id|]
375− _ -> [e|traverse|]
376− exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
377− exprFieldRender =
378− [e|(\a ->
379− XW.elementA $exprFieldStrName (toXmlParentAttributes a) a)|]
380− return [e|$exprForField $exprFieldRender $exprFieldValue|]
381− IsoXmlDescRecordContent (IsoXmlDescContent rawName _) -> do
382− let
383− fieldStrName = xmlLocalName rawName
384− fName = TH.mkName (fieldName fieldStrName)
385− exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
386− return [e|XW.content . toXmlAttribute $ $exprFieldValue|]
387− _ -> []
388− toXmlExpr
389− = TH.lamE [if null exprFields then TH.wildP else TH.varP objName]
390− $ foldr (\fe e -> [e|$fe *> $e|]) [e|return ()|] exprFields
391− TH.instanceD
392− (return [])
393− [t|XW.ToXML $(TH.conT name)|]
394− [funSimple 'XW.toXML toXmlExpr]
395− genToXmlParentAttributeInst = do
396− objName <- TH.newName strPrefix
397− let
398− exprAttributes = do
399− descRecordPart <- descRecordParts
400− IsoXmlDescAttribute attributePlural attributeStrName _ <-
401− maybeToList $ case descRecordPart of
402− IsoXmlDescRecordAttribute descAttribute -> Just descAttribute
403− _ -> Nothing
404− let
405− fName = TH.mkName (fieldName attributeStrName)
406− exprAttrStrName = TH.litE (TH.stringL attributeStrName)
407− exprAttrValue = [e|$(TH.varE fName) $(TH.varE objName)|]
408− exprAttrWrap = case attributePlural of
409− XmlAttributePluralMandatory -> [e|Just . toXmlAttribute|]
410− XmlAttributePluralOptional -> [e|fmap toXmlAttribute|]
411− return [e|($exprAttrStrName, $exprAttrWrap $exprAttrValue)|]
412− toXmlParentAttributesExpr
413− = TH.lamE [if null exprAttributes then TH.wildP else TH.varP objName]
414− $ [e|mapMaybe distribPair $(TH.listE exprAttributes)|]
415−#if __GLASGOW_HASKELL__ < 800
416− TH.instanceD
417−#else
418− TH.instanceWithOverlapD (Just TH.Overlapping)
419−#endif
420− (return [])
421− [t|ToXmlParentAttributes $(TH.conT name)|]
422− [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]
423−
424− case genType of
425− Generator -> do
426− toXmlInst <- genToXmlInst
427− toXmlParentAttributesInst <- genToXmlParentAttributeInst
428− return $ [termDecl] ++ lensDecls ++
429− [toXmlInst, toXmlParentAttributesInst, nfDataInst]
430− Parser -> do
431− fromDomInst <- genFromDomInst Strict
432− return $ [termDecl] ++ lensDecls ++ [fromDomInst, nfDataInst]
433− LenientParser -> do
434− fromDomInst <- genFromDomInst Lenient
435− return $ [termDecl] ++ lensDecls ++ [fromDomInst, nfDataInst]
436− ParserAndGenerator -> do
437− toXmlInst <- genToXmlInst
438− toXmlParentAttributesInst <- genToXmlParentAttributeInst
439− fromDomInst <- genFromDomInst Strict
440− return $ [termDecl] ++ lensDecls ++
441− [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]
442− LenientParserAndGenerator -> do
443− toXmlInst <- genToXmlInst
444− toXmlParentAttributesInst <- genToXmlParentAttributeInst
445− fromDomInst <- genFromDomInst Lenient
446− return $ [termDecl] ++ lensDecls ++
447− [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]
448−
449−distribPair :: Functor f => (a, f b) -> f (a, b)
450−distribPair (a, fb) = (a,) <$> fb
451−
452−-- | Get a local part of (possibly) fully qualified 'X.Name':
453−--
454−-- >>> xmlLocalName "{http://example.com/ns/my-namespace}my-name"
455−-- "my-name"
456−xmlLocalName :: String -> String
457−xmlLocalName = T.unpack . X.nameLocalName . fromString