@@ -24,8 +24,27 @@ import Text.XML.ParentAttributes
2424import qualified Text.XML.Writer as XW
2525
2626
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+-}
2732data GenType = Parser | Generator | Both
2833
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+
2948data XmlFieldPlural
3049 = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
3150 | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)
@@ -55,7 +74,7 @@ data IsoXmlDescRecordPart
5574 | IsoXmlDescRecordAttribute IsoXmlDescAttribute
5675 | IsoXmlDescRecordContent IsoXmlDescContent
5776
58−data IsoXmlDescRecord = IsoXmlDescRecord GenType [IsoXmlDescRecordPart]
77+data IsoXmlDescRecord = IsoXmlDescRecord GenType GenerateLens [IsoXmlDescRecordPart]
5978
6079makePrisms ''IsoXmlDescRecord
6180
@@ -76,26 +95,34 @@ appendField
7695 -> IsoXmlDescRecord
7796 -> IsoXmlDescPreField
7897 -> IsoXmlDescRecord
79−appendField plural (IsoXmlDescRecord genType fields) (IsoXmlDescPreField name ty) =
80− let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty
81− in IsoXmlDescRecord genType (xfield:fields)
98+appendField
99+ plural
100+ (IsoXmlDescRecord genType generateLens fields)
101+ (IsoXmlDescPreField name ty) =
102+ let xfield = IsoXmlDescRecordField $ IsoXmlDescField plural name ty
103+ in IsoXmlDescRecord genType generateLens (xfield:fields)
82104
83105appendAttribute
84106 :: XmlAttributePlural
85107 -> IsoXmlDescRecord
86108 -> IsoXmlDescPreAttribute
87109 -> IsoXmlDescRecord
88−appendAttribute plural (IsoXmlDescRecord genType fields) (IsoXmlDescPreAttribute name ty) =
89− let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty
90− in IsoXmlDescRecord genType (xattribute:fields)
110+appendAttribute
111+ plural
112+ (IsoXmlDescRecord genType generateLens fields)
113+ (IsoXmlDescPreAttribute name ty) =
114+ let xattribute = IsoXmlDescRecordAttribute $ IsoXmlDescAttribute plural name ty
115+ in IsoXmlDescRecord genType generateLens (xattribute:fields)
91116
92117appendContent
93118 :: IsoXmlDescRecord
94119 -> IsoXmlDescPreContent
95120 -> IsoXmlDescRecord
96−appendContent (IsoXmlDescRecord genType fields) (IsoXmlDescPreContent name ty) =
97− let xcontent = IsoXmlDescRecordContent $ IsoXmlDescContent name ty
98− in IsoXmlDescRecord genType (xcontent:fields)
121+appendContent
122+ (IsoXmlDescRecord genType generateLens fields)
123+ (IsoXmlDescPreContent name ty) =
124+ let xcontent = IsoXmlDescRecordContent $ IsoXmlDescContent name ty
125+ in IsoXmlDescRecord genType generateLens (xcontent:fields)
99126
100127(!), (?), (*), (+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord
101128(!) = appendField XmlFieldPluralMandatory
@@ -133,11 +160,11 @@ class Description name desc | desc -> name where
133160infix 0 =:=
134161
135162instance Description PrefixName IsoXmlDescRecord where
136− prefixName =:= (IsoXmlDescRecord genType descRecordParts) =
137− isoXmlGenerateDatatype genType prefixName (reverse descRecordParts)
163+ prefixName =:= (IsoXmlDescRecord genType generateLens descRecordParts) =
164+ isoXmlGenerateDatatype genType generateLens prefixName (reverse descRecordParts)
138165
139−record :: GenType -> IsoXmlDescRecord
140−record gt = IsoXmlDescRecord gt []
166+record :: GenType -> GenerateLens -> IsoXmlDescRecord
167+record gt gl = IsoXmlDescRecord gt gl []
141168
142169enum :: GenType -> IsoXmlDescEnum
143170enum gt = IsoXmlDescEnum gt []
@@ -238,14 +265,25 @@ isoXmlGenerateEnum genType (ExhaustivenessName strName' exh) enumCons = do
238265 return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
239266 fromDomInst, fromAttributeInst]
240267
241−isoXmlGenerateDatatype :: GenType -> PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ
242−isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts = do
268+isoXmlGenerateDatatype
269+ :: GenType
270+ -> GenerateLens
271+ -> PrefixName
272+ -> [IsoXmlDescRecordPart]
273+ -> TH.DecsQ
274+isoXmlGenerateDatatype
275+ genType
276+ generateLens
277+ (PrefixName strName' strPrefix')
278+ descRecordParts = do
243279 let
244280 isNewtype = length descRecordParts == 1
245281 strName = "Xml" ++ strName'
246282 strPrefix = "x" ++ strPrefix'
247283 name = TH.mkName strName
248− fieldName str = "_" ++ strPrefix ++ over _head C.toUpper str
284+ fieldName str = case generateLens of
285+ LensRenaming -> "_" ++ strPrefix ++ over _head C.toUpper str
286+ NoLens -> str
249287 termDecl <- do
250288 let
251289 fields = do
@@ -287,7 +325,9 @@ isoXmlGenerateDatatype genType (PrefixName strName' strPrefix') descRecordParts
287325 -- generate a newtype instead to do less allocations later
288326 then THC.newtypeD name (TH.recC name fields) [''Eq, ''Show, ''Generic]
289327 else THC.dataD name [TH.recC name fields] [''Eq, ''Show, ''Generic]
290− lensDecls <- makeFieldOpticsForDec lensRules termDecl
328+ lensDecls <- case generateLens of
329+ NoLens -> pure []
330+ LensRenaming -> makeFieldOpticsForDec lensRules termDecl
291331 nfDataInst <- do
292332 TH.instanceD
293333 (return [])