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