diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +### 0.6.1 [2022.05.07] +* Backport [GHC!6955](https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6955), + which makes derived `Eq` instances check data constructor tags, which can + improve runtime performance for data types with nullary constructors. +* Allow building the test suite with `transformers-0.6.*`. + ## 0.6 [2021.08.29] * Allow building with `template-haskell-2.18.0.0` (GHC 9.2). * Using `deriveEnum` and `deriveIx` on poly-kinded data family instances may diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -15,15 +15,15 @@ https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29 "BSD 3-Clause License (Revised)" -Provides Template Haskell functions that mimic deriving extensions that were introduced or modified in recent versions of GHC. Currently, the following typeclasses/extensions are covered: +`deriving-compat` provides Template Haskell functions that mimic `deriving` extensions that were introduced or modified in recent versions of GHC. Currently, the following typeclasses/extensions are covered: * Deriving `Bounded` * Deriving `Enum` * Deriving `Ix` -* Deriving `Eq`, `Eq1`, and `Eq2` -* Deriving `Ord`, `Ord1`, and `Ord2` -* Deriving `Read`, `Read1`, and `Read2` -* Deriving `Show`, `Show1`, and `Show2` +* Deriving `Eq` +* Deriving `Ord` +* Deriving `Read` +* Deriving `Show` * `DeriveFoldable` * `DeriveFunctor` * `DeriveTraversable` @@ -31,6 +31,8 @@ * `DerivingVia` (with GHC 8.2 or later) See the `Data.Deriving` module for a full list of backported changes. + +In addition, `deriving-compat` also provides some additional `deriving` functionality that has not yet been merged into upstream GHC. Aside from the GHC `deriving` extensions mentioned above, `deriving-compat` also permits deriving instances of classes in the `Data.Functor.Classes` module, covering the `Eq1`, `Eq2`, `Ord1`, `Ord2`, `Read1`, `Read2`, `Show1`, and `Show2` classes. This extra functionality is outside of the main scope of `deriving-compat`, as it does not backport extensions that exist in today's GHC. Nevertheless, the underlying Template Haskell machinery needed to derive `Eq` and friends extends very naturally to `Eq1` and friends, so this extra functionality is included in `deriving-compat` as a convenience. Note that some recent GHC typeclasses/extensions are not covered by this package: diff --git a/deriving-compat.cabal b/deriving-compat.cabal --- a/deriving-compat.cabal +++ b/deriving-compat.cabal @@ -1,9 +1,10 @@ name: deriving-compat -version: 0.6 +version: 0.6.1 synopsis: Backports of GHC deriving extensions -description: Provides Template Haskell functions that mimic deriving - extensions that were introduced or modified in recent versions - of GHC. Currently, the following typeclasses/extensions are covered: +description: @deriving-compat@ provides Template Haskell functions that + mimic @deriving@ extensions that were introduced or modified + in recent versions of GHC. Currently, the following + typeclasses/extensions are covered: . * Deriving @Bounded@ . @@ -11,13 +12,13 @@ . * Deriving @Ix@ . - * Deriving @Eq@, @Eq1@, and @Eq2@ + * Deriving @Eq@ . - * Deriving @Ord@, @Ord1@, and @Ord2@ + * Deriving @Ord@ . - * Deriving @Read@, @Read1@, and @Read2@ + * Deriving @Read@ . - * Deriving @Show@, @Show1@, and @Show2@ + * Deriving @Show@ . * @DeriveFoldable@ . @@ -31,6 +32,21 @@ . See the "Data.Deriving" module for a full list of backported changes. . + In addition, @deriving-compat@ also provides some additional + @deriving@ functionality that has not yet been merged into + upstream GHC. Aside from the GHC @deriving@ extensions + mentioned above, @deriving-compat@ also permits deriving + instances of classes in the @Data.Functor.Classes@ module, + covering the @Eq1@, @Eq2@, @Ord1@, @Ord2@, @Read1@, + @Read2@, @Show1@, and @Show2@ classes. This extra + functionality is outside of the main scope of + @deriving-compat@, as it does not backport extensions that + exist in today's GHC. Nevertheless, the underlying Template + Haskell machinery needed to derive @Eq@ and friends + extends very naturally to @Eq1@ and friends, so this extra + functionality is included in @deriving-compat@ as a + convenience. + . Note that some recent GHC typeclasses/extensions are not covered by this package: . * @DeriveDataTypeable@ @@ -74,8 +90,8 @@ , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 - , GHC == 9.0.1 - , GHC == 9.2.* + , GHC == 9.0.2 + , GHC == 9.2.2 cabal-version: >=1.10 source-repository head @@ -139,7 +155,7 @@ build-depends: template-haskell >= 2.5 && < 2.11 if flag(new-functor-classes) - build-depends: transformers (>= 0.2 && < 0.4) || >= 0.5 + build-depends: transformers (>= 0.2 && < 0.4) || (>= 0.5 && < 0.7) , transformers-compat >= 0.5 cpp-options: "-DNEW_FUNCTOR_CLASSES" else @@ -183,7 +199,7 @@ build-depends: base >= 4.3 && < 4.9 if flag(new-functor-classes) - build-depends: transformers (>= 0.2 && < 0.4) || (>= 0.5 && < 0.6) + build-depends: transformers (>= 0.2 && < 0.4) || (>= 0.5 && < 0.7) , transformers-compat >= 0.5 cpp-options: "-DNEW_FUNCTOR_CLASSES" else @@ -194,3 +210,5 @@ ghc-options: -Wall -threaded -rtsopts if impl(ghc >= 8.6) ghc-options: -Wno-star-is-type + if impl(ghc >= 9.0) + ghc-options: -fenable-th-splice-warnings diff --git a/src/Data/Deriving.hs b/src/Data/Deriving.hs --- a/src/Data/Deriving.hs +++ b/src/Data/Deriving.hs @@ -123,6 +123,10 @@ * In GHC 9.0, @DeriveFunctor@ was changed so that it works on more constructors with rank-n field types. + +* In GHC 9.4, deriving 'Eq' was changed so that it checks data constructor + tags, which can improve runtime performance for data types with nullary + constructors. -} {- $derive diff --git a/src/Data/Deriving/Internal.hs b/src/Data/Deriving/Internal.hs --- a/src/Data/Deriving/Internal.hs +++ b/src/Data/Deriving/Internal.hs @@ -1562,6 +1562,9 @@ minusIntHashValName :: Name minusIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "-#" +neqIntHashValName :: Name +neqIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "/=#" + parenValName :: Name parenValName = mkNameG_v "base" "GHC.Read" "paren" diff --git a/src/Data/Eq/Deriving.hs b/src/Data/Eq/Deriving.hs --- a/src/Data/Eq/Deriving.hs +++ b/src/Data/Eq/Deriving.hs @@ -7,6 +7,10 @@ Portability: Template Haskell Exports functions to mechanically derive 'Eq', 'Eq1', and 'Eq2' instances. +Note that upstream GHC does not have the ability to derive 'Eq1' or 'Eq2' +instances, but since the functionality to derive 'Eq' extends very naturally +'Eq1' and 'Eq2', the ability to derive the latter two classes is provided as a +convenience. -} module Data.Eq.Deriving ( -- * 'Eq' diff --git a/src/Data/Eq/Deriving/Internal.hs b/src/Data/Eq/Deriving/Internal.hs --- a/src/Data/Eq/Deriving/Internal.hs +++ b/src/Data/Eq/Deriving/Internal.hs @@ -33,7 +33,7 @@ ) where import Data.Deriving.Internal -import Data.List (foldl1', partition) +import Data.List (foldl1') import qualified Data.Map as Map import Language.Haskell.TH.Datatype @@ -177,8 +177,7 @@ [value1, value2] ) . appsE $ [ varE $ eqConstName eClass - , letE [ funD eqDefn $ map (makeCaseForCon eClass tvMap) patMatchCons - ++ fallThroughCase + , letE [ funD eqDefn [eqClause tvMap] ] $ varE eqDefn `appE` varE value1 `appE` varE value2 ] #if defined(NEW_FUNCTOR_CLASSES) @@ -186,40 +185,64 @@ #endif ++ [varE value1, varE value2] where - nullaryCons, nonNullaryCons :: [ConstructorInfo] - (nullaryCons, nonNullaryCons) = partition isNullaryCon cons + nonNullaryCons :: [ConstructorInfo] + nonNullaryCons = filter (not . isNullaryCon) cons - tagMatchCons, patMatchCons :: [ConstructorInfo] - (tagMatchCons, patMatchCons) - | length nullaryCons > 10 = (nullaryCons, nonNullaryCons) - | otherwise = ([], cons) + numNonNullaryCons :: Int + numNonNullaryCons = length nonNullaryCons - fallThroughCase :: [Q Clause] - fallThroughCase - | null tagMatchCons = case patMatchCons of - [] -> [makeFallThroughCaseTrue] -- No constructors: _ == _ = True - [_] -> [] -- One constructor: no fall-through case - _ -> [makeFallThroughCaseFalse] -- Two or more constructors: - -- _ == _ = False - | otherwise = [makeTagCase] + eqClause :: TyVarMap1 -> Q Clause + eqClause tvMap + | null cons + = makeFallThroughCaseTrue + -- Tag checking is redundant when there is only one data constructor + | [con] <- cons + = makeCaseForCon eClass tvMap con + -- This is an enum (all constructors are nullary) - just do a simple tag check + | all isNullaryCon cons + = makeTagCase + | otherwise + = do abNames@(a, _, b, _) <- newABNames + clause (map varP [a,b]) + (normalB $ eqExprWithTagCheck tvMap abNames) + [] -makeTagCase :: Q Clause -makeTagCase = do + eqExprWithTagCheck :: TyVarMap1 -> (Name, Name, Name, Name) -> Q Exp + eqExprWithTagCheck tvMap (a, aHash, b, bHash) = + condE (untagExpr [(a, aHash), (b, bHash)] + (primOpAppExpr (varE aHash) neqIntHashValName (varE bHash))) + (conE falseDataName) + (caseE (varE a) + (map (mkNestedMatchesForCon eClass tvMap b) nonNullaryCons + ++ [ makeFallThroughMatchTrue + | 0 < numNonNullaryCons && numNonNullaryCons < length cons + ])) + +newABNames :: Q (Name, Name, Name, Name) +newABNames = do a <- newName "a" aHash <- newName "a#" b <- newName "b" bHash <- newName "b#" + return (a, aHash, b, bHash) + +makeTagCase :: Q Clause +makeTagCase = do + (a, aHash, b, bHash) <- newABNames clause (map varP [a,b]) (normalB $ untagExpr [(a, aHash), (b, bHash)] $ primOpAppExpr (varE aHash) eqIntHashValName (varE bHash)) [] -makeFallThroughCaseFalse, makeFallThroughCaseTrue :: Q Clause -makeFallThroughCaseFalse = makeFallThroughCase falseDataName -makeFallThroughCaseTrue = makeFallThroughCase trueDataName +makeFallThroughCaseTrue :: Q Clause +makeFallThroughCaseTrue = clause [wildP, wildP] (normalB $ conE trueDataName) [] -makeFallThroughCase :: Name -> Q Clause -makeFallThroughCase dataName = clause [wildP, wildP] (normalB $ conE dataName) [] +makeFallThroughMatchFalse, makeFallThroughMatchTrue :: Q Match +makeFallThroughMatchFalse = makeFallThroughMatch falseDataName +makeFallThroughMatchTrue = makeFallThroughMatch trueDataName +makeFallThroughMatch :: Name -> Q Match +makeFallThroughMatch dataName = match wildP (normalB $ conE dataName) [] + makeCaseForCon :: EqClass -> TyVarMap1 -> ConstructorInfo -> Q Clause makeCaseForCon eClass tvMap (ConstructorInfo { constructorName = conName, constructorFields = ts }) = do @@ -230,6 +253,22 @@ clause [conP conName (map varP as), conP conName (map varP bs)] (normalB $ makeCaseForArgs eClass tvMap conName ts' as bs) [] + +mkNestedMatchesForCon :: EqClass -> TyVarMap1 -> Name -> ConstructorInfo -> Q Match +mkNestedMatchesForCon eClass tvMap b + (ConstructorInfo { constructorName = conName, constructorFields = ts }) = do + ts' <- mapM resolveTypeSynonyms ts + let tsLen = length ts' + as <- newNameList "a" tsLen + bs <- newNameList "b" tsLen + match (conP conName (map varP as)) + (normalB $ caseE (varE b) + [ match (conP conName (map varP bs)) + (normalB $ makeCaseForArgs eClass tvMap conName ts' as bs) + [] + , makeFallThroughMatchFalse + ]) + [] makeCaseForArgs :: EqClass -> TyVarMap1 diff --git a/src/Data/Ord/Deriving.hs b/src/Data/Ord/Deriving.hs --- a/src/Data/Ord/Deriving.hs +++ b/src/Data/Ord/Deriving.hs @@ -7,6 +7,10 @@ Portability: Template Haskell Exports functions to mechanically derive 'Ord', 'Ord1', and 'Ord2' instances. +Note that upstream GHC does not have the ability to derive 'Ord1' or 'Ord2' +instances, but since the functionality to derive 'Ord' extends very naturally +'Ord1' and 'Ord2', the ability to derive the latter two classes is provided as a +convenience. -} module Data.Ord.Deriving ( -- * 'Ord' diff --git a/src/Text/Read/Deriving.hs b/src/Text/Read/Deriving.hs --- a/src/Text/Read/Deriving.hs +++ b/src/Text/Read/Deriving.hs @@ -7,6 +7,10 @@ Portability: Template Haskell Exports functions to mechanically derive 'Read', 'Read1', and 'Read2' instances. +Note that upstream GHC does not have the ability to derive 'Read1' or 'Read2' +instances, but since the functionality to derive 'Read' extends very naturally +'Read1' and 'Read2', the ability to derive the latter two classes is provided as a +convenience. -} module Text.Read.Deriving ( -- * 'Read' diff --git a/src/Text/Show/Deriving.hs b/src/Text/Show/Deriving.hs --- a/src/Text/Show/Deriving.hs +++ b/src/Text/Show/Deriving.hs @@ -7,6 +7,10 @@ Portability: Template Haskell Exports functions to mechanically derive 'Show', 'Show1', and 'Show2' instances. +Note that upstream GHC does not have the ability to derive 'Show1' or 'Show2' +instances, but since the functionality to derive 'Show' extends very naturally +'Show1' and 'Show2', the ability to derive the latter two classes is provided as a +convenience. -} module Text.Show.Deriving ( -- * 'Show' diff --git a/tests/FunctorSpec.hs b/tests/FunctorSpec.hs --- a/tests/FunctorSpec.hs +++ b/tests/FunctorSpec.hs @@ -8,6 +8,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE EmptyCase #-} diff --git a/tests/ShowSpec.hs b/tests/ShowSpec.hs --- a/tests/ShowSpec.hs +++ b/tests/ShowSpec.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE EmptyCase #-} #endif diff --git a/tests/Types/EqOrd.hs b/tests/Types/EqOrd.hs --- a/tests/Types/EqOrd.hs +++ b/tests/Types/EqOrd.hs @@ -5,6 +5,7 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-| Module: Types.EqOrd @@ -88,6 +89,11 @@ data Empty a b +data TyConNullary a b + = TyConNullary1 + | TyConNullary2 + | TyConNullary3 + -- Data families data family TyFamily1 y z :: * @@ -150,6 +156,13 @@ | TyFamilyWrap2 (f (g a)) | TyFamilyWrap3 (f (g (h a))) +data family TyFamilyNullary x y :: * + +data instance TyFamilyNullary a b + = TyFamilyNullary1 + | TyFamilyNullary2 + | TyFamilyNullary3 + ------------------------------------------------------------------------------- -- Plain data types @@ -162,11 +175,13 @@ (==) = $(makeEq ''TyConWrap) (/=) = $(makeNotEq ''TyConWrap) $(deriveEq ''Empty) +$(deriveEq ''TyConNullary) $(deriveEq1 ''TyCon1) $(deriveEq1 ''TyCon#) $(deriveEq1 ''TyCon2) $(deriveEq1 ''Empty) +$(deriveEq1 ''TyConNullary) $(deriveOrd ''TyCon1) $(deriveOrd ''TyCon#) @@ -186,6 +201,7 @@ $(deriveOrd1 ''TyCon#) $(deriveOrd1 ''TyCon2) $(deriveOrd1 ''Empty) +$(deriveOrd1 ''TyConNullary) #if defined(NEW_FUNCTOR_CLASSES) $(deriveEq1 ''TyConWrap) @@ -206,11 +222,13 @@ $(deriveEq2 ''TyCon#) $(deriveEq2 ''TyCon2) $(deriveEq2 ''Empty) +$(deriveEq2 ''TyConNullary) $(deriveOrd2 ''TyCon1) $(deriveOrd2 ''TyCon#) $(deriveOrd2 ''TyCon2) $(deriveOrd2 ''Empty) +$(deriveOrd2 ''TyConNullary) #endif #if MIN_VERSION_template_haskell(2,7,0) @@ -223,10 +241,12 @@ => Eq (TyFamilyWrap f g h a) where (==) = $(makeEq 'TyFamilyWrap1) (/=) = $(makeNotEq 'TyFamilyWrap1) +$(deriveEq 'TyFamilyNullary1) $(deriveEq1 'TyFamily1B) $(deriveEq1 'TyFamily#) $(deriveEq1 'TyFamilyEqualityConstraints) +$(deriveEq1 'TyFamilyNullary1) $(deriveOrd 'TyFamily1A) $(deriveOrd 'TyFamily#) @@ -240,10 +260,12 @@ (<=) = $(makeGE 'TyFamilyWrap1) max = $(makeMax 'TyFamilyWrap1) min = $(makeMin 'TyFamilyWrap1) +$(deriveOrd 'TyFamilyNullary1) $(deriveOrd1 'TyFamily1B) $(deriveOrd1 'TyFamily#) $(deriveOrd1 'TyFamilyEqualityConstraints) +$(deriveOrd1 'TyFamilyNullary1) #if defined(NEW_FUNCTOR_CLASSES) $(deriveEq1 'TyFamilyWrap2) @@ -263,9 +285,11 @@ $(deriveEq2 'TyFamily1C) $(deriveEq2 'TyFamily#) $(deriveEq2 'TyFamilyTypeRefinement1) +$(deriveEq2 'TyFamilyNullary1) $(deriveOrd2 'TyFamily1C) $(deriveOrd2 'TyFamily#) $(deriveOrd2 'TyFamilyTypeRefinement1) +$(deriveOrd2 'TyFamilyNullary1) # endif #endif