@@ -114,6 +114,7 @@ module Data.THGen.XML
114114 , (!%)
115115 , (?%)
116116 , (&)
117+ , (^)
117118 , (=:=)
118119 -- Re-exports
119120 , T.Text
@@ -133,12 +134,12 @@ import Data.THGen.Enum
133134import qualified Data.Text as T
134135import GHC.Generics (Generic)
135136import qualified Language.Haskell.TH as TH
136−import qualified Language.Haskell.TH.Syntax as TH
137−import Prelude hiding ((+), (*))
137+import Prelude hiding ((+), (*), (^))
138138import qualified Text.XML as X
139−import Text.XML.DOM.Parser
139+import Text.XML.DOM.Parser hiding (parseContent)
140140import Text.XML.ParentAttributes
141141import qualified Text.XML.Writer as XW
142+import Text.XML.DOM.Parser.Internal.Content
142143
143144
144145data XmlFieldPlural
@@ -157,13 +158,18 @@ data IsoXmlDescPreField = IsoXmlDescPreField String TH.TypeQ
157158
158159data IsoXmlDescPreAttribute = IsoXmlDescPreAttribute String TH.TypeQ
159160
161+data IsoXmlDescPreContent = IsoXmlDescPreContent String TH.TypeQ
162+
160163data IsoXmlDescField = IsoXmlDescField XmlFieldPlural String TH.TypeQ
161164
162165data IsoXmlDescAttribute = IsoXmlDescAttribute XmlAttributePlural String TH.TypeQ
163166
167+data IsoXmlDescContent = IsoXmlDescContent String TH.TypeQ
168+
164169data IsoXmlDescRecordPart
165170 = IsoXmlDescRecordField IsoXmlDescField
166171 | IsoXmlDescRecordAttribute IsoXmlDescAttribute
172+ | IsoXmlDescRecordContent IsoXmlDescContent
167173
168174newtype IsoXmlDescRecord = IsoXmlDescRecord [IsoXmlDescRecordPart]
169175
@@ -199,6 +205,14 @@ appendAttribute plural xrec (IsoXmlDescPreAttribute name ty) =
199205 let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty
200206 in over _IsoXmlDescRecord (xattribute:) xrec
201207
208+appendContent
209+ :: IsoXmlDescRecord
210+ -> IsoXmlDescPreContent
211+ -> IsoXmlDescRecord
212+appendContent xrec (IsoXmlDescPreContent name ty) =
213+ let xcontent = IsoXmlDescRecordContent $ IsoXmlDescContent name ty
214+ in over _IsoXmlDescRecord (xcontent:) xrec
215+
202216(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
203217(!) = appendField XmlFieldPluralMandatory
204218(?) = appendField XmlFieldPluralOptional
@@ -209,12 +223,16 @@ appendAttribute plural xrec (IsoXmlDescPreAttribute name ty) =
209223(!%) = appendAttribute XmlAttributePluralMandatory
210224(?%) = appendAttribute XmlAttributePluralOptional
211225
226+(^) :: IsoXmlDescRecord -> IsoXmlDescPreContent -> IsoXmlDescRecord
227+(^) = appendContent
228+
212229infixl 2 !
213230infixl 2 ?
214231infixl 2 *
215232infixl 2 +
216233infixl 2 !%
217234infixl 2 ?%
235+infixl 2 ^
218236
219237appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
220238appendEnumCon xenum xenumcon =
@@ -257,11 +275,19 @@ instance IsString IsoXmlDescPreField where
257275instance IsString (TH.TypeQ -> IsoXmlDescPreAttribute) where
258276 fromString = IsoXmlDescPreAttribute
259277
278+instance IsString (TH.TypeQ -> IsoXmlDescPreContent) where
279+ fromString = IsoXmlDescPreContent
280+
260281instance IsString IsoXmlDescPreAttribute where
261282 fromString name = IsoXmlDescPreAttribute name ty
262283 where
263284 ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)
264285
286+instance IsString IsoXmlDescPreContent where
287+ fromString name = IsoXmlDescPreContent name ty
288+ where
289+ ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)
290+
265291instance s ~ String => IsString (s -> PrefixName) where
266292 fromString = PrefixName
267293
@@ -349,6 +375,14 @@ isoXmlGenerateDatatype (PrefixName strName' strPrefix') descRecordParts = do
349375 in if isNewtype
350376 then varStrictType fName (nonStrictType fType)
351377 else varStrictType fName (strictType fType)
378+ IsoXmlDescRecordContent descContent ->
379+ let
380+ IsoXmlDescContent contentStrName contentType = descContent
381+ fName = TH.mkName (fieldName contentStrName)
382+ fType = contentType
383+ in if isNewtype
384+ then varStrictType fName (nonStrictType fType)
385+ else varStrictType fName (strictType fType)
352386 if isNewtype
353387 -- generate a newtype instead to do less allocations later
354388 then newtypeD name (TH.recC name fields) [''Eq, ''Show, ''Generic]
@@ -384,6 +418,7 @@ isoXmlGenerateDatatype (PrefixName strName' strPrefix') descRecordParts = do
384418 XmlAttributePluralOptional -> [e|parseAttributeMaybe|]
385419 in
386420 [e|$attributeParse $exprAttributeStrName fromAttribute|]
421+ IsoXmlDescRecordContent _ -> [e|parseContent fromAttribute|]
387422 fromDomExpr = foldl (\e fe -> [e| $e <*> $fe |]) exprHeader exprRecordParts
388423 TH.instanceD
389424 (return [])
@@ -395,21 +430,27 @@ isoXmlGenerateDatatype (PrefixName strName' strPrefix') descRecordParts = do
395430 let
396431 exprFields = do
397432 descRecordPart <- descRecordParts
398− IsoXmlDescField fieldPlural rawName _ <-
399− maybeToList $ case descRecordPart of
400− IsoXmlDescRecordField descField -> Just descField
401− _ -> Nothing
402− let
403− fieldStrName = xmlLocalName rawName
404− fName = TH.mkName (fieldName fieldStrName)
405− exprFieldStrName = TH.litE (TH.stringL rawName)
406− exprForField = case fieldPlural of
407− XmlFieldPluralMandatory -> [e|id|]
408− _ -> [e|traverse|]
409− exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
410− exprFieldRender =
411− [e|(\a -> XW.elementA $exprFieldStrName (toXmlParentAttributes a) a)|]
412− return [e|$exprForField $exprFieldRender $exprFieldValue|]
433+ case descRecordPart of
434+ IsoXmlDescRecordField (IsoXmlDescField fieldPlural rawName _) -> do
435+ let
436+ fieldStrName = xmlLocalName rawName
437+ fName = TH.mkName (fieldName fieldStrName)
438+ exprFieldStrName = TH.litE (TH.stringL rawName)
439+ exprForField = case fieldPlural of
440+ XmlFieldPluralMandatory -> [e|id|]
441+ _ -> [e|traverse|]
442+ exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
443+ exprFieldRender =
444+ [e|(\a ->
445+ XW.elementA $exprFieldStrName (toXmlParentAttributes a) a)|]
446+ return [e|$exprForField $exprFieldRender $exprFieldValue|]
447+ IsoXmlDescRecordContent (IsoXmlDescContent rawName _) -> do
448+ let
449+ fieldStrName = xmlLocalName rawName
450+ fName = TH.mkName (fieldName fieldStrName)
451+ exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
452+ return [e|XW.content . toXmlAttribute $ $exprFieldValue|]
453+ _ -> []
413454 toXmlExpr
414455 = TH.lamE [if null exprFields then TH.wildP else TH.varP objName]
415456 $ foldr (\fe e -> [e|$fe *> $e|]) [e|return ()|] exprFields