git.iko.soy/typeable/xml-isogen
on master help sign in
Merge pull request #9 from typeable/newtype-optimization

Reduce allocations by using newtypes when possible, solves #8

commitf09e6ae9012c0ad7eda7783899e209a53972bcf9 authorDenis Redozubov <denis.redozubov@gmail.com> dateTue 13 Mar 2018, 13:41 (9 years ago) parent6ee42f31f3fea0
3 files changed+50−15
compare with master
unifiedsplit
src/Data/THGen/Compat.hs+23 src/Data/THGen/Enum.hs+10−2 src/Data/THGen/XML.hs+17−13
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.noSourceStrictness)
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/Enum.hs+10−2
@@ -25,14 +25,17 @@ module Data.THGen.Enum
2525 ) where
2626
2727import Control.Applicative
28+import Control.DeepSeq
2829import Control.Lens (over, _head, (<&>))
2930import Control.Monad
3031import qualified Data.Char as C
3132import Data.THGen.Compat
33+import GHC.Generics (Generic)
3234import qualified Language.Haskell.TH as TH
3335import qualified Test.QuickCheck as QC
3436import qualified Text.Read as R
3537
38+
3639data Exhaustiveness = Exhaustive | NonExhaustive
3740 deriving (Eq, Ord, Show)
3841
@@ -79,7 +82,7 @@ enumGenerate (EnumDesc exh strName strVals) = do
7982 dataD
8083 name
8184 (constrs ++ unknownConstr)
82− ([''Eq, ''Ord] ++ if (exh == Exhaustive) then [''Enum, ''Bounded] else [])
85+ ([''Eq, ''Ord, ''Generic] ++ if (exh == Exhaustive) then [''Enum, ''Bounded] else [])
8386 showInstDecl <- do
8487 unknownMatch <- case exh of
8588 Exhaustive -> return []
@@ -126,4 +129,9 @@ enumGenerate (EnumDesc exh strName strVals) = do
126129 (return [])
127130 [t|QC.Arbitrary $(TH.conT name)|]
128131 [funSimple 'QC.arbitrary arbExpr]
129− return [dataDecl, readInstDecl, showInstDecl, arbInstance]
132+ nfDataInst <- do
133+ TH.instanceD
134+ (return [])
135+ [t|NFData $(TH.conT name)|]
136+ []
137+ return [dataDecl, readInstDecl, showInstDecl, arbInstance, nfDataInst]
src/Data/THGen/XML.hs+17−13
@@ -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)
@@ -231,7 +233,7 @@ infix 0 =:=
231233instance Description PrefixName IsoXmlDescRecord where
232234 prefixName =:= descRecord =
233235 let descRecordParts = descRecord ^. _IsoXmlDescRecord
234− in isoXmlGenerateRecord prefixName (reverse descRecordParts)
236+ in isoXmlGenerateDatatype prefixName (reverse descRecordParts)
235237
236238record :: IsoXmlDescRecord
237239record = IsoXmlDescRecord []
@@ -310,14 +312,15 @@ isoXmlGenerateEnum (ExhaustivenessName strName' exh) enumCons = do
310312 return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
311313 fromDomInst, fromAttributeInst]
312314
313−isoXmlGenerateRecord :: PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ
314−isoXmlGenerateRecord (PrefixName strName' strPrefix') descRecordParts = do
315+isoXmlGenerateDatatype :: PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ
316+isoXmlGenerateDatatype (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,11 +347,11 @@ isoXmlGenerateRecord (PrefixName strName' strPrefix') descRecordParts = do
343347 XmlAttributePluralOptional -> [t| Maybe $attributeType |]
344348 in
345349 varStrictType fName (strictType fType)
346− dataD
347− name
348− [TH.recC name fields]
349− [''Eq, ''Show, ''Generic]
350− lensDecls <- makeFieldOpticsForDec lensRules dataDecl
350+ if isNewtype
351+ -- generate a newtype instead to do less allocations later
352+ then newtypeD name (TH.recC name fields) [''Eq, ''Show, ''Generic]
353+ else dataD name [TH.recC name fields] [''Eq, ''Show, ''Generic]
354+ lensDecls <- makeFieldOpticsForDec lensRules termDecl
351355 nfDataInst <- do
352356 TH.instanceD
353357 (return [])
@@ -439,8 +443,8 @@ isoXmlGenerateRecord (PrefixName strName' strPrefix') descRecordParts = do
439443 [t|ToXmlParentAttributes $(TH.conT name)|]
440444 [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]
441445
442− return $ [dataDecl] ++ lensDecls ++
443− [fromDomInst, toXmlInst, toXmlParentAttributesInst]
446+ return $ [termDecl] ++ lensDecls ++
447+ [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]
444448
445449distribPair :: Functor f => (a, f b) -> f (a, b)
446450distribPair (a, fb) = (a,) <$> fb