diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +### 0.5.3 [2018.01.20] +* Fix a bug in which `deriveEnum`/`deriveIx` would generate ill-scoped code + for certain poly-kinded data types. + ### 0.5.2 [2018.09.13] * Fix a bug (on GHC 8.7 and above) in which `deriveGND`/`deriveVia` would generate ill-scoped code. diff --git a/deriving-compat.cabal b/deriving-compat.cabal --- a/deriving-compat.cabal +++ b/deriving-compat.cabal @@ -1,5 +1,5 @@ name: deriving-compat -version: 0.5.2 +version: 0.5.3 synopsis: Backports of GHC deriving extensions description: Provides Template Haskell functions that mimic deriving extensions that were introduced or modified in recent versions @@ -70,8 +70,8 @@ , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 - , GHC == 8.4.3 - , GHC == 8.6.1 + , GHC == 8.4.4 + , GHC == 8.6.3 cabal-version: >=1.10 source-repository head @@ -123,7 +123,7 @@ Paths_deriving_compat build-depends: containers >= 0.1 && < 0.7 , ghc-prim - , th-abstraction >= 0.2.2 && < 1 + , th-abstraction >= 0.2.9 && < 0.3 if flag(base-4-9) build-depends: base >= 4.9 && < 5 @@ -159,6 +159,7 @@ ReadSpec ShowSpec GH6Spec + GH24Spec Types.EqOrd Types.ReadShow 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 @@ -38,6 +38,7 @@ import Data.Maybe import qualified Data.Set as Set import Data.Set (Set) +import qualified Data.Traversable as T import Text.ParserCombinators.ReadPrec (ReadPrec) import qualified Text.Read.Lex as L @@ -1022,9 +1023,10 @@ tag2ConExpr ty = do iHash <- newName "i#" ty' <- freshenType ty + let tvbs = avoidTypeInType $ freeVariablesWellScoped [ty'] lam1E (conP iHashDataName [varP iHash]) $ varE tagToEnumHashValName `appE` varE iHash - `sigE` return (ForallT (requiredTyVarsOfType ty') [] ty') + `sigE` return (ForallT tvbs [] ty') -- tagToEnum# is a hack, and won't typecheck unless it's in the -- immediate presence of a type ascription like so: -- @@ -1033,17 +1035,44 @@ -- We have to be careful when dealing with datatypes with type -- variables, since Template Haskell might reject the type variables -- we use for being out-of-scope. To avoid this, we explicitly - -- collect the type variable binders with requiredTyVarsOfType - -- and shove them into a ForallT. Also make sure to freshen the - -- bound type variables to avoid shadowed variable warnings when - -- -Wall is enabled. - -- - -- Note that we do NOT collect the kind variable binders, since - -- a type signature like `forall k a. Foo (a :: k)` won't typecheck - -- unless TypeInType is enabled (i.e., if GHC 8.0 or later is being - -- used). Luckily, GHC seems to just accept kind variables, even if - -- they aren't actually bound in a ForallT. + -- collect the type variable binders and shove them into a ForallT + -- (using th-abstraction's quantifyType function). Also make sure + -- to freshen the bound type variables to avoid shadowed variable + -- warnings on old versions of GHC when -Wall is enabled. + where + -- Somewhat annoyingly, it's possible to generate code that requires + -- TypeInType (on old versions of GHC) for data types which didn't require + -- TypeInType to define. To avoid users having to turn on more language + -- extensions than is necessary, we filter out all kind variable binders. + -- Fortunately, old versions of GHC are quite alright with implicitly + -- quantifying kind variables, even in the type of a SigE. + -- + -- This is rather tiresome, and while writing this function, I debated + -- whether to just forget about this nonsense and require users to + -- enable TypeInType to use the generated code. Alas, that would entail + -- a breaking change, so I decided against it at the time. If we ever make + -- some breaking change in the future, however, this would be at the top + -- of the list of things that I'd rip out. + avoidTypeInType :: [TyVarBndr] -> [TyVarBndr] +#if __GLASGOW_HASKELL__ >= 806 + avoidTypeInType = id +#else + avoidTypeInType = go . map attachFreeKindVars + where + attachFreeKindVars :: TyVarBndr -> (TyVarBndr, [Name]) + attachFreeKindVars tvb = (tvb, freeVariables (tvKind tvb)) + go :: [(TyVarBndr, [Name])] -> [TyVarBndr] + go [] = [] + go ((tvb, _):tvbsAndFVs) + | any (\(_, kindVars) -> tvName tvb `elem` kindVars) tvbsAndFVs + = tvbs' + | otherwise + = tvb:tvbs' + where + tvbs' = go tvbsAndFVs +#endif + removeClassApp :: Type -> Type removeClassApp (AppT _ t2) = t2 removeClassApp t = t @@ -1058,13 +1087,10 @@ freshen n = newName (nameBase n ++ "_'") freshenType :: Type -> Q Type -freshenType (AppT t1 t2) = do t1' <- freshenType t1 - t2' <- freshenType t2 - return $ AppT t1' t2' -freshenType (SigT t k) = do t' <- freshenType t - return $ SigT t' k -freshenType (VarT n) = fmap VarT $ freshen n -freshenType t = return t +freshenType t = + do let xs = [(n, VarT `fmap` freshen n) | n <- freeVariables t] + subst <- T.sequence (Map.fromList xs) + return (applySubstitution subst t) -- | Gets all of the required type variable binders mentioned in a Type. requiredTyVarsOfType :: Type -> [TyVarBndr] diff --git a/src/Data/Deriving/Via/Internal.hs b/src/Data/Deriving/Via/Internal.hs --- a/src/Data/Deriving/Via/Internal.hs +++ b/src/Data/Deriving/Via/Internal.hs @@ -139,15 +139,15 @@ where go :: Dec -> Q (Maybe [Dec]) - go (OpenTypeFamilyD (TypeFamilyHead tfName tfTvbs _ _)) = + go (OpenTypeFamilyD (TypeFamilyHead tfName tfTvbs _ _)) = do let lhsSubst = zipTvbSubst clsTvbs clsArgs rhsSubst = zipTvbSubst clsTvbs $ changeLast clsArgs repTy tfTvbTys = map tvbToType tfTvbs tfLHSTys = map (applySubstitution lhsSubst) tfTvbTys tfRHSTys = map (applySubstitution rhsSubst) tfTvbTys tfRHSTy = applyTy (ConT tfName) tfRHSTys - tfInst = TySynInstD tfName (TySynEqn tfLHSTys tfRHSTy) - in return (Just [tfInst]) + tfInst <- tySynInstDCompat tfName (map pure tfLHSTys) (pure tfRHSTy) + pure (Just [tfInst]) go (SigD methName methTy) = let (fromTy, toTy) = mkCoerceClassMethEqn clsTvbs clsArgs repTy $ diff --git a/tests/GH24Spec.hs b/tests/GH24Spec.hs new file mode 100644 --- /dev/null +++ b/tests/GH24Spec.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE TypeInType #-} +#endif + +{-| +Module: GH24Spec +Copyright: (C) 2019 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +A regression test for +https://github.com/haskell-compat/deriving-compat/issues/24. +-} +module GH24Spec (main, spec) where + +#if __GLASGOW_HASKELL__ >= 800 +import Data.Deriving +#endif + +import Prelude () +import Prelude.Compat + +import Test.Hspec + +#if __GLASGOW_HASKELL__ >= 800 +data family P (a :: j) (b :: k) +data instance P (a :: k) k = MkP deriving (Eq, Ord) + +$(deriveEnum 'MkP) +$(deriveIx 'MkP) +#endif + +main :: IO () +main = hspec spec + +spec :: Spec +spec = pure ()