git.iko.soy/typeable/xml-isogen
on master help sign in
Parent attribute support
commit9b3683c8d343001d2ec55810234c652dfeff0af2 authorVladislav Zavialov <vlad.z.4096@gmail.com> dateFri 23 Dec 2016, 15:51 (10 years ago) parent578de23
7 files changed+263−45
compare with master
unifiedsplit
.gitignore+5 src/Data/THGen/XML.hs+150−44 src/Text/XML/ParentAttributes.hs+53 stack.yaml+9 test/Main.hs+6 test/TestDefs.hs+27 xml-isogen.cabal+13−1
.gitignorenew file+5
@@ -0,0 +1,5 @@
1+tags
2+dist
3+.stack-work
4+.cabal-sandbox/
5+cabal.sandbox.config
src/Data/THGen/XML.hs+150−44
@@ -111,6 +111,8 @@ module Data.THGen.XML
111111 , (?)
112112 , (*)
113113 , (+)
114+ , (!%)
115+ , (?%)
114116 , (&)
115117 , (=:=)
116118 -- Re-exports
@@ -123,13 +125,16 @@ import Control.Lens hiding (repeated, enum, (&))
123125import Control.Lens.Internal.FieldTH (makeFieldOpticsForDec)
124126import qualified Data.Char as C
125127import Data.List.NonEmpty (NonEmpty)
128+import Data.Maybe (maybeToList, mapMaybe)
126129import Data.String
127130import Data.THGen.Enum
128131import qualified Data.Text as T
129132import qualified Language.Haskell.TH as TH
130133import Prelude hiding ((+), (*))
131134import Text.XML.DOM.Parser
135+import Text.XML.ParentAttributes
132136import qualified Text.XML.Writer as XW
137+import qualified Text.XML as X
133138
134139data XmlFieldPlural
135140 = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
@@ -137,13 +142,25 @@ data XmlFieldPlural
137142 | XmlFieldPluralRepeated -- Occurs 0 or more times (List)
138143 | XmlFieldPluralMultiplied -- Occurs 1 or more times (NonEmpty)
139144
145+data XmlAttributePlural
146+ = XmlAttributePluralMandatory -- Occurs exactly 1 time (Identity)
147+ | XmlAttributePluralOptional -- Occurs 0 or 1 times (Maybe)
148+
140149data PrefixName = PrefixName String String
141150
142151data IsoXmlDescPreField = IsoXmlDescPreField String TH.TypeQ
143152
153+data IsoXmlDescPreAttribute = IsoXmlDescPreAttribute String TH.TypeQ
154+
144155data IsoXmlDescField = IsoXmlDescField XmlFieldPlural String TH.TypeQ
145156
146−data IsoXmlDescRecord = IsoXmlDescRecord [IsoXmlDescField]
157+data IsoXmlDescAttribute = IsoXmlDescAttribute XmlAttributePlural String TH.TypeQ
158+
159+data IsoXmlDescRecordPart
160+ = IsoXmlDescRecordField IsoXmlDescField
161+ | IsoXmlDescRecordAttribute IsoXmlDescAttribute
162+
163+newtype IsoXmlDescRecord = IsoXmlDescRecord [IsoXmlDescRecordPart]
147164
148165makePrisms ''IsoXmlDescRecord
149166
@@ -165,25 +182,34 @@ appendField
165182 -> IsoXmlDescPreField
166183 -> IsoXmlDescRecord
167184appendField plural xrec (IsoXmlDescPreField name ty) =
168− let xfield = IsoXmlDescField plural name ty
185+ let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty
169186 in over _IsoXmlDescRecord (xfield:) xrec
170187
171−(!) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
172−(!) = appendField XmlFieldPluralMandatory
188+appendAttribute
189+ :: XmlAttributePlural
190+ -> IsoXmlDescRecord
191+ -> IsoXmlDescPreAttribute
192+ -> IsoXmlDescRecord
193+appendAttribute plural xrec (IsoXmlDescPreAttribute name ty) =
194+ let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty
195+ in over _IsoXmlDescRecord (xattribute:) xrec
173196
174−(?) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
197+(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
198+(!) = appendField XmlFieldPluralMandatory
175199(?) = appendField XmlFieldPluralOptional
176−
177−(*) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
178200(*) = appendField XmlFieldPluralRepeated
179−
180−(+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
181201(+) = appendField XmlFieldPluralMultiplied
182202
203+(!%), (?%) :: IsoXmlDescRecord -> IsoXmlDescPreAttribute -> IsoXmlDescRecord
204+(!%) = appendAttribute XmlAttributePluralMandatory
205+(?%) = appendAttribute XmlAttributePluralOptional
206+
183207infixl 2 !
184208infixl 2 ?
185209infixl 2 *
186210infixl 2 +
211+infixl 2 !%
212+infixl 2 ?%
187213
188214appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum
189215appendEnumCon xenum xenumcon =
@@ -201,8 +227,8 @@ infix 0 =:=
201227
202228instance Description PrefixName IsoXmlDescRecord where
203229 prefixName =:= descRecord =
204− let descFields = descRecord ^. _IsoXmlDescRecord
205− in isoXmlGenerateRecord prefixName (reverse descFields)
230+ let descRecordParts = descRecord ^. _IsoXmlDescRecord
231+ in isoXmlGenerateRecord prefixName (reverse descRecordParts)
206232
207233record :: IsoXmlDescRecord
208234record = IsoXmlDescRecord []
@@ -223,6 +249,14 @@ instance IsString IsoXmlDescPreField where
223249 where
224250 ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)
225251
252+instance IsString (TH.TypeQ -> IsoXmlDescPreAttribute) where
253+ fromString = IsoXmlDescPreAttribute
254+
255+instance IsString IsoXmlDescPreAttribute where
256+ fromString name = IsoXmlDescPreAttribute name ty
257+ where
258+ ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)
259+
226260instance s ~ String => IsString (s -> PrefixName) where
227261 fromString = PrefixName
228262
@@ -251,20 +285,30 @@ isoXmlGenerateEnum (ExhaustivenessName strName' exh) enumCons = do
251285 name = TH.mkName strName
252286 enumDecls <- enumGenerate enumDesc
253287 toXmlInst <- do
254− let toXmlExpr = [e|XW.toXML . T.pack . show|]
255288 TH.instanceD
256289 (return [])
257290 [t|XW.ToXML $(TH.conT name)|]
258− [funSimple 'XW.toXML toXmlExpr]
291+ [funSimple 'XW.toXML [e|XW.toXML . T.pack . show|]]
292+ toXmlAttributeInst <- do
293+ TH.instanceD
294+ (return [])
295+ [t|ToXmlAttribute $(TH.conT name)|]
296+ [funSimple 'toXmlAttribute [e|T.pack . show|]]
259297 fromDomInst <- do
260298 TH.instanceD
261299 (return [])
262300 [t|FromDom $(TH.conT name)|]
263− [ funSimple 'fromDom [e|parseContent readContent|] ]
264− return (enumDecls ++ [toXmlInst, fromDomInst])
301+ [funSimple 'fromDom [e|parseContent readContent|]]
302+ fromAttributeInst <- do
303+ TH.instanceD
304+ (return [])
305+ [t|FromAttribute $(TH.conT name)|]
306+ [funSimple 'fromAttribute [e|readContent|]]
307+ return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
308+ fromDomInst, fromAttributeInst]
265309
266−isoXmlGenerateRecord :: PrefixName -> [IsoXmlDescField] -> TH.DecsQ
267−isoXmlGenerateRecord (PrefixName strName' strPrefix') descFields = do
310+isoXmlGenerateRecord :: PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ
311+isoXmlGenerateRecord (PrefixName strName' strPrefix') descRecordParts = do
268312 let
269313 strName = "Xml" ++ strName'
270314 strPrefix = "x" ++ strPrefix'
@@ -272,35 +316,62 @@ isoXmlGenerateRecord (PrefixName strName' strPrefix') descFields = do
272316 fieldName str = "_" ++ strPrefix ++ over _head C.toUpper str
273317 dataDecl <- do
274318 let
275− constructors = do
276− IsoXmlDescField fieldPlural fieldStrName fieldType <- descFields
277− let
278− fName = TH.mkName (fieldName fieldStrName)
279− fType = case fieldPlural of
280− XmlFieldPluralMandatory -> fieldType
281− XmlFieldPluralOptional -> [t| Maybe $fieldType |]
282− XmlFieldPluralRepeated -> [t| [$fieldType] |]
283− XmlFieldPluralMultiplied -> [t| NonEmpty $fieldType |]
284− return $ TH.varStrictType fName (TH.strictType TH.isStrict fType)
319+ fields = do
320+ descRecordPart <- descRecordParts
321+ return $ case descRecordPart of
322+ IsoXmlDescRecordField descField ->
323+ let
324+ IsoXmlDescField fieldPlural fieldStrName fieldType = descField
325+ fName = TH.mkName (fieldName fieldStrName)
326+ fType = case fieldPlural of
327+ XmlFieldPluralMandatory -> fieldType
328+ XmlFieldPluralOptional -> [t| Maybe $fieldType |]
329+ XmlFieldPluralRepeated -> [t| [$fieldType] |]
330+ XmlFieldPluralMultiplied -> [t| NonEmpty $fieldType |]
331+ in
332+ TH.varStrictType fName (TH.strictType TH.isStrict fType)
333+ IsoXmlDescRecordAttribute descAttribute ->
334+ let
335+ IsoXmlDescAttribute
336+ attributePlural attributeStrName attributeType = descAttribute
337+ fName = TH.mkName (fieldName attributeStrName)
338+ fType = case attributePlural of
339+ XmlAttributePluralMandatory -> attributeType
340+ XmlAttributePluralOptional -> [t| Maybe $attributeType |]
341+ in
342+ TH.varStrictType fName (TH.strictType TH.isStrict fType)
285343 TH.dataD
286344 (return [])
287345 name
288346 []
289− [TH.recC name constructors]
347+ [TH.recC name fields]
290348 [''Eq, ''Show]
291349 lensDecls <- makeFieldOpticsForDec lensRules dataDecl
292350 fromDomInst <- do
293351 let
294− exprHeader = [e|pure $(TH.conE name)|]
295− exprFields = do
296− IsoXmlDescField fieldPlural fieldStrName _ <- descFields
297− let
298− exprFieldStrName = TH.litE (TH.stringL fieldStrName)
299− fieldParse = case fieldPlural of
300− XmlFieldPluralMandatory -> [e|inElem|]
301− _ -> [e|inElemTrav|]
302− return [e|$fieldParse $exprFieldStrName fromDom|]
303− fromDomExpr = foldl (\e fe -> [e| $e <*> $fe |]) exprHeader exprFields
352+ exprHeader = [e|pure $(TH.conE name)|]
353+ exprRecordParts = do
354+ descRecordPart <- descRecordParts
355+ return $ case descRecordPart of
356+ IsoXmlDescRecordField descField ->
357+ let
358+ IsoXmlDescField fieldPlural fieldStrName _ = descField
359+ exprFieldStrName = TH.litE (TH.stringL fieldStrName)
360+ fieldParse = case fieldPlural of
361+ XmlFieldPluralMandatory -> [e|inElem|]
362+ _ -> [e|inElemTrav|]
363+ in
364+ [e|$fieldParse $exprFieldStrName fromDom|]
365+ IsoXmlDescRecordAttribute descAttribute ->
366+ let
367+ IsoXmlDescAttribute attributePlural attributeStrName _ = descAttribute
368+ exprAttributeStrName = TH.litE (TH.stringL attributeStrName)
369+ attributeParse = case attributePlural of
370+ XmlAttributePluralMandatory -> [e|parseAttribute|]
371+ XmlAttributePluralOptional -> [e|parseAttributeMaybe|]
372+ in
373+ [e|$attributeParse $exprAttributeStrName fromAttribute|]
374+ fromDomExpr = foldl (\e fe -> [e| $e <*> $fe |]) exprHeader exprRecordParts
304375 TH.instanceD
305376 (return [])
306377 [t|FromDom $(TH.conT name)|]
@@ -309,24 +380,59 @@ isoXmlGenerateRecord (PrefixName strName' strPrefix') descFields = do
309380 toXmlInst <- do
310381 objName <- TH.newName strPrefix
311382 let
312− exprFooter = [e|return ()|]
313383 exprFields = do
314− IsoXmlDescField fieldPlural fieldStrName _ <- descFields
384+ descRecordPart <- descRecordParts
385+ IsoXmlDescField fieldPlural fieldStrName _ <-
386+ maybeToList $ case descRecordPart of
387+ IsoXmlDescRecordField descField -> Just descField
388+ _ -> Nothing
315389 let
316− fieldRender = [e|XW.toXML|]
317390 fName = TH.mkName (fieldName fieldStrName)
318391 exprFieldStrName = TH.litE (TH.stringL fieldStrName)
319392 exprForField = case fieldPlural of
320393 XmlFieldPluralMandatory -> [e|id|]
321394 _ -> [e|traverse|]
322395 exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]
323− exprFieldRender = [e|XW.element $exprFieldStrName . $fieldRender|]
396+ exprFieldRender = [e|mkElement $exprFieldStrName|]
324397 return [e|$exprForField $exprFieldRender $exprFieldValue|]
325398 toXmlExpr
326399 = TH.lamE [if null exprFields then TH.wildP else TH.varP objName]
327− $ foldr (\fe e -> [e|$fe *> $e|]) exprFooter exprFields
400+ $ foldr (\fe e -> [e|$fe *> $e|]) [e|return ()|] exprFields
328401 TH.instanceD
329402 (return [])
330403 [t|XW.ToXML $(TH.conT name)|]
331404 [funSimple 'XW.toXML toXmlExpr]
332− return $ [dataDecl] ++ lensDecls ++ [fromDomInst, toXmlInst]
405+
406+ toXmlParentAttributesInst <- do
407+ objName <- TH.newName strPrefix
408+ let
409+ exprAttributes = do
410+ descRecordPart <- descRecordParts
411+ IsoXmlDescAttribute attributePlural attributeStrName _ <-
412+ maybeToList $ case descRecordPart of
413+ IsoXmlDescRecordAttribute descAttribute -> Just descAttribute
414+ _ -> Nothing
415+ let
416+ fName = TH.mkName (fieldName attributeStrName)
417+ exprAttrStrName = TH.litE (TH.stringL attributeStrName)
418+ exprAttrValue = [e|$(TH.varE fName) $(TH.varE objName)|]
419+ exprAttrWrap = case attributePlural of
420+ XmlAttributePluralMandatory -> [e|Just . toXmlAttribute|]
421+ XmlAttributePluralOptional -> [e|fmap toXmlAttribute|]
422+ return [e|($exprAttrStrName, $exprAttrWrap $exprAttrValue)|]
423+ toXmlParentAttributesExpr
424+ = TH.lamE [if null exprAttributes then TH.wildP else TH.varP objName]
425+ $ [e|mapMaybe distribPair $(TH.listE exprAttributes)|]
426+ TH.instanceD
427+ (return [])
428+ [t|ToXmlParentAttributes $(TH.conT name)|]
429+ [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]
430+
431+ return $ [dataDecl] ++ lensDecls ++
432+ [fromDomInst, toXmlInst, toXmlParentAttributesInst]
433+
434+mkElement :: (XW.ToXML a, ToXmlParentAttributes a) => X.Name -> a -> XW.XML
435+mkElement name a = XW.elementA name (toXmlParentAttributes a) (XW.toXML a)
436+
437+distribPair :: Functor f => (a, f b) -> f (a, b)
438+distribPair (a, fb) = (a,) <$> fb
src/Text/XML/ParentAttributes.hsnew file+53
@@ -0,0 +1,53 @@
1+module Text.XML.ParentAttributes
2+ ( ToXmlParentAttributes(..)
3+ , ToXmlAttribute(..)
4+ , toXmlAttributeIntegral
5+ ) where
6+
7+import Data.Text as T.S
8+import Data.Text.Lazy as T.L
9+import Data.Text.Lazy.Builder as T.L
10+import Data.Text.Lazy.Builder.Int as T.L
11+import Numeric.Natural
12+import Text.XML
13+
14+class ToXmlParentAttributes a where
15+ toXmlParentAttributes :: a -> [(Name, T.S.Text)]
16+
17+-- | A catch-all instance: by default objects don't have parent attributes.
18+-- The alternative solution is to write a default implementation in the class,
19+-- but it has a drawback that it requires numerous (boilerplate) empty
20+-- instances - one for each type that doesn't have parent attributes (most
21+-- types). This overlappable instance gets overriden for XML records
22+-- (described in "Data.THGen.XML") because they can store parent attributes
23+-- added via the @!%@ and @?%@ operators.
24+-- For example, `toXmlParentAttributes` applied to a `Text` or `Integer' value
25+-- returns @[]@ because of this instance. However, an XML record defined as
26+-- @"Foo" =:= record !% "bar"@ will have its own TH-generated
27+-- `ToXmlParentAttributes` instance that inspects the value of its @bar@ field
28+-- and returns it as an attribute.
29+-- This way the TH-generators can safely apply `toXmlParentAttributes` to any
30+-- value without worrying about missing instances.
31+instance {-# OVERLAPPABLE #-} ToXmlParentAttributes a where
32+ toXmlParentAttributes _ = []
33+
34+class ToXmlAttribute a where
35+ toXmlAttribute :: a -> T.S.Text
36+
37+instance ToXmlAttribute T.S.Text where
38+ toXmlAttribute = id
39+
40+toXmlAttributeIntegral :: Integral a => a -> T.S.Text
41+toXmlAttributeIntegral = T.L.toStrict . T.L.toLazyText . T.L.decimal
42+
43+instance ToXmlAttribute Int where
44+ toXmlAttribute = toXmlAttributeIntegral
45+
46+instance ToXmlAttribute Word where
47+ toXmlAttribute = toXmlAttributeIntegral
48+
49+instance ToXmlAttribute Integer where
50+ toXmlAttribute = toXmlAttributeIntegral
51+
52+instance ToXmlAttribute Natural where
53+ toXmlAttribute = toXmlAttributeIntegral
stack.yamlnew file+9
@@ -0,0 +1,9 @@
1+resolver: lts-6.27
2+
3+packages:
4+- "."
5+
6+extra-deps:
7+- dom-parser-2.0.0
8+- type-fun-0.0.1
9+- open-union-0.2.0.0
test/Main.hsnew file+6
@@ -0,0 +1,6 @@
1+module Main where
2+
3+import TestDefs
4+
5+main :: IO ()
6+main = return ()
test/TestDefs.hsnew file+27
@@ -0,0 +1,27 @@
1+{-# LANGUAGE NoImplicitPrelude #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE TemplateHaskell #-}
4+
5+{-# OPTIONS -ddump-splices #-}
6+
7+module TestDefs where
8+
9+import Data.THGen.XML
10+
11+"Bar" =:= enum
12+ & "baroque"
13+ & "bartender"
14+
15+"Quux" Exhaustive =:= enum
16+ & "ALL"
17+ & "YOUR"
18+ & "BASE"
19+ & "ARE"
20+ & "BELONG"
21+ & "TO"
22+ & "US"
23+
24+"Foo" =:= record
25+ + "Bar"
26+ ? "Baz" [t|Text|]
27+ !% "Quux"
xml-isogen.cabal+13−1
@@ -20,15 +20,17 @@ cabal-version: >=1.22
2020library
2121 exposed-modules: Data.THGen.Enum
2222 Data.THGen.XML
23+ Text.XML.ParentAttributes
2324
2425 build-depends: QuickCheck >= 2.8
2526 , base >=4.8 && <5
26− , dom-parser >= 0.1.0
27+ , dom-parser >= 2.0.0
2728 , lens >= 4.13
2829 , mtl >= 2.2
2930 , semigroups >= 0.18
3031 , template-haskell >= 2.10
3132 , text >= 1.2
33+ , xml-conduit >= 1.0
3234 , xml-conduit-writer >= 0.1
3335
3436 hs-source-dirs: src
@@ -38,3 +40,13 @@ library
3840 LambdaCase
3941 FlexibleInstances
4042 TypeFamilies
43+ TupleSections
44+
45+test-suite spec
46+ type: exitcode-stdio-1.0
47+ hs-source-dirs: test
48+ main-is: Main.hs
49+ other-modules: TestDefs
50+ build-depends: base, xml-isogen
51+ default-language: Haskell2010
52+ ghc-options: -Wall -fno-warn-missing-signatures