diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +### 0.5.7 [2019.08.27] +* Permit `deriveVia` to use "floating" `via` type variables, such as the `a` + in: + + ```hs + deriveVia [t| forall a. Show MyInt `Via` Const Int a |] + ``` + ### 0.5.6 [2019.05.02] * Support deriving `Eq`, `Ord`, and `Show` instances for data types with fields of type `Int8#`, `Int16#`, `Word8#`, or `Word16#` on GHC 8.8 or later. 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.6 +version: 0.5.7 synopsis: Backports of GHC deriving extensions description: Provides Template Haskell functions that mimic deriving extensions that were introduced or modified in recent versions @@ -121,7 +121,7 @@ other-modules: Paths_deriving_compat build-depends: containers >= 0.1 && < 0.7 , ghc-prim - , th-abstraction >= 0.2.9 && < 0.4 + , th-abstraction >= 0.3 && < 0.4 if flag(base-4-9) build-depends: base >= 4.9 && < 5 @@ -158,6 +158,7 @@ ShowSpec GH6Spec GH24Spec + GH27Spec Types.EqOrd Types.ReadShow diff --git a/src/Data/Bounded/Deriving/Internal.hs b/src/Data/Bounded/Deriving/Internal.hs --- a/src/Data/Bounded/Deriving/Internal.hs +++ b/src/Data/Bounded/Deriving/Internal.hs @@ -37,11 +37,7 @@ case info of DatatypeInfo { datatypeContext = ctxt , datatypeName = parentName -#if MIN_VERSION_th_abstraction(0,3,0) , datatypeInstTypes = instTypes -#else - , datatypeVars = instTypes -#endif , datatypeVariant = variant , datatypeCons = cons } -> do @@ -80,11 +76,7 @@ case info of DatatypeInfo { datatypeContext = ctxt , datatypeName = parentName -#if MIN_VERSION_th_abstraction(0,3,0) , datatypeInstTypes = instTypes -#else - , datatypeVars = instTypes -#endif , datatypeVariant = variant , datatypeCons = cons } -> do diff --git a/src/Data/Deriving.hs b/src/Data/Deriving.hs --- a/src/Data/Deriving.hs +++ b/src/Data/Deriving.hs @@ -79,25 +79,25 @@ * In GHC 8.4, deriving 'Functor' and 'Traverable' was changed so that it uses 'coerce' for efficiency when the last parameter of the data type is at phantom role. -* In GHC 8.4, the `EmptyDataDeriving` proposal brought forth a slew of changes related +* In GHC 8.4, the @EmptyDataDeriving@ proposal brought forth a slew of changes related to how instances for empty data types (i.e., no constructors) were derived. These changes include: - * For derived `Eq` and `Ord` instances for empty data types, simply return - `True` and `EQ`, respectively, without inspecting the arguments. + * For derived 'Eq' and 'Ord' instances for empty data types, simply return + 'True' and 'EQ', respectively, without inspecting the arguments. - * For derived `Read` instances for empty data types, simply return `pfail` - (without `parens`). + * For derived 'Read' instances for empty data types, simply return 'pfail' + (without 'parens'). - * For derived `Show` instances for empty data types, inspect the argument - (instead of `error`ing). + * For derived 'Show' instances for empty data types, inspect the argument + (instead of 'error'ing). - * For derived `Functor` and `Traversable` instances for empty data - types, make `fmap` and `traverse` strict in its argument. + * For derived 'Functor' and 'Traversable' instances for empty data + types, make 'fmap' and 'traverse' strict in its argument. - * For derived `Foldable` instances, do not error on empty data types. - Instead, simply return the folded state (for `foldr`) or `mempty` (for - `foldMap`), without inspecting the arguments. + * For derived 'Foldable' instances, do not error on empty data types. + Instead, simply return the folded state (for 'foldr') or 'mempty' (for + 'foldMap'), without inspecting the arguments. * In GHC 8.6, the @DerivingVia@ language extension was introduced. @deriving-compat@ provides an interface which attempts to mimic this @@ -107,8 +107,11 @@ Since the generated code requires the use of @TypeApplications@, this can only be backported back to GHC 8.2. -* In GHC 8.6, deriving `Read` was changed so as to factor out certain commonly +* In GHC 8.6, deriving 'Read' was changed so as to factor out certain commonly used subexpressions, which significantly improve compliation times. + +* In GHC 8.10, @DerivingVia@ permits \"floating\" type variables in @via@ types, + such as the @a@ in @'deriveVia' [t| forall a. Show MyInt ``Via`` Const Int a |]@. -} {- $derive diff --git a/src/Data/Deriving/Via.hs b/src/Data/Deriving/Via.hs --- a/src/Data/Deriving/Via.hs +++ b/src/Data/Deriving/Via.hs @@ -54,6 +54,8 @@ * @TypeApplications@ + * @TypeOperators@ + * @UndecidableInstances@ (if deriving an instance of a type class with associated type families) 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 @@ -45,11 +45,12 @@ deriveGND :: Q Type -> Q [Dec] deriveGND qty = do ty <- qty - let (instanceCxt, instanceTy) = decomposeType ty + let (instanceTvbs, instanceCxt, instanceTy) = decomposeType ty instanceTy' <- (resolveTypeSynonyms <=< resolveInfixT) instanceTy decs <- deriveViaDecs instanceTy' Nothing - (:[]) `fmap` instanceD (return instanceCxt) - (return instanceTy) + let instanceHeader = ForallT instanceTvbs instanceCxt instanceTy + (:[]) `fmap` instanceD (return []) + (return instanceHeader) (map return decs) {- | Generates an instance for a type class by emulating the behavior of the @@ -69,7 +70,7 @@ deriveVia :: Q Type -> Q [Dec] deriveVia qty = do ty <- qty - let (instanceCxt, viaApp) = decomposeType ty + let (instanceTvbs, instanceCxt, viaApp) = decomposeType ty viaApp' <- (resolveTypeSynonyms <=< resolveInfixT) viaApp (instanceTy, viaTy) <- case unapplyTy viaApp' of @@ -82,8 +83,9 @@ , "\t[t| forall a. C (T a) `Via` V a |]" ] decs <- deriveViaDecs instanceTy (Just viaTy) - (:[]) `fmap` instanceD (return instanceCxt) - (return instanceTy) + let instanceHeader = ForallT instanceTvbs instanceCxt instanceTy + (:[]) `fmap` instanceD (return []) + (return instanceHeader) (map return decs) deriveViaDecs :: Type -- ^ The instance head (e.g., @Eq (Foo a)@) @@ -110,11 +112,7 @@ case dataTy of ConT dataName -> do DatatypeInfo { -#if MIN_VERSION_th_abstraction(0,3,0) datatypeInstTypes = dataInstTypes -#else - datatypeVars = dataInstTypes -#endif , datatypeVariant = dv , datatypeCons = cons } <- reifyDatatype dataName @@ -154,10 +152,7 @@ tfLHSTys = map (applySubstitution lhsSubst) tfTvbTys tfRHSTys = map (applySubstitution rhsSubst) tfTvbTys tfRHSTy = applyTy (ConT tfName) tfRHSTys - tfInst <- tySynInstDCompat tfName -#if MIN_VERSION_th_abstraction(0,3,0) - Nothing -#endif + tfInst <- tySynInstDCompat tfName Nothing (map pure tfLHSTys) (pure tfRHSTy) pure (Just [tfInst]) @@ -204,9 +199,9 @@ #endif stripOuterForallT ty = ty -decomposeType :: Type -> (Cxt, Type) -decomposeType (ForallT _ ctxt ty) = (ctxt, ty) -decomposeType ty = ([], ty) +decomposeType :: Type -> ([TyVarBndr], Cxt, Type) +decomposeType (ForallT tvbs ctxt ty) = (tvbs, ctxt, ty) +decomposeType ty = ([], [], ty) newtypeRepType :: DatatypeVariant -> [ConstructorInfo] -> Maybe Type newtypeRepType dv cons = do diff --git a/src/Data/Enum/Deriving/Internal.hs b/src/Data/Enum/Deriving/Internal.hs --- a/src/Data/Enum/Deriving/Internal.hs +++ b/src/Data/Enum/Deriving/Internal.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - {-| Module: Data.Enum.Deriving.Internal Copyright: (C) 2015-2017 Ryan Scott @@ -41,11 +39,7 @@ case info of DatatypeInfo { datatypeContext = ctxt , datatypeName = parentName -#if MIN_VERSION_th_abstraction(0,3,0) , datatypeInstTypes = instTypes -#else - , datatypeVars = instTypes -#endif , datatypeVariant = variant , datatypeCons = cons } -> do @@ -111,11 +105,7 @@ case info of DatatypeInfo { datatypeContext = ctxt , datatypeName = parentName -#if MIN_VERSION_th_abstraction(0,3,0) , datatypeInstTypes = instTypes -#else - , datatypeVars = instTypes -#endif , datatypeVariant = variant , datatypeCons = cons } -> do 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 @@ -118,11 +118,7 @@ case info of DatatypeInfo { datatypeContext = ctxt , datatypeName = parentName -#if MIN_VERSION_th_abstraction(0,3,0) , datatypeInstTypes = instTypes -#else - , datatypeVars = instTypes -#endif , datatypeVariant = variant , datatypeCons = cons } -> do @@ -152,11 +148,7 @@ case info of DatatypeInfo { datatypeContext = ctxt , datatypeName = parentName -#if MIN_VERSION_th_abstraction(0,3,0) , datatypeInstTypes = instTypes -#else - , datatypeVars = instTypes -#endif , datatypeVariant = variant , datatypeCons = cons } -> do diff --git a/src/Data/Functor/Deriving/Internal.hs b/src/Data/Functor/Deriving/Internal.hs --- a/src/Data/Functor/Deriving/Internal.hs +++ b/src/Data/Functor/Deriving/Internal.hs @@ -219,11 +219,7 @@ case info of DatatypeInfo { datatypeContext = ctxt , datatypeName = parentName -#if MIN_VERSION_th_abstraction(0,3,0) , datatypeInstTypes = instTypes -#else - , datatypeVars = instTypes -#endif , datatypeVariant = variant , datatypeCons = cons } -> do @@ -259,11 +255,7 @@ case info of DatatypeInfo { datatypeContext = ctxt , datatypeName = parentName -#if MIN_VERSION_th_abstraction(0,3,0) , datatypeInstTypes = instTypes -#else - , datatypeVars = instTypes -#endif , datatypeVariant = variant , datatypeCons = cons } -> do diff --git a/src/Data/Ix/Deriving/Internal.hs b/src/Data/Ix/Deriving/Internal.hs --- a/src/Data/Ix/Deriving/Internal.hs +++ b/src/Data/Ix/Deriving/Internal.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - {-| Module: Data.Ix.Deriving.Internal Copyright: (C) 2015-2017 Ryan Scott @@ -38,11 +36,7 @@ case info of DatatypeInfo { datatypeContext = ctxt , datatypeName = parentName -#if MIN_VERSION_th_abstraction(0,3,0) , datatypeInstTypes = instTypes -#else - , datatypeVars = instTypes -#endif , datatypeVariant = variant , datatypeCons = cons } -> do @@ -90,11 +84,7 @@ case info of DatatypeInfo { datatypeContext = ctxt , datatypeName = parentName -#if MIN_VERSION_th_abstraction(0,3,0) , datatypeInstTypes = instTypes -#else - , datatypeVars = instTypes -#endif , datatypeVariant = variant , datatypeCons = cons } -> do diff --git a/src/Data/Ord/Deriving/Internal.hs b/src/Data/Ord/Deriving/Internal.hs --- a/src/Data/Ord/Deriving/Internal.hs +++ b/src/Data/Ord/Deriving/Internal.hs @@ -164,11 +164,7 @@ case info of DatatypeInfo { datatypeContext = ctxt , datatypeName = parentName -#if MIN_VERSION_th_abstraction(0,3,0) , datatypeInstTypes = instTypes -#else - , datatypeVars = instTypes -#endif , datatypeVariant = variant , datatypeCons = cons } -> do @@ -227,11 +223,7 @@ case info of DatatypeInfo { datatypeContext = ctxt , datatypeName = parentName -#if MIN_VERSION_th_abstraction(0,3,0) , datatypeInstTypes = instTypes -#else - , datatypeVars = instTypes -#endif , datatypeVariant = variant , datatypeCons = cons } -> do diff --git a/src/Text/Read/Deriving/Internal.hs b/src/Text/Read/Deriving/Internal.hs --- a/src/Text/Read/Deriving/Internal.hs +++ b/src/Text/Read/Deriving/Internal.hs @@ -424,11 +424,7 @@ case info of DatatypeInfo { datatypeContext = ctxt , datatypeName = parentName -#if MIN_VERSION_th_abstraction(0,3,0) , datatypeInstTypes = instTypes -#else - , datatypeVars = instTypes -#endif , datatypeVariant = variant , datatypeCons = cons } -> do @@ -468,11 +464,7 @@ case info of DatatypeInfo { datatypeContext = ctxt , datatypeName = parentName -#if MIN_VERSION_th_abstraction(0,3,0) , datatypeInstTypes = instTypes -#else - , datatypeVars = instTypes -#endif , datatypeVariant = variant , datatypeCons = cons } -> do diff --git a/src/Text/Show/Deriving/Internal.hs b/src/Text/Show/Deriving/Internal.hs --- a/src/Text/Show/Deriving/Internal.hs +++ b/src/Text/Show/Deriving/Internal.hs @@ -275,11 +275,7 @@ case info of DatatypeInfo { datatypeContext = ctxt , datatypeName = parentName -#if MIN_VERSION_th_abstraction(0,3,0) , datatypeInstTypes = instTypes -#else - , datatypeVars = instTypes -#endif , datatypeVariant = variant , datatypeCons = cons } -> do @@ -309,11 +305,7 @@ case info of DatatypeInfo { datatypeContext = ctxt , datatypeName = parentName -#if MIN_VERSION_th_abstraction(0,3,0) , datatypeInstTypes = instTypes -#else - , datatypeVars = instTypes -#endif , datatypeVariant = variant , datatypeCons = cons } -> do diff --git a/tests/GH27Spec.hs b/tests/GH27Spec.hs new file mode 100644 --- /dev/null +++ b/tests/GH27Spec.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} + +#if MIN_VERSION_template_haskell(2,12,0) +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-unused-foralls #-} -- Due to GHC #13512. Sigh. +#endif + +{-| +Module: GH27Spec +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/27. +We isolate this test case from the rest of "DerivingViaSpec" because +we have to disable @-Wunused-foralls@ due to +https://gitlab.haskell.org/ghc/ghc/issues/13512, and we would prefer not to +contaminate the rest of "DerivingViaSpec" with this hack. +-} +module GH27Spec where + +import Prelude () +import Prelude.Compat + +import Test.Hspec + +#if MIN_VERSION_template_haskell(2,12,0) +import Data.Deriving.Via +import Data.Functor.Const + +newtype Age = MkAge Int +$(deriveVia [t| forall a. Show Age `Via` Const Int a |]) +#endif + +main :: IO () +main = hspec spec + +spec :: Spec +spec = pure ()