git.iko.soy/typeable/xml-isogen
on master help sign in
Reduce allocations by using newtypes when possible, solves #8
commit03c1dd8165b56b92d1aa7ffb3be3110ea208e3d3 authorDenis Redozubov <denis.redozubov@gmail.com> dateMon 12 Mar 2018, 19:26 (9 years ago) parent6ee42f3
2 files changed+37−4
compare with master
unifiedsplit
src/Data/THGen/Compat.hs+23 src/Data/THGen/XML.hs+14−4
src/Data/THGen/Compat.hs+23
@@ -2,6 +2,8 @@
22
33module Data.THGen.Compat
44 ( dataD
5+ , newtypeD
6+ , nonStrictType
57 , strictType
68 , varStrictType
79 ) where
@@ -21,6 +23,27 @@ dataD name cons derivs = TH.dataD (return []) name [] Nothing cons derivCls
2123dataD name = TH.dataD (return []) name []
2224#endif
2325
26+newtypeD :: TH.Name -> TH.ConQ -> [TH.Name] -> TH.DecQ
27+#if MIN_VERSION_template_haskell(2,12,0)
28+newtypeD name cons derivs = TH.newtypeD (return []) name [] Nothing cons [derivCls]
29+ where
30+ derivCls = TH.derivClause Nothing $ fmap TH.conT derivs
31+#elif MIN_VERSION_template_haskell(2,11,0)
32+newtypeD name cons derivs = TH.newtypeD (return []) name [] Nothing cons derivCls
33+ where
34+ derivCls = traverse TH.conT derivs
35+#else
36+newtypeD name = TH.newtypeD (return []) name []
37+#endif
38+
39+#if MIN_VERSION_template_haskell(2,11,0)
40+nonStrictType :: TH.TypeQ -> TH.BangTypeQ
41+nonStrictType = TH.bangType (TH.bang TH.noSourceUnpackedness TH.sourceLazy)
42+#else
43+nonStrictType :: TH.TypeQ -> TH.StrictTypeQ
44+nonStrictType = TH.strictType TH.notStrict
45+#endif
46+
2447#if MIN_VERSION_template_haskell(2,11,0)
2548strictType :: TH.TypeQ -> TH.BangTypeQ
2649strictType = TH.bangType (TH.bang TH.noSourceUnpackedness TH.sourceStrict)
src/Data/THGen/XML.hs+14−4
@@ -133,12 +133,14 @@ import Data.THGen.Enum
133133import qualified Data.Text as T
134134import GHC.Generics (Generic)
135135import qualified Language.Haskell.TH as TH
136+import qualified Language.Haskell.TH.Syntax as TH
136137import Prelude hiding ((+), (*))
137138import qualified Text.XML as X
138139import Text.XML.DOM.Parser
139140import Text.XML.ParentAttributes
140141import qualified Text.XML.Writer as XW
141142
143+
142144data XmlFieldPlural
143145 = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
144146 | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)
@@ -313,11 +315,12 @@ isoXmlGenerateEnum (ExhaustivenessName strName' exh) enumCons = do
313315isoXmlGenerateRecord :: PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ
314316isoXmlGenerateRecord (PrefixName strName' strPrefix') descRecordParts = do
315317 let
318+ isNewtype = length descRecordParts == 1
316319 strName = "Xml" ++ strName'
317320 strPrefix = "x" ++ strPrefix'
318321 name = TH.mkName strName
319322 fieldName str = "_" ++ strPrefix ++ over _head C.toUpper str
320− dataDecl <- do
323+ termDecl <- do
321324 let
322325 fields = do
323326 descRecordPart <- descRecordParts
@@ -331,8 +334,9 @@ isoXmlGenerateRecord (PrefixName strName' strPrefix') descRecordParts = do
331334 XmlFieldPluralOptional -> [t| Maybe $fieldType |]
332335 XmlFieldPluralRepeated -> [t| [$fieldType] |]
333336 XmlFieldPluralMultiplied -> [t| NonEmpty $fieldType |]
334− in
335− varStrictType fName (strictType fType)
337+ in if isNewtype
338+ then varStrictType fName (nonStrictType fType)
339+ else varStrictType fName (strictType fType)
336340 IsoXmlDescRecordAttribute descAttribute ->
337341 let
338342 IsoXmlDescAttribute
@@ -343,6 +347,7 @@ isoXmlGenerateRecord (PrefixName strName' strPrefix') descRecordParts = do
343347 XmlAttributePluralOptional -> [t| Maybe $attributeType |]
344348 in
345349 varStrictType fName (strictType fType)
350+<<<<<<< HEAD
346351 dataD
347352 name
348353 [TH.recC name fields]
@@ -353,6 +358,11 @@ isoXmlGenerateRecord (PrefixName strName' strPrefix') descRecordParts = do
353358 (return [])
354359 [t|NFData $(TH.conT name)|]
355360 [ ]
361+ if isNewtype
362+ -- generate a newtype instead to do less allocations later
363+ then newtypeD name (TH.recC name fields) [''Eq, ''Show]
364+ else dataD name [TH.recC name fields] [''Eq, ''Show]
365+ lensDecls <- makeFieldOpticsForDec lensRules termDecl
356366 fromDomInst <- do
357367 let
358368 exprHeader = [e|pure $(TH.conE name)|]
@@ -439,7 +449,7 @@ isoXmlGenerateRecord (PrefixName strName' strPrefix') descRecordParts = do
439449 [t|ToXmlParentAttributes $(TH.conT name)|]
440450 [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]
441451
442− return $ [dataDecl] ++ lensDecls ++
452+ return $ [termDecl] ++ lensDecls ++
443453 [fromDomInst, toXmlInst, toXmlParentAttributesInst]
444454
445455distribPair :: Functor f => (a, f b) -> f (a, b)