@@ -0,0 +1,416 @@
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