git.iko.soy/typeable/xml-isogen
on 987ed57 help sign in
e7de369
swap
3 ahead, 21 behind
src/Data/THGen/XML.hs+7−3
since splitsnapshots
unifiedsplit
@@ -40,7 +40,7 @@ to be either @R@, @G@ or @B@.
40
40
41Example 2.
41Example 2.
42
42
43−> "Message" =:= record Both
43+> "Message" =:= record Both Lens
44> ! "author"
44> ! "author"
45> + "recipient"
45> + "recipient"
46> ? "message" [t|Text|]
46> ? "message" [t|Text|]
@@ -78,9 +78,12 @@ the data type to be generated. The prefix for the record fields is
78inferred automatically by taking all of the uppercase letters in the
78inferred automatically by taking all of the uppercase letters in the
79name. You can override it manually like so:
79name. You can override it manually like so:
80
80
81−> "Reference" "ref" =:= record Parser
81+> "Reference" "ref" =:= record Parser Lens
82> ...
82> ...
83
83
84+Second argument to @record@ either enabled lens generation for records fields
85+or disables it for use with DuplicateRecordFields and, possibly, generic-lens.
86+
84To describe a record field you must supply its name as it appears
87To describe a record field you must supply its name as it appears
85in the XML tag, prefixed by its repetition kind:
88in the XML tag, prefixed by its repetition kind:
86
89
@@ -93,7 +96,7 @@ The type of the field is inferred automatically from its name, so
93if the field is called @"author"@ its type will be @Author@. You can
96if the field is called @"author"@ its type will be @Author@. You can
94override the type by specifying it in quasiquotes like so:
97override the type by specifying it in quasiquotes like so:
95
98
96−> "Message" =:= record Both
99+> "Message" =:= record Both NoLens
97> ! "author" [t|Person|].
100> ! "author" [t|Person|].
98> ...
101> ...
99
102
@@ -109,6 +112,7 @@ module Data.THGen.XML
109 , PrefixName(..)
112 , PrefixName(..)
110 , ExhaustivenessName(..)
113 , ExhaustivenessName(..)
111 , GenType(..)
114 , GenType(..)
115+ , GenerateLens(..)
112 , record
116 , record
113 , enum
117 , enum
114 , (!)
118 , (!)
src/Data/THGen/XML/Internal.hs+58−18
@@ -24,8 +24,27 @@ import Text.XML.ParentAttributes
24import qualified Text.XML.Writer as XW
24import qualified Text.XML.Writer as XW
25
25
26
26
27+{- | Marks the type of code generation:
28+@Parser@ - generate only instances for xml parsing (@FromDom@)
29+@Generator@ - generate only @ToXML@ instances
30+@Both@ - generate @FromDom@ and @ToXML@ instances
31+-}
27data GenType = Parser | Generator | Both
32data GenType = Parser | Generator | Both
28
33
34+{- | Marks the style of code generation regarding records fields
35+@LensRenaming@ - fields get renamed by prefixing the field name with
36+'_' and lowercased capital letter used in the type name.
37+e.g. for
38+
39+> "MyNewDataType" =:= record genType LensRenaming
40+> * "field1"
41+
42+field will be renamed to `_mndtField1` and lens `mndtField1` will be created.
43+
44+@NoLens@ - no field renaming and no lens generation.
45+-}
46+data GenerateLens = LensRenaming | NoLens
47+
29data XmlFieldPlural
48data XmlFieldPlural
30 = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
49 = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
31 | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)
50 | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)
@@ -55,7 +74,7 @@ data IsoXmlDescRecordPart
55 | IsoXmlDescRecordAttribute IsoXmlDescAttribute
74 | IsoXmlDescRecordAttribute IsoXmlDescAttribute
56 | IsoXmlDescRecordContent IsoXmlDescContent
75 | IsoXmlDescRecordContent IsoXmlDescContent
57
76
58−data IsoXmlDescRecord = IsoXmlDescRecord GenType [IsoXmlDescRecordPart]
77+data IsoXmlDescRecord = IsoXmlDescRecord GenType GenerateLens [IsoXmlDescRecordPart]
59
78
60makePrisms ''IsoXmlDescRecord
79makePrisms ''IsoXmlDescRecord
61
80
@@ -76,26 +95,34 @@ appendField
76 -> IsoXmlDescRecord
95 -> IsoXmlDescRecord
77 -> IsoXmlDescPreField
96 -> IsoXmlDescPreField
78 -> IsoXmlDescRecord
97 -> IsoXmlDescRecord
98+appendField
99+ plural
79−appendField plural (IsoXmlDescRecord genType fields) (IsoXmlDescPreField name ty) =
100+ (IsoXmlDescRecord genType generateLens fields)
101+ (IsoXmlDescPreField name ty) =
80− let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty
102+ let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty
81− in IsoXmlDescRecord genType (xfield:fields)
103+ in IsoXmlDescRecord genType generateLens (xfield:fields)
82
104
83appendAttribute
105appendAttribute
84 :: XmlAttributePlural
106 :: XmlAttributePlural
85 -> IsoXmlDescRecord
107 -> IsoXmlDescRecord
86 -> IsoXmlDescPreAttribute
108 -> IsoXmlDescPreAttribute
87 -> IsoXmlDescRecord
109 -> IsoXmlDescRecord
110+appendAttribute
111+ plural
112+ (IsoXmlDescRecord genType generateLens fields)
88−appendAttribute plural (IsoXmlDescRecord genType fields) (IsoXmlDescPreAttribute name ty) =
113+ (IsoXmlDescPreAttribute name ty) =
89− let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty
114+ let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty
90− in IsoXmlDescRecord genType (xattribute:fields)
115+ in IsoXmlDescRecord genType generateLens (xattribute:fields)
91
116
92appendContent
117appendContent
93 :: IsoXmlDescRecord
118 :: IsoXmlDescRecord
94 -> IsoXmlDescPreContent
119 -> IsoXmlDescPreContent
95 -> IsoXmlDescRecord
120 -> IsoXmlDescRecord
121+appendContent
122+ (IsoXmlDescRecord genType generateLens fields)
96−appendContent (IsoXmlDescRecord genType fields) (IsoXmlDescPreContent name ty) =
123+ (IsoXmlDescPreContent name ty) =
97− let xcontent = IsoXmlDescRecordContent $ IsoXmlDescContent name ty
124+ let xcontent = IsoXmlDescRecordContent $ IsoXmlDescContent name ty
98− in IsoXmlDescRecord genType (xcontent:fields)
125+ in IsoXmlDescRecord genType generateLens (xcontent:fields)
99
126
100(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
127(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
101(!) = appendField XmlFieldPluralMandatory
128(!) = appendField XmlFieldPluralMandatory
@@ -133,11 +160,11 @@ class Description name desc | desc -> name where
133infix 0 =:=
160infix 0 =:=
134
161
135instance Description PrefixName IsoXmlDescRecord where
162instance Description PrefixName IsoXmlDescRecord where
136− prefixName =:= (IsoXmlDescRecord genType descRecordParts) =
163+ prefixName =:= (IsoXmlDescRecord genType generateLens descRecordParts) =
137− isoXmlGenerateDatatype genType prefixName (reverse descRecordParts)
164+ isoXmlGenerateDatatype genType generateLens prefixName (reverse descRecordParts)
138
165
139−record :: GenType -> IsoXmlDescRecord
166+record :: GenType -> GenerateLens -> IsoXmlDescRecord
140−record gt = IsoXmlDescRecord gt []
167+record gt gl = IsoXmlDescRecord gt gl []
141
168
142enum :: GenType -> IsoXmlDescEnum
169enum :: GenType -> IsoXmlDescEnum
143enum gt = IsoXmlDescEnum gt []
170enum gt = IsoXmlDescEnum gt []
@@ -238,14 +265,25 @@ isoXmlGenerateEnum genType (ExhaustivenessName strName' exh) enumCons = do
238 return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
265 return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
239 fromDomInst, fromAttributeInst]
266 fromDomInst, fromAttributeInst]
240
267
241−isoXmlGenerateDatatype :: GenType -> PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ
268+isoXmlGenerateDatatype
269+ :: GenType
270+ -> GenerateLens
271+ -> PrefixName
272+ -> [IsoXmlDescRecordPart]
273+ -> TH.DecsQ
274+isoXmlGenerateDatatype
275+ genType
276+ generateLens
242−isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts = do
277+ (PrefixName strName' strPrefix')
278+ descRecordParts = do
243 let
279 let
244 isNewtype = length descRecordParts == 1
280 isNewtype = length descRecordParts == 1
245 strName = "Xml" ++ strName'
281 strName = "Xml" ++ strName'
246 strPrefix = "x" ++ strPrefix'
282 strPrefix = "x" ++ strPrefix'
247 name = TH.mkName strName
283 name = TH.mkName strName
284+ fieldName str = case generateLens of
248− fieldName str = "_" ++ strPrefix ++ over _head C.toUpper str
285+ LensRenaming -> "_" ++ strPrefix ++ over _head C.toUpper str
286+ NoLens -> str
249 termDecl <- do
287 termDecl <- do
250 let
288 let
251 fields = do
289 fields = do
@@ -287,7 +325,9 @@ isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts
287 -- generate a newtype instead to do less allocations later
325 -- generate a newtype instead to do less allocations later
288 then THC.newtypeD name (TH.recC name fields) [''Eq, ''Show, ''Generic]
326 then THC.newtypeD name (TH.recC name fields) [''Eq, ''Show, ''Generic]
289 else THC.dataD name [TH.recC name fields] [''Eq, ''Show, ''Generic]
327 else THC.dataD name [TH.recC name fields] [''Eq, ''Show, ''Generic]
328+ lensDecls <- case generateLens of
329+ NoLens -> pure []
290− lensDecls <- makeFieldOpticsForDec lensRules termDecl
330+ LensRenaming -> makeFieldOpticsForDec lensRules termDecl
291 nfDataInst <- do
331 nfDataInst <- do
292 TH.instanceD
332 TH.instanceD
293 (return [])
333 (return [])
test/TestDefs.hs+8−8
@@ -22,14 +22,14 @@ import Test.QuickCheck.Instances ()
22 & "TO"
22 & "TO"
23 & "US"
23 & "US"
24
24
25−"Foo" =:= record Both
25+"Foo" =:= record Both NoLens
26− ^ "Shmuux" [t|XmlQuux|]
26+ ^ "shmuux" [t|XmlQuux|]
27− + "Bar"
27+ + "bar"
28− ? "Baz" [t|Text|]
28+ ? "baz" [t|Text|]
29− !% "Quux"
29+ !% "quux"
30− ?% "Muux" [t|XmlQuux|]
30+ ?% "muux" [t|XmlQuux|]
31−
31+
32−"Root" =:= record Both
32+"Root" =:= record Both LensRenaming
33 ! "{http://example.com/ns/my-namespace}Foo"
33 ! "{http://example.com/ns/my-namespace}Foo"
34
34
35instance Arbitrary XmlRoot where
35instance Arbitrary XmlRoot where