git.iko.soy/typeable/xml-isogen
on master help sign in
Merge pull request #9 from typeable/newtype-optimization
f09e6aeDenis Redozubov
src/Data/THGen/Compat.hs+23
compare with master
unifiedsplit
@@ -2,6 +2,8 @@
2
2
3module Data.THGen.Compat
3module Data.THGen.Compat
4 ( dataD
4 ( dataD
5+ , newtypeD
6+ , nonStrictType
5 , strictType
7 , strictType
6 , varStrictType
8 , varStrictType
7 ) where
9 ) where
@@ -21,6 +23,27 @@ dataD name cons derivs = TH.dataD (return []) name [] Nothing cons derivCls
21dataD name = TH.dataD (return []) name []
23dataD name = TH.dataD (return []) name []
22#endif
24#endif
23
25
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+
24#if MIN_VERSION_template_haskell(2,11,0)
47#if MIN_VERSION_template_haskell(2,11,0)
25strictType :: TH.TypeQ -> TH.BangTypeQ
48strictType :: TH.TypeQ -> TH.BangTypeQ
26strictType = TH.bangType (TH.bang TH.noSourceUnpackedness TH.sourceStrict)
49strictType = TH.bangType (TH.bang TH.noSourceUnpackedness TH.sourceStrict)
src/Data/THGen/Enum.hs+10−2
@@ -25,14 +25,17 @@ module Data.THGen.Enum
25 ) where
25 ) where
26
26
27import Control.Applicative
27import Control.Applicative
28+import Control.DeepSeq
28import Control.Lens (over, _head, (<&>))
29import Control.Lens (over, _head, (<&>))
29import Control.Monad
30import Control.Monad
30import qualified Data.Char as C
31import qualified Data.Char as C
31import Data.THGen.Compat
32import Data.THGen.Compat
33+import GHC.Generics (Generic)
32import qualified Language.Haskell.TH as TH
34import qualified Language.Haskell.TH as TH
33import qualified Test.QuickCheck as QC
35import qualified Test.QuickCheck as QC
34import qualified Text.Read as R
36import qualified Text.Read as R
35
37
38+
36data Exhaustiveness = Exhaustive | NonExhaustive
39data Exhaustiveness = Exhaustive | NonExhaustive
37 deriving (Eq, Ord, Show)
40 deriving (Eq, Ord, Show)
38
41
@@ -79,7 +82,7 @@ enumGenerate (EnumDesc exh strName strVals) = do
79 dataD
82 dataD
80 name
83 name
81 (constrs ++ unknownConstr)
84 (constrs ++ unknownConstr)
82− ([''Eq, ''Ord] ++ if (exh == Exhaustive) then [''Enum, ''Bounded] else [])
85+ ([''Eq, ''Ord, ''Generic] ++ if (exh == Exhaustive) then [''Enum, ''Bounded] else [])
83 showInstDecl <- do
86 showInstDecl <- do
84 unknownMatch <- case exh of
87 unknownMatch <- case exh of
85 Exhaustive -> return []
88 Exhaustive -> return []
@@ -126,4 +129,9 @@ enumGenerate (EnumDesc exh strName strVals) = do
126 (return [])
129 (return [])
127 [t|QC.Arbitrary $(TH.conT name)|]
130 [t|QC.Arbitrary $(TH.conT name)|]
128 [funSimple 'QC.arbitrary arbExpr]
131 [funSimple 'QC.arbitrary arbExpr]
132+ nfDataInst <- do
133+ TH.instanceD
134+ (return [])
135+ [t|NFData $(TH.conT name)|]
136+ []
129− return [dataDecl, readInstDecl, showInstDecl, arbInstance]
137+ return [dataDecl, readInstDecl, showInstDecl, arbInstance, nfDataInst]
src/Data/THGen/XML.hs+17−13
@@ -133,12 +133,14 @@ import Data.THGen.Enum
133import qualified Data.Text as T
133import qualified Data.Text as T
134import GHC.Generics (Generic)
134import GHC.Generics (Generic)
135import qualified Language.Haskell.TH as TH
135import qualified Language.Haskell.TH as TH
136+import qualified Language.Haskell.TH.Syntax as TH
136import Prelude hiding ((+), (*))
137import Prelude hiding ((+), (*))
137import qualified Text.XML as X
138import qualified Text.XML as X
138import Text.XML.DOM.Parser
139import Text.XML.DOM.Parser
139import Text.XML.ParentAttributes
140import Text.XML.ParentAttributes
140import qualified Text.XML.Writer as XW
141import qualified Text.XML.Writer as XW
141
142
143+
142data XmlFieldPlural
144data XmlFieldPlural
143 = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
145 = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)
144 | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)
146 | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)
@@ -231,7 +233,7 @@ infix 0 =:=
231instance Description PrefixName IsoXmlDescRecord where
233instance Description PrefixName IsoXmlDescRecord where
232 prefixName =:= descRecord =
234 prefixName =:= descRecord =
233 let descRecordParts = descRecord ^. _IsoXmlDescRecord
235 let descRecordParts = descRecord ^. _IsoXmlDescRecord
234− in isoXmlGenerateRecord prefixName (reverse descRecordParts)
236+ in isoXmlGenerateDatatype prefixName (reverse descRecordParts)
235
237
236record :: IsoXmlDescRecord
238record :: IsoXmlDescRecord
237record = IsoXmlDescRecord []
239record = IsoXmlDescRecord []
@@ -310,14 +312,15 @@ isoXmlGenerateEnum (ExhaustivenessName strName' exh) enumCons = do
310 return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
312 return $ enumDecls ++ [toXmlInst, toXmlAttributeInst,
311 fromDomInst, fromAttributeInst]
313 fromDomInst, fromAttributeInst]
312
314
313−isoXmlGenerateRecord :: PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ
315+isoXmlGenerateDatatype :: PrefixName -> [IsoXmlDescRecordPart] -> TH.DecsQ
314−isoXmlGenerateRecord (PrefixName strName' strPrefix') descRecordParts = do
316+isoXmlGenerateDatatype (PrefixName strName' strPrefix') descRecordParts = do
315 let
317 let
318+ isNewtype = length descRecordParts == 1
316 strName = "Xml" ++ strName'
319 strName = "Xml" ++ strName'
317 strPrefix = "x" ++ strPrefix'
320 strPrefix = "x" ++ strPrefix'
318 name = TH.mkName strName
321 name = TH.mkName strName
319 fieldName str = "_" ++ strPrefix ++ over _head C.toUpper str
322 fieldName str = "_" ++ strPrefix ++ over _head C.toUpper str
320− dataDecl <- do
323+ termDecl <- do
321 let
324 let
322 fields = do
325 fields = do
323 descRecordPart <- descRecordParts
326 descRecordPart <- descRecordParts
@@ -331,8 +334,9 @@ isoXmlGenerateRecord (PrefixName strName' strPrefix') descRecordParts = do
331 XmlFieldPluralOptional -> [t| Maybe $fieldType |]
334 XmlFieldPluralOptional -> [t| Maybe $fieldType |]
332 XmlFieldPluralRepeated -> [t| [$fieldType] |]
335 XmlFieldPluralRepeated -> [t| [$fieldType] |]
333 XmlFieldPluralMultiplied -> [t| NonEmpty $fieldType |]
336 XmlFieldPluralMultiplied -> [t| NonEmpty $fieldType |]
334− in
337+ in if isNewtype
338+ then varStrictType fName (nonStrictType fType)
335− varStrictType fName (strictType fType)
339+ else varStrictType fName (strictType fType)
336 IsoXmlDescRecordAttribute descAttribute ->
340 IsoXmlDescRecordAttribute descAttribute ->
337 let
341 let
338 IsoXmlDescAttribute
342 IsoXmlDescAttribute
@@ -343,11 +347,11 @@ isoXmlGenerateRecord (PrefixName strName' strPrefix') descRecordParts = do
343 XmlAttributePluralOptional -> [t| Maybe $attributeType |]
347 XmlAttributePluralOptional -> [t| Maybe $attributeType |]
344 in
348 in
345 varStrictType fName (strictType fType)
349 varStrictType fName (strictType fType)
346− dataD
350+ if isNewtype
347− name
351+ -- generate a newtype instead to do less allocations later
352+ then newtypeD name (TH.recC name fields) [''Eq, ''Show, ''Generic]
348− [TH.recC name fields]
353+ else dataD name [TH.recC name fields] [''Eq, ''Show, ''Generic]
349− [''Eq, ''Show, ''Generic]
350− lensDecls <- makeFieldOpticsForDec lensRules dataDecl
354+ lensDecls <- makeFieldOpticsForDec lensRules termDecl
351 nfDataInst <- do
355 nfDataInst <- do
352 TH.instanceD
356 TH.instanceD
353 (return [])
357 (return [])
@@ -439,8 +443,8 @@ isoXmlGenerateRecord (PrefixName strName' strPrefix') descRecordParts = do
439 [t|ToXmlParentAttributes $(TH.conT name)|]
443 [t|ToXmlParentAttributes $(TH.conT name)|]
440 [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]
444 [funSimple 'toXmlParentAttributes toXmlParentAttributesExpr]
441
445
442− return $ [dataDecl] ++ lensDecls ++
446+ return $ [termDecl] ++ lensDecls ++
443− [fromDomInst, toXmlInst, toXmlParentAttributesInst]
447+ [fromDomInst, toXmlInst, toXmlParentAttributesInst, nfDataInst]
444
448
445distribPair :: Functor f => (a, f b) -> f (a, b)
449distribPair :: Functor f => (a, f b) -> f (a, b)
446distribPair (a, fb) = (a,) <$> fb
450distribPair (a, fb) = (a,) <$> fb