@@ -1,10 +1,26 @@
1+{-# LANGUAGE UndecidableInstances #-}
2+{-# LANGUAGE FunctionalDependencies #-}
3+
14module Data.THGen.XML.Internal where
25
3−import Control.Lens
4−import Data.String
5−import Data.THGen.Compat
6−import Data.THGen.Enum
7−import Language.Haskell.TH as TH
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)
12+import Data.String
13+import Data.THGen.Compat as THC
14+import Data.THGen.Enum
15+import qualified Data.Text as T
16+import GHC.Generics (Generic)
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
824
925
1026data XmlFieldPlural
@@ -51,3 +67,317 @@ instance IsString IsoXmlDescEnumCon where
5167data IsoXmlDescEnum = IsoXmlDescEnum [IsoXmlDescEnumCon]
5268
5369makePrisms ''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