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