diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,46 @@ +# 1.11 +* The behavior of function in `Generics.Deriving.TH` has changed with respect + to when type synonyms are generated for `Rep(1)` definitions. In particular: + + * By default, `deriveRepresentable(1)` will no longer define its `Rep(1)` + type family instance in terms of the type synonym that has to be generated + with `deriveRep(1)`. Similarly, `deriveAll(1)` and `deriveAll0And1` will no + longer generate a type synonym. Instead, they will generate `Generic(1)` + instances that directly define the `Rep(1)` instance inline. If you wish + to revert to the old behavior, you will need to use the variants of those + functions suffixed with `-Options`. + * New functions `makeRep0Inline` and `makeRep1Inline` have been added which, + for most purposes, should replace uses of `makeRep0`/`makeRep0FromType` + and `makeRep1`/`makeRep1FromType` (but see the next bullet point for a + caveat). + * The use of `deriveRep(1)`, `makeRep0`/`makeRep0FromType`, and + `makeRep1`/`makeRep1FromType` are now discouraged, but those functions are + still available. The reason is that on GHC 7.0/7.2/7.4, it is impossible to use + `makeRep0Inline`/`makeRep1Inline` due to a GHC bug. Therefore, you must use + `makeRep0`/`makeRep1` and `deriveRep(1)` on GHC 7.0/7.2/7.4 out of necessity. + + These changes make dealing with `Generic` instances that involve `PolyKinds` + and `TypeInType` much easier. +* All functions suffixed in `-WithKindSigs` in `Generics.Deriving.TH` have been + removed in favor of a more sensible `-Options` suffixing scheme. The ability to + toggle whether explicit kind signatures are used on type variable binders has + been folded into `KindSigOptions`, which is an explicit argument to + `deriveRep0Options`/`deriveRep1Options` and also a field in the more general + 'Options' data type. +* Furthermore, the behavior of derived instances' kind signatures has changed. + By default, the TH code will now _always_ use explicit kind signatures + whenever possible, regardless of whether you're working with plain data types + or data family instances. This makes working with `TypeInType` less + surprising, but at the cost of making it slightly more awkward to work with + derived `Generic1` instances that constrain kinds to `*` by means of `(:.:)`. +* Since `Generic1` is polykinded on GHC 8.2 and later, the functions in + `Generics.Deriving.TH` will no longer unify the kind of the last type + parameter to be `*`. +* Fix a bug in which `makeRep` (and similarly named functions) would not check + whether the argument type can actually have a well kinded `Generic(1)` + instance. +* Backport missing `Foldable` and `Traversable` instances for `Rec1` + # 1.10.7 * Renamed internal modules to avoid using apostrophes (averting this bug: https://github.com/haskell/cabal/issues/3631) diff --git a/generic-deriving.cabal b/generic-deriving.cabal --- a/generic-deriving.cabal +++ b/generic-deriving.cabal @@ -1,5 +1,5 @@ name: generic-deriving -version: 1.10.7 +version: 1.11 synopsis: Generic programming library for generalised deriving. description: @@ -12,7 +12,7 @@ . The current implementation integrates with the new GHC Generics. See for more information. - Template Haskell code is provided for supporting GHC before version 7.2. + Template Haskell code is provided for supporting older GHCs. homepage: https://github.com/dreixel/generic-deriving bug-reports: https://github.com/dreixel/generic-deriving/issues diff --git a/src/Generics/Deriving/Base/Internal.hs b/src/Generics/Deriving/Base/Internal.hs --- a/src/Generics/Deriving/Base/Internal.hs +++ b/src/Generics/Deriving/Base/Internal.hs @@ -729,7 +729,7 @@ -- | Recursive calls of kind * -> * newtype Rec1 f p = Rec1 { unRec1 :: f p } - deriving (Eq, Ord, Read, Functor, Show) + deriving (Eq, Ord, Read, Functor, Foldable, Traversable, Show) instance Applicative f => Applicative (Rec1 f) where pure a = Rec1 (pure a) diff --git a/src/Generics/Deriving/TH.hs b/src/Generics/Deriving/TH.hs --- a/src/Generics/Deriving/TH.hs +++ b/src/Generics/Deriving/TH.hs @@ -43,7 +43,7 @@ -- Adapted from Generics.Regular.TH module Generics.Deriving.TH ( - + -- * @derive@- functions deriveMeta , deriveData , deriveConstructors @@ -58,27 +58,40 @@ , deriveRep0 , deriveRep1 , simplInstance - -- * -@WithSigs@ functions - -- $withSigs - , deriveAll0WithKindSigs - , deriveAll1WithKindSigs - , deriveAll0And1WithKindSigs - , deriveRepresentable0WithKindSigs - , deriveRepresentable1WithKindSigs - , deriveRep0WithKindSigs - , deriveRep1WithKindSigs + -- * @make@- functions -- $make + , makeRep0Inline , makeRep0 , makeRep0FromType , makeFrom , makeFrom0 , makeTo , makeTo0 + , makeRep1Inline , makeRep1 , makeRep1FromType , makeFrom1 , makeTo1 + + -- * Options + -- $options + -- ** Option types + , Options(..) + , defaultOptions + , RepOptions(..) + , defaultRepOptions + , KindSigOptions + , defaultKindSigOptions + + -- ** Functions with optional arguments + , deriveAll0Options + , deriveAll1Options + , deriveAll0And1Options + , deriveRepresentable0Options + , deriveRepresentable1Options + , deriveRep0Options + , deriveRep1Options ) where import Control.Monad ((>=>), unless, when) @@ -88,6 +101,7 @@ #endif import Data.List (nub) import qualified Data.Map as Map (fromList) +import Data.Maybe (catMaybes) import Generics.Deriving.TH.Internal #if MIN_VERSION_base(4,9,0) @@ -99,33 +113,26 @@ import Language.Haskell.TH.Lib import Language.Haskell.TH -{- $withSigs -By default, 'deriveRep0', 'deriveRep1', and functions that invoke it generate -type synonyms whose type variable binders do not have explicit kind binders for -polykinded type variables. This is a pretty reasonable default, since puts less -of a burden on the Template Haskell machinery to get the kinds just right, and -lets the kind inferencer do more work. However, there are times when you want to -have explicit kind signatures, such as if you have a datatype that uses -@-XTypeInType@. For example: - -@ -data Prox (a :: k) (b :: *) = Prox k -$('deriveRep0WithKindSigs' ''Prox) -@ - -will result in something like: - -@ -type Rep0Prox (a :: k) (b :: *) = Rec0 k -@ +{- $options +'Options' gives you a way to further tweak derived 'Generic' and 'Generic1' instances: -Whereas if you had used 'deriveRep0', you would have something like: +* 'RepOptions': By default, all derived 'Rep' and 'Rep1' type instances emit the code + directly (the 'InlineRep' option). One can also choose to emit a separate type + synonym for the 'Rep' type (this is the functionality of 'deriveRep0' and + 'deriveRep1') and define a 'Rep' instance in terms of that type synonym (the + 'TypeSynonymRep' option). -@ -type Rep0Prox a (b :: *) = Rec0 k -@ +* 'KindSigOptions': By default, all derived instances will use explicit kind + signatures (when the 'KindSigOptions' is 'True'). You might wish to set the + 'KindSigOptions' to 'False' if you want a 'Generic'/'Generic1' instance at + a particular kind that GHC will infer correctly, but the functions in this + module won't guess correctly. For example, the following example will only + compile with 'KindSigOptions' set to 'False': -which will fail to compile, since k is out-of-scope! + @ + newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) = Compose (f (g a)) + $('deriveAll1Options' False ''Compose) + @ -} -- | Given the names of a generic class, a type to instantiate, a function in @@ -140,6 +147,39 @@ [funD fn [clause [] (normalB (varE df `appE` (sigE (varE undefinedValName) (return typ)))) []]] +-- | Additional options for configuring derived 'Generic'/'Generic1' instances +-- using Template Haskell. +data Options = Options + { repOptions :: RepOptions + , kindSigOptions :: KindSigOptions + } deriving (Eq, Ord, Read, Show) + +-- | Sensible default 'Options' ('defaultRepOptions' and 'defaultKindSigOptions'). +defaultOptions :: Options +defaultOptions = Options + { repOptions = defaultRepOptions + , kindSigOptions = defaultKindSigOptions + } + +-- | Configures whether 'Rep'/'Rep1' type instances should be defined inline in a +-- derived 'Generic'/'Generic1' instance ('InlineRep') or defined in terms of a +-- type synonym ('TypeSynonymRep'). +data RepOptions = InlineRep + | TypeSynonymRep + deriving (Eq, Ord, Read, Show) + +-- | 'InlineRep', a sensible default 'RepOptions'. +defaultRepOptions :: RepOptions +defaultRepOptions = InlineRep + +-- | 'True' if explicit kind signatures should be used in derived +-- 'Generic'/'Generic1' instances, 'False' otherwise. +type KindSigOptions = Bool + +-- | 'True', a sensible default 'KindSigOptions'. +defaultKindSigOptions :: KindSigOptions +defaultKindSigOptions = True + -- | A backwards-compatible synonym for 'deriveAll0'. deriveAll :: Name -> Q [Dec] deriveAll = deriveAll0 @@ -148,134 +188,133 @@ -- generate the 'Data' instance, the 'Constructor' instances, the 'Selector' -- instances, and the 'Representable0' instance. deriveAll0 :: Name -> Q [Dec] -deriveAll0 = deriveAllCommon True False False +deriveAll0 = deriveAll0Options defaultOptions --- | Like 'deriveAll0', except that the type variable binders in the --- 'Rep' type synonym will have explicit kind signatures. -deriveAll0WithKindSigs :: Name -> Q [Dec] -deriveAll0WithKindSigs = deriveAllCommon True False True +-- | Like 'deriveAll0', but takes an 'Options' argument. +deriveAll0Options :: Options -> Name -> Q [Dec] +deriveAll0Options = deriveAllCommon True False -- | Given the type and the name (as string) for the type to derive, -- generate the 'Data' instance, the 'Constructor' instances, the 'Selector' -- instances, and the 'Representable1' instance. deriveAll1 :: Name -> Q [Dec] -deriveAll1 = deriveAllCommon False True False +deriveAll1 = deriveAll1Options defaultOptions --- | Like 'deriveAll1', except that the type variable binders in the --- 'Rep1' type synonym will have explicit kind signatures. -deriveAll1WithKindSigs :: Name -> Q [Dec] -deriveAll1WithKindSigs = deriveAllCommon False True True +-- | Like 'deriveAll1', but takes an 'Options' argument. +deriveAll1Options :: Options -> Name -> Q [Dec] +deriveAll1Options = deriveAllCommon False True -- | Given the type and the name (as string) for the type to derive, -- generate the 'Data' instance, the 'Constructor' instances, the 'Selector' -- instances, the 'Representable0' instance, and the 'Representable1' instance. deriveAll0And1 :: Name -> Q [Dec] -deriveAll0And1 = deriveAllCommon True True False +deriveAll0And1 = deriveAll0And1Options defaultOptions --- | Like 'deriveAll0And1', except that the type variable binders in the --- 'Rep' and 'Rep1' type synonyms will have explicit kind signatures. -deriveAll0And1WithKindSigs :: Name -> Q [Dec] -deriveAll0And1WithKindSigs = deriveAllCommon True True True +-- | Like 'deriveAll0And1', but takes an 'Options' argument. +deriveAll0And1Options :: Options -> Name -> Q [Dec] +deriveAll0And1Options = deriveAllCommon True True -deriveAllCommon :: Bool -> Bool -> Bool -> Name -> Q [Dec] -deriveAllCommon generic generic1 useKindSigs n = do +deriveAllCommon :: Bool -> Bool -> Options -> Name -> Q [Dec] +deriveAllCommon generic generic1 opts n = do a <- deriveMeta n b <- if generic - then deriveRepresentableCommon Generic useKindSigs n + then deriveRepresentableCommon Generic opts n else return [] c <- if generic1 - then deriveRepresentableCommon Generic1 useKindSigs n + then deriveRepresentableCommon Generic1 opts n else return [] return (a ++ b ++ c) -- | Given the type and the name (as string) for the Representable0 type -- synonym to derive, generate the 'Representable0' instance. deriveRepresentable0 :: Name -> Q [Dec] -deriveRepresentable0 = deriveRepresentableCommon Generic False +deriveRepresentable0 = deriveRepresentable0Options defaultOptions --- | Like 'deriveRepresentable0', except that the type variable binders in the --- 'Rep' type synonym will have explicit kind signatures. -deriveRepresentable0WithKindSigs :: Name -> Q [Dec] -deriveRepresentable0WithKindSigs = deriveRepresentableCommon Generic True +-- | Like 'deriveRepresentable0', but takes an 'Options' argument. +deriveRepresentable0Options :: Options -> Name -> Q [Dec] +deriveRepresentable0Options = deriveRepresentableCommon Generic -- | Given the type and the name (as string) for the Representable1 type -- synonym to derive, generate the 'Representable1' instance. deriveRepresentable1 :: Name -> Q [Dec] -deriveRepresentable1 = deriveRepresentableCommon Generic1 False +deriveRepresentable1 = deriveRepresentable1Options defaultOptions --- | Like 'deriveRepresentable1', except that the type variable binders in the --- 'Rep1' type synonym will have explicit kind signatures. -deriveRepresentable1WithKindSigs :: Name -> Q [Dec] -deriveRepresentable1WithKindSigs = deriveRepresentableCommon Generic1 True +-- | Like 'deriveRepresentable1', but takes an 'Options' argument. +deriveRepresentable1Options :: Options -> Name -> Q [Dec] +deriveRepresentable1Options = deriveRepresentableCommon Generic1 -deriveRepresentableCommon :: GenericClass -> Bool -> Name -> Q [Dec] -deriveRepresentableCommon gClass useKindSigs n = do - rep <- deriveRepCommon gClass useKindSigs n - inst <- deriveInst gClass n +deriveRepresentableCommon :: GenericClass -> Options -> Name -> Q [Dec] +deriveRepresentableCommon gClass opts n = do + rep <- if repOptions opts == InlineRep + then return [] + else deriveRepCommon gClass (kindSigOptions opts) n + inst <- deriveInst gClass opts n return (rep ++ inst) -- | Derive only the 'Rep0' type synonym. Not needed if 'deriveRepresentable0' -- is used. deriveRep0 :: Name -> Q [Dec] -deriveRep0 = deriveRepCommon Generic False +deriveRep0 = deriveRep0Options defaultKindSigOptions --- | Like 'deriveRep0', except that the type variable binders in the 'Rep' --- type synonym will have explicit kind signatures. -deriveRep0WithKindSigs :: Name -> Q [Dec] -deriveRep0WithKindSigs = deriveRepCommon Generic True +-- | Like 'deriveRep0', but takes an 'KindSigOptions' argument. +deriveRep0Options :: KindSigOptions -> Name -> Q [Dec] +deriveRep0Options = deriveRepCommon Generic -- | Derive only the 'Rep1' type synonym. Not needed if 'deriveRepresentable1' -- is used. deriveRep1 :: Name -> Q [Dec] -deriveRep1 = deriveRepCommon Generic1 False +deriveRep1 = deriveRep1Options defaultKindSigOptions --- | Like 'deriveRep1', except that the type variable binders in the 'Rep1' --- type synonym will have explicit kind signatures. -deriveRep1WithKindSigs :: Name -> Q [Dec] -deriveRep1WithKindSigs = deriveRepCommon Generic1 True +-- | Like 'deriveRep1', but takes an 'KindSigOptions' argument. +deriveRep1Options :: KindSigOptions -> Name -> Q [Dec] +deriveRep1Options = deriveRepCommon Generic1 -deriveRepCommon :: GenericClass -> Bool -> Name -> Q [Dec] +deriveRepCommon :: GenericClass -> KindSigOptions -> Name -> Q [Dec] deriveRepCommon gClass useKindSigs n = do i <- reifyDataInfo n let (name, isNT, declTvbs, cons, dv) = either error id i -- See Note [Forcing buildTypeInstance] - !_ <- buildTypeInstance gClass name declTvbs dv + !_ <- buildTypeInstance gClass useKindSigs name declTvbs dv + tySynVars <- grabTyVarsFromCons gClass cons - tySynTvbs <- grabTyVarBndrsFromCons gClass cons - let tySynTvbs' = if useKindSigs - then tySynTvbs - else map (\tvb -> if isKindMonomorphic (tyVarBndrKind tvb) - then tvb - else unKindedTV tvb) tySynTvbs + -- See Note [Kind signatures in derived instances] + let tySynVars' = if useKindSigs + then tySynVars + else map unSigT tySynVars fmap (:[]) $ tySynD (genRepName gClass dv name) - tySynTvbs' - -- The typechecker will infer the kinds of the TyVarBndrs - -- in a type synonym declaration, so we don't need to - -- splice them in explicitly (hence the unKindedTV call). - (repType gClass dv name isNT cons tySynTvbs) + (catMaybes $ map typeToTyVarBndr tySynVars') + (repType gClass dv name isNT cons tySynVars) -deriveInst :: GenericClass -> Name -> Q [Dec] +deriveInst :: GenericClass -> Options -> Name -> Q [Dec] deriveInst Generic = deriveInstCommon genericTypeName repTypeName Generic fromValName toValName deriveInst Generic1 = deriveInstCommon generic1TypeName rep1TypeName Generic1 from1ValName to1ValName -deriveInstCommon :: Name -> Name -> GenericClass -> Name -> Name -> Name -> Q [Dec] -deriveInstCommon genericName repName gClass fromName toName n = do +deriveInstCommon :: Name -> Name -> GenericClass -> Name -> Name -> Options -> Name -> Q [Dec] +deriveInstCommon genericName repName gClass fromName toName opts n = do i <- reifyDataInfo n - let (name, _, allTvbs, cons, dv) = either error id i - origTy <- buildTypeInstance gClass name allTvbs dv - repTySynApp <- makeRepTySynApp gClass dv name cons origTy - let tyIns = TySynInstD repName + let (name, isNT, allTvbs, cons, dv) = either error id i + useKindSigs = kindSigOptions opts + -- See Note [Forcing buildTypeInstance] + !(origTy, origKind) <- buildTypeInstance gClass useKindSigs name allTvbs dv + tyInsRHS <- if repOptions opts == InlineRep + then makeRepInline gClass dv name isNT cons origTy + else makeRepTySynApp gClass dv name cons origTy + + let origSigTy = if useKindSigs + then SigT origTy origKind + else origTy + tyIns = TySynInstD repName #if MIN_VERSION_template_haskell(2,9,0) - (TySynEqn [origTy] repTySynApp) + (TySynEqn [origSigTy] tyInsRHS) #else - [origTy] repTySynApp + [origSigTy] tyInsRHS #endif mkBody maker = [clause [] (normalB $ mkCaseExp gClass name cons maker) []] fcs = mkBody mkFrom tcs = mkBody mkTo fmap (:[]) $ - instanceD (cxt []) (conT genericName `appT` return origTy) + instanceD (cxt []) (conT genericName `appT` return origSigTy) [return tyIns, funD fromName fcs, funD toName tcs] {- $make @@ -285,7 +324,7 @@ 'Generic1' instances. As an example, consider this data type: @ -data Fix f a = Fix (f (Fix f a)) +newtype Fix f a = Fix (f (Fix f a)) @ A proper 'Generic1' instance would look like this: @@ -302,16 +341,16 @@ $('deriveMeta' ''Fix) $('deriveRep1' ''Fix) instance Functor f => Generic1 (Fix f) where - type Rep1 (Fix f) = $('makeRep1FromType' ''Fix [t| Fix f |]) + type Rep1 (Fix f) = $('makeRep1Inline' ''Fix [t| Fix f |]) from1 = $('makeFrom1' ''Fix) to1 = $('makeTo1' ''Fix) @ Note that due to the lack of type-level lambdas in Haskell, one must manually -apply @'makeRep1FromType' ''Fix@ to the type @Fix f@. +apply @'makeRep1Inline' ''Fix@ to the type @Fix f@. Be aware that there is a bug on GHC 7.0, 7.2, and 7.4 which might prevent you from -using 'makeRep0FromType' and 'makeRep1FromType'. In the @Fix@ example above, you +using 'makeRep0Inline' and 'makeRep1Inline'. In the @Fix@ example above, you would experience the following error: @ @@ -319,11 +358,16 @@ In the Template Haskell quotation [t| Fix f |] @ -Then a workaround is to use 'makeRep1' instead, which requires you to pass as -arguments the type variables that occur in the instance, in order from left to -right, excluding duplicates. (Normally, 'makeRep1FromType' would figure this -out for you.) Using the above example: +Then a workaround is to use 'makeRep1' instead, which requires you to: +1. Invoke 'deriveRep1' beforehand + +2. Pass as arguments the type variables that occur in the instance, in order + from left to right, topologically sorted, excluding duplicates. (Normally, + 'makeRep1Inline' would figure this out for you.) + +Using the above example: + @ $('deriveMeta' ''Fix) $('deriveRep1' ''Fix) @@ -351,6 +395,40 @@ Note that you don't pass @b@ twice, only once. -} +-- | Generates the full 'Rep' type inline. Since this type can be quite +-- large, it is recommended you only use this to define 'Rep', e.g., +-- +-- @ +-- type Rep (Foo (a :: k) b) = $('makeRep0Inline' ''Foo [t| Foo (a :: k) b |]) +-- @ +-- +-- You can then simply refer to @Rep (Foo a b)@ elsewhere. +-- +-- Note that the type passed as an argument to 'makeRep0Inline' must match the +-- type argument of 'Rep' exactly, even up to including the explicit kind +-- signature on @a@. This is due to a limitation of Template Haskell—without +-- the kind signature, 'makeRep0Inline' has no way of figuring out the kind of +-- @a@, and the generated type might be completely wrong as a result! +makeRep0Inline :: Name -> Q Type -> Q Type +makeRep0Inline n = makeRepCommon Generic InlineRep n . Just + +-- | Generates the full 'Rep1' type inline. Since this type can be quite +-- large, it is recommended you only use this to define 'Rep1', e.g., +-- +-- @ +-- type Rep1 (Foo (a :: k)) = $('makeRep0Inline' ''Foo [t| Foo (a :: k) |]) +-- @ +-- +-- You can then simply refer to @Rep1 (Foo a)@ elsewhere. +-- +-- Note that the type passed as an argument to 'makeRep1Inline' must match the +-- type argument of 'Rep1' exactly, even up to including the explicit kind +-- signature on @a@. This is due to a limitation of Template Haskell—without +-- the kind signature, 'makeRep1Inline' has no way of figuring out the kind of +-- @a@, and the generated type might be completely wrong as a result! +makeRep1Inline :: Name -> Q Type -> Q Type +makeRep1Inline n = makeRepCommon Generic1 InlineRep n . Just + -- | Generates the 'Rep' type synonym constructor (as opposed to 'deriveRep0', -- which generates the type synonym declaration). After splicing it into -- Haskell source, it expects types as arguments. For example: @@ -358,52 +436,99 @@ -- @ -- type Rep (Foo a b) = $('makeRep0' ''Foo) a b -- @ +-- +-- The use of 'makeRep0' is generally discouraged, as it can sometimes be +-- difficult to predict the order in which you are expected to pass type +-- variables. As a result, 'makeRep0Inline' is recommended instead. However, +-- 'makeRep0Inline' is not usable on GHC 7.0, 7.2, or 7.4 due to a GHC bug, +-- so 'makeRep0' still exists for GHC 7.0, 7.2, and 7.4 users. makeRep0 :: Name -> Q Type -makeRep0 n = makeRepCommon Generic n Nothing +makeRep0 n = makeRepCommon Generic TypeSynonymRep n Nothing -- | Generates the 'Rep1' type synonym constructor (as opposed to 'deriveRep1', -- which generates the type synonym declaration). After splicing it into -- Haskell source, it expects types as arguments. For example: -- -- @ --- type Rep1 (Foo a b) = $('makeRep1' ''Foo) a b +-- type Rep1 (Foo a) = $('makeRep1' ''Foo) a -- @ +-- +-- The use of 'makeRep1' is generally discouraged, as it can sometimes be +-- difficult to predict the order in which you are expected to pass type +-- variables. As a result, 'makeRep1Inline' is recommended instead. However, +-- 'makeRep1Inline' is not usable on GHC 7.0, 7.2, or 7.4 due to a GHC bug, +-- so 'makeRep1' still exists for GHC 7.0, 7.2, and 7.4 users. makeRep1 :: Name -> Q Type -makeRep1 n = makeRepCommon Generic1 n Nothing +makeRep1 n = makeRepCommon Generic1 TypeSynonymRep n Nothing -- | Generates the 'Rep' type synonym constructor (as opposed to 'deriveRep0', -- which generates the type synonym declaration) applied to its type arguments. -- Unlike 'makeRep0', this also takes a quoted 'Type' as an argument, e.g., -- -- @ --- type Rep (Foo a b) = $('makeRep0FromType' ''Foo [t| Foo a b |]) +-- type Rep (Foo (a :: k) b) = $('makeRep0FromType' ''Foo [t| Foo (a :: k) b |]) -- @ +-- +-- Note that the type passed as an argument to 'makeRep0FromType' must match the +-- type argument of 'Rep' exactly, even up to including the explicit kind +-- signature on @a@. This is due to a limitation of Template Haskell—without +-- the kind signature, 'makeRep0FromType' has no way of figuring out the kind of +-- @a@, and the generated type might be completely wrong as a result! +-- +-- The use of 'makeRep0FromType' is generally discouraged, since 'makeRep0Inline' +-- does exactly the same thing but without having to go through an intermediate +-- type synonym, and as a result, 'makeRep0Inline' tends to be less buggy. makeRep0FromType :: Name -> Q Type -> Q Type -makeRep0FromType n = makeRepCommon Generic n . Just +makeRep0FromType n = makeRepCommon Generic TypeSynonymRep n . Just -- | Generates the 'Rep1' type synonym constructor (as opposed to 'deriveRep1', -- which generates the type synonym declaration) applied to its type arguments. -- Unlike 'makeRep1', this also takes a quoted 'Type' as an argument, e.g., -- -- @ --- type Rep1 (Foo a b) = $('makeRep1FromType' ''Foo [t| Foo a b |]) +-- type Rep1 (Foo (a :: k)) = $('makeRep1FromType' ''Foo [t| Foo (a :: k) |]) -- @ +-- +-- Note that the type passed as an argument to 'makeRep1FromType' must match the +-- type argument of 'Rep' exactly, even up to including the explicit kind +-- signature on @a@. This is due to a limitation of Template Haskell—without +-- the kind signature, 'makeRep1FromType' has no way of figuring out the kind of +-- @a@, and the generated type might be completely wrong as a result! +-- +-- The use of 'makeRep1FromType' is generally discouraged, since 'makeRep1Inline' +-- does exactly the same thing but without having to go through an intermediate +-- type synonym, and as a result, 'makeRep1Inline' tends to be less buggy. makeRep1FromType :: Name -> Q Type -> Q Type -makeRep1FromType n = makeRepCommon Generic1 n . Just +makeRep1FromType n = makeRepCommon Generic1 TypeSynonymRep n . Just makeRepCommon :: GenericClass + -> RepOptions -> Name -> Maybe (Q Type) -> Q Type -makeRepCommon gClass n mbQTy = do +makeRepCommon gClass repOpts n mbQTy = do i <- reifyDataInfo n - let (name, _, _, cons, dv) = either error id i - case mbQTy of - Just qTy -> do - ty <- qTy - makeRepTySynApp gClass dv name cons ty - Nothing -> conT $ genRepName gClass dv name + let (name, isNT, declTvbs, cons, dv) = either error id i + -- See Note [Forcing buildTypeInstance] + !_ <- buildTypeInstance gClass False name declTvbs dv + case (mbQTy, repOpts) of + (Just qTy, TypeSynonymRep) -> qTy >>= makeRepTySynApp gClass dv name cons + (Just qTy, InlineRep) -> qTy >>= makeRepInline gClass dv name isNT cons + (Nothing, TypeSynonymRep) -> conT $ genRepName gClass dv name + (Nothing, InlineRep) -> fail "makeRepCommon" + +makeRepInline :: GenericClass + -> DataVariety + -> Name + -> Bool + -> [Con] + -> Type + -> Q Type +makeRepInline gClass dv name isNT cons ty = do + let instVars = map tyVarBndrToType $ tyVarsOfType ty + repType gClass dv name isNT cons instVars + makeRepTySynApp :: GenericClass -> DataVariety -> Name @@ -415,15 +540,15 @@ -- of the LHS of the Rep(1) instance. We call unKindedTV because the kind -- inferencer can figure out the kinds perfectly well, so we don't need to -- give anything here explicit kind signatures. - let instTvbs = nub . map unKindedTV $ visibleTyVarsOfType ty + let instTvbs = nub . map unKindedTV $ requiredTyVarsOfType ty -- We grab the type variables from the first constructor's type signature. -- Or, if there are no constructors, we grab no type variables. The latter -- is okay because we use zipWith to ensure that we never pass more type -- variables than the generated type synonym can accept. -- See Note [Arguments to generated type synonyms] - tySynTvbs <- grabTyVarBndrsFromCons gClass cons + tySynVars <- grabTyVarsFromCons gClass cons return . applyTyToTvbs (genRepName gClass dv name) - $ zipWith const instTvbs tySynTvbs + $ zipWith const instTvbs tySynVars -- | A backwards-compatible synonym for 'makeFrom0'. makeFrom :: Name -> Q Exp @@ -455,7 +580,7 @@ i <- reifyDataInfo n let (name, _, allTvbs, cons, dv) = either error id i -- See Note [Forcing buildTypeInstance] - buildTypeInstance gClass name allTvbs dv + buildTypeInstance gClass False name allTvbs dv `seq` mkCaseExp gClass name cons maker genRepName :: GenericClass -> DataVariety -> Name -> Name @@ -471,12 +596,12 @@ -> Name -> Bool -> [Con] - -> [TyVarBndr] + -> [Type] -> Q Type -repType gClass dv dt isNT cs tySynTvbs = +repType gClass dv dt isNT cs tySynVars = conT d1TypeName `appT` mkMetaDataType dv dt isNT `appT` foldr1' sum' (conT v1TypeName) - (map (repCon gClass dv dt tySynTvbs) cs) + (map (repCon gClass dv dt tySynVars) cs) where sum' :: Q Type -> Q Type -> Q Type sum' a b = conT sumTypeName `appT` a `appT` b @@ -484,35 +609,35 @@ repCon :: GenericClass -> DataVariety -> Name - -> [TyVarBndr] + -> [Type] -> Con -> Q Type -repCon gClass dv dt tySynTvbs (NormalC n bts) = do +repCon gClass dv dt tySynVars (NormalC n bts) = do let bangs = map fst bts ssis <- reifySelStrictInfo n bangs - repConWith gClass dv dt n tySynTvbs Nothing ssis False False -repCon gClass dv dt tySynTvbs (RecC n vbts) = do + repConWith gClass dv dt n tySynVars Nothing ssis False False +repCon gClass dv dt tySynVars (RecC n vbts) = do let (selNames, bangs, _) = unzip3 vbts ssis <- reifySelStrictInfo n bangs - repConWith gClass dv dt n tySynTvbs (Just selNames) ssis True False -repCon gClass dv dt tySynTvbs (InfixC t1 n t2) = do + repConWith gClass dv dt n tySynVars (Just selNames) ssis True False +repCon gClass dv dt tySynVars (InfixC t1 n t2) = do let bangs = map fst [t1, t2] ssis <- reifySelStrictInfo n bangs - repConWith gClass dv dt n tySynTvbs Nothing ssis False True + repConWith gClass dv dt n tySynVars Nothing ssis False True repCon _ _ _ _ con = gadtError con repConWith :: GenericClass -> DataVariety -> Name -> Name - -> [TyVarBndr] + -> [Type] -> Maybe [Name] -> [SelStrictInfo] -> Bool -> Bool -> Q Type -repConWith gClass dv dt n tySynTvbs mbSelNames ssis isRecord isInfix = do - (conTvbs, ts, gk) <- reifyConTys gClass n +repConWith gClass dv dt n tySynVars mbSelNames ssis isRecord isInfix = do + (conVars, ts, gk) <- reifyConTys gClass n let structureType :: Q Type structureType = case ssis of @@ -522,8 +647,8 @@ -- See Note [Substituting types in a constructor type signature] typeSubst :: TypeSubst typeSubst = Map.fromList $ - zip (concatMap tyVarNamesOfTyVarBndr conTvbs) - (concatMap (map VarT . tyVarNamesOfTyVarBndr) tySynTvbs) + zip (concatMap tyVarNamesOfType conVars) + (concatMap (map VarT . tyVarNamesOfType) tySynVars) f :: [Q Type] f = case mbSelNames of @@ -556,7 +681,13 @@ -- See Note [Substituting types in constructor type signatures] t', t'' :: Type t' = case gk of - Gen1 _ (Just kvName) -> substNameWithKind kvName starK t + Gen1 _ (Just _kvName) -> +-- See Note [Generic1 is polykinded on GHC 8.2] +#if __GLASGOW_HASKELL__ >= 801 + t +#else + substNameWithKind _kvName starK t +#endif _ -> t t'' = substType typeSubst t' @@ -805,9 +936,11 @@ | ty == ConT wordHashTypeName = Just (uWordTypeName, uWordDataName, uWordHashValName) | otherwise = Nothing --- | Deduces the instance type to use for a Generic(1) instance. +-- | Deduces the instance type (and kind) to use for a Generic(1) instance. buildTypeInstance :: GenericClass -- ^ Generic or Generic1 + -> KindSigOptions + -- ^ Whether or not to use explicit kind signatures in the instance type -> Name -- ^ The type constructor or data family name -> [TyVarBndr] @@ -815,17 +948,17 @@ -> DataVariety -- ^ If using a data family instance, provides the types used -- to instantiate the instance - -> Q Type + -> Q (Type, Kind) -- Plain data type/newtype case -buildTypeInstance gClass tyConName tvbs DataPlain = +buildTypeInstance gClass useKindSigs tyConName tvbs DataPlain = let varTys :: [Type] varTys = map tyVarBndrToType tvbs - in buildTypeInstanceFromTys gClass tyConName varTys False + in buildTypeInstanceFromTys gClass useKindSigs tyConName varTys -- Data family instance case -- -- The CPP is present to work around a couple of annoying old GHC bugs. -- See Note [Polykinded data families in Template Haskell] -buildTypeInstance gClass parentName tvbs (DataFamily _ instTysAndKinds) = do +buildTypeInstance gClass useKindSigs parentName tvbs (DataFamily _ instTysAndKinds) = do #if !(MIN_VERSION_template_haskell(2,8,0)) || MIN_VERSION_template_haskell(2,10,0) let instTys :: [Type] instTys = zipWith stealKindForType tvbs instTysAndKinds @@ -860,11 +993,11 @@ xTypeNames <- newNameList "tExtra" (length tvbs - length givenTys) let xTys :: [Type] + -- Because these type variables were eta-reduced away, we can only + -- determine their kind by using stealKindForType. Therefore, we mark + -- them as VarT to ensure they will be given an explicit kind annotation + -- (and so the kind inference machinery has the right information). xTys = map VarT xTypeNames - -- ^ Because these type variables were eta-reduced away, we can only - -- determine their kind by using stealKindForType. Therefore, we mark - -- them as VarT to ensure they will be given an explicit kind annotation - -- (and so the kind inference machinery has the right information). substNamesWithKinds :: [(Name, Kind)] -> Type -> Type substNamesWithKinds nks t = foldr' (uncurry substNameWithKind) t nks @@ -884,22 +1017,23 @@ -- grab the correct kind. $ zipWith stealKindForType tvbs (givenTys ++ xTys) #endif - buildTypeInstanceFromTys gClass parentName instTys True + buildTypeInstanceFromTys gClass useKindSigs parentName instTys --- For the given Types, deduces the instance type to use for a Generic(1) instance. --- Coming up with the instance type isn't as simple as dropping the last types, as --- you need to be wary of kinds being instantiated with *. +-- For the given Types, deduces the instance type (and kind) to use for a +-- Generic(1) instance. Coming up with the instance type isn't as simple as +-- dropping the last types, as you need to be wary of kinds being instantiated +-- with *. -- See Note [Type inference in derived instances] buildTypeInstanceFromTys :: GenericClass -- ^ Generic or Generic1 + -> KindSigOptions + -- ^ Whether or not to use explicit kind signatures in the instance type -> Name -- ^ The type constructor or data family name -> [Type] -- ^ The types to instantiate the instance with - -> Bool - -- ^ True if it's a data family, False otherwise - -> Q Type -buildTypeInstanceFromTys gClass tyConName varTysOrig isDataFamily = do + -> Q (Type, Kind) +buildTypeInstanceFromTys gClass useKindSigs tyConName varTysOrig = do -- Make sure to expand through type/kind synonyms! Otherwise, the -- eta-reduction check might get tripped up over type variables in a -- synonym that are actually dropped. @@ -920,35 +1054,30 @@ when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $ derivingKindError tyConName - let droppedKindVarNames :: [Name] - droppedKindVarNames = catKindVarNames droppedStarKindStati - -- Substitute kind * for any dropped kind variables - varTysExpSubst :: [Type] + let varTysExpSubst :: [Type] +-- See Note [Generic1 is polykinded on GHC 8.2] +#if __GLASGOW_HASKELL__ >= 801 + varTysExpSubst = varTysExp +#else varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp - -- We must take care to avoid allowing Generic1 instances where a visible kind - -- binder is instantiated to * (which should only happen in the presence of - -- -XTypeInType). See the documentation for instantiationError for an example - -- of when this can occur. - -- - -- A quick-and-dirty way to accomplish this is to check if the visible type - -- binders of the original type, and of the type post-synonym-expansion, are - -- both the same. If not, it's likely that one of the type binders was - -- instantiated to a specific type (likely *). - when (concatMap visibleTyVarsOfType varTysExp - /= concatMap visibleTyVarsOfType varTysExpSubst) $ - instantiationError tyConName + droppedKindVarNames :: [Name] + droppedKindVarNames = catKindVarNames droppedStarKindStati +#endif let remainingTysExpSubst, droppedTysExpSubst :: [Type] (remainingTysExpSubst, droppedTysExpSubst) = splitAt remainingLength varTysExpSubst +-- See Note [Generic1 is polykinded on GHC 8.2] +#if __GLASGOW_HASKELL__ < 801 -- If any of the dropped types were polykinded, ensure that there are of -- kind * after substituting * for the dropped kind variables. If not, -- throw an error. unless (all hasKindStar droppedTysExpSubst) $ derivingKindError tyConName +#endif -- We now substitute all of the specialized-to-* kind variable names -- with *, but in the original types, not the synonym-expanded types. The reason @@ -966,32 +1095,45 @@ -- Not: -- -- instance C (Fam [Char]) - let remainingTysOrigSubst :: [Type] - remainingTysOrigSubst = + let varTysOrigSubst :: [Type] + varTysOrigSubst = +-- See Note [Generic1 is polykinded on GHC 8.2] +#if __GLASGOW_HASKELL__ >= 801 + id +#else map (substNamesWithKindStar droppedKindVarNames) - $ take remainingLength varTysOrig +#endif + $ varTysOrig + remainingTysOrigSubst, droppedTysOrigSubst :: [Type] + (remainingTysOrigSubst, droppedTysOrigSubst) = + splitAt remainingLength varTysOrigSubst + remainingTysOrigSubst' :: [Type] -- See Note [Kind signatures in derived instances] for an explanation - -- of the isDataFamily check. + -- of the useKindSigs check. remainingTysOrigSubst' = - if isDataFamily + if useKindSigs then remainingTysOrigSubst else map unSigT remainingTysOrigSubst instanceType :: Type instanceType = applyTyToTys (ConT tyConName) remainingTysOrigSubst' + -- See Note [Kind signatures in derived instances] + instanceKind :: Kind + instanceKind = makeFunKind (map typeKind droppedTysOrigSubst) starK + -- Ensure the dropped types can be safely eta-reduced. Otherwise, -- throw an error. unless (canEtaReduce remainingTysExpSubst droppedTysExpSubst) $ etaReductionError instanceType - return instanceType + return (instanceType, instanceKind) -- See Note [Arguments to generated type synonyms] -grabTyVarBndrsFromCons :: GenericClass -> [Con] -> Q [TyVarBndr] -grabTyVarBndrsFromCons _ [] = return [] -grabTyVarBndrsFromCons gClass (con:_) = +grabTyVarsFromCons :: GenericClass -> [Con] -> Q [Type] +grabTyVarsFromCons _ [] = return [] +grabTyVarsFromCons gClass (con:_) = fmap fst3 $ reifyConTys gClass (constructorName con) {- @@ -1030,12 +1172,13 @@ corresponding type variables from the data declaration. There is another obscure case where we need to do a type subtitution. With --XTypeInType enabled, you might have something like this: +-XTypeInType enabled on GHC 8.0, you might have something like this: data Proxy (a :: k) (b :: k) = Proxy k deriving Generic1 Then k gets specialized to *, which means that k should NOT show up in the RHS of a Rep1 type instance! To avoid this, make sure to substitute k with *. +See also Note [Generic1 is polykinded on GHC 8.2]. Note [Arguments to generated type synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1108,33 +1251,77 @@ Note [Kind signatures in derived instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It is possible to put explicit kind signatures into the derived instances, e.g., +We generally include explicit type signatures in derived instances. One reason for +doing so is that in the case of certain data family instances, not including kind +signatures can result in ambiguity. For example, consider the following two data +family instances that are distinguished by their kinds: - instance C a => C (Data (f :: * -> *)) where ... + data family Fam (a :: k) + data instance Fam (a :: * -> *) + data instance Fam (a :: *) -But it is preferable to avoid this if possible. If we come up with an incorrect -kind signature (which is entirely possible, since our type inferencer is pretty -unsophisticated - see Note [Type inference in derived instances]), then GHC will -flat-out reject the instance, which is quite unfortunate. +If we dropped the kind signature for a in a derived instance for Fam a, then GHC +would have no way of knowing which instance we are talking about. -Plain old datatypes have the advantage that you can avoid using any kind signatures -at all in their instances. This is because a datatype declaration uses all type -variables, so the types that we use in a derived instance uniquely determine their -kinds. As long as we plug in the right types, the kind inferencer can do the rest -of the work. For this reason, we use unSigT to remove all kind signatures before -splicing in the instance context and head. +Another motivation for explicit kind signatures is the -XTypeInType extension. +With -XTypeInType, dropping kind signatures can completely change the meaning +of some data types. For example, there is a substantial difference between these +two data types: -Data family instances are trickier, since a data family can have two instances that -are distinguished by kind alone, e.g., + data T k (a :: k) = T k + data T k a = T k - data family Fam (a :: k) - data instance Fam (a :: * -> *) - data instance Fam (a :: *) +In addition to using explicit kind signatures on type variables, we also put +explicit return kinds in the instance head, so generated instances will look +something like this: -If we dropped the kind signatures for C (Fam a), then GHC will have no way of -knowing which instance we are talking about. To avoid this scenario, we always -include explicit kind signatures in data family instances. There is a chance that -the inferred kind signatures will be incorrect, but if so, we can always fall back -on the make- functions. + data S (a :: k) = S k + instance Generic1 (S :: k -> *) where + type Rep1 (S :: k -> *) = ... (Rec0 k) +Why do we do this? Imagine what the instance would be without the explicit return kind: + + instance Generic1 S where + type Rep1 S = ... (Rec0 k) + +This is an error, since the variable k is now out-of-scope! + +Although explicit kind signatures are the right thing to do in most cases, there +are sadly some degenerate cases where this isn't true. Consider this example: + + newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) = Compose (f (g a)) + +The Rep1 type instance in a Generic1 instance for Compose would involve the type +(f :.: Rec1 g), which forces (f :: * -> *). But this library doesn't have very +sophisticated kind inference machinery (other than what is mentioned in +Note [Substituting types in constructor type signatures]), so at the moment we +have no way of actually unifying k1 with *. So the naïve generated Generic1 +instance would be: + + instance Generic1 (Compose (f :: k2 -> *) (g :: k1 -> k2)) where + type Rep1 (Compose f g) = ... (f :.: Rec1 g) + +This is wrong, since f's kind is overly generalized. To get around this issue, +there are variants of the TH functions that allow you to configure the KindSigOptions. +If KindSigOptions is set to False, then generated instances will not include +explicit kind signatures, leaving it up to GHC's kind inference machinery to +figure out the correct kinds. + +Note [Generic1 is polykinded on GHC 8.2] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Prior to GHC 8.2, Generic1 :: (* -> *) -> Constraint. This means that if a Generic1 +instance is defined for a polykinded data type like so: + + data Proxy k (a :: k) = Proxy + +Then k is unified with *, and this has an effect on the generated Generic1 instance: + + instance Generic1 (Proxy *) where ... + +We must take great care to ensure that all occurrences of k are substituted with *, +or else the generated instance will be ill kinded. + +On GHC 8.2 and later, Generic1 :: (k -> *) -> Constraint. This means we don't have +to do this kind unification anymore! Hooray! -} diff --git a/src/Generics/Deriving/TH/Internal.hs b/src/Generics/Deriving/TH/Internal.hs --- a/src/Generics/Deriving/TH/Internal.hs +++ b/src/Generics/Deriving/TH/Internal.hs @@ -105,16 +105,17 @@ substNamesWithKindStar :: [Name] -> Type -> Type substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns -substTyVarBndrKind :: KindSubst -> TyVarBndr -> TyVarBndr -substTyVarBndrKind _subs (KindedTV n k) = KindedTV n $ +substTyVarBndrType :: TypeSubst -> TyVarBndr -> Type +substTyVarBndrType subs = substType subs . tyVarBndrToType + +substTyVarBndrKind :: KindSubst -> TyVarBndr -> Type #if MIN_VERSION_template_haskell(2,8,0) - substKind _subs k +substTyVarBndrKind = substTyVarBndrType #else - k +substTyVarBndrKind _ = tyVarBndrToType #endif -substTyVarBndrKind _ tvb = tvb -substNameWithKindStarInTyVarBndr :: Name -> TyVarBndr -> TyVarBndr +substNameWithKindStarInTyVarBndr :: Name -> TyVarBndr -> Type substNameWithKindStarInTyVarBndr n = substTyVarBndrKind (Map.singleton n starK) ------------------------------------------------------------------------------- @@ -162,10 +163,6 @@ #endif hasKindStar _ = False -tyVarNamesOfTyVarBndr :: TyVarBndr -> [Name] -tyVarNamesOfTyVarBndr (PlainTV n) = [n] -tyVarNamesOfTyVarBndr (KindedTV n k) = n:kindVarNamesOfKind k - -- | Gets all of the type/kind variable names mentioned somewhere in a Type. tyVarNamesOfType :: Type -> [Name] tyVarNamesOfType = go @@ -179,19 +176,24 @@ go (VarT n) = [n] go _ = [] --- | Gets all of the kind variable names mentioned somewhere in a Kind. -kindVarNamesOfKind :: Kind -> [Name] +-- | Gets all of the type/kind variable binders mentioned in a Type. +tyVarsOfType :: Type -> [TyVarBndr] +tyVarsOfType = go + where + go :: Type -> [TyVarBndr] + go (AppT t1 t2) = go t1 ++ go t2 + go (SigT t _k) = go t #if MIN_VERSION_template_haskell(2,8,0) -kindVarNamesOfKind = tyVarNamesOfType -#else -kindVarNamesOfKind _ = [] -- There are no kind variables + ++ go _k #endif + go (VarT n) = [PlainTV n] + go _ = [] --- | Gets all of the specified type/kind variable names mentioned in a Type. In --- contrast to 'tyVarNamesOfType', 'visibleTyVarsOfType' does not go into kinds +-- | Gets all of the required type/kind variable binders mentioned in a Type. In +-- contrast to 'tyVarsOfType', 'requiredTyVarsOfType' does not go into kinds -- of 'SigT's. -visibleTyVarsOfType :: Type -> [TyVarBndr] -visibleTyVarsOfType = go +requiredTyVarsOfType :: Type -> [TyVarBndr] +requiredTyVarsOfType = go where go :: Type -> [TyVarBndr] go (AppT t1 t2) = go t1 ++ go t2 @@ -199,6 +201,50 @@ go (VarT n) = [PlainTV n] go _ = [] +-- | Converts a VarT or a SigT into Just the corresponding TyVarBndr. +-- Converts other Types to Nothing. +typeToTyVarBndr :: Type -> Maybe TyVarBndr +typeToTyVarBndr (VarT n) = Just (PlainTV n) +typeToTyVarBndr (SigT (VarT n) k) = Just (KindedTV n k) +typeToTyVarBndr _ = Nothing + +-- | If a Type is a SigT, returns its kind signature. Otherwise, return *. +typeKind :: Type -> Kind +typeKind (SigT _ k) = k +typeKind _ = starK + +-- | Turns +-- +-- @ +-- [a, b] c +-- @ +-- +-- into +-- +-- @ +-- a -> b -> c +-- @ +makeFunType :: [Type] -> Type -> Type +makeFunType argTys resTy = foldr' (AppT . AppT ArrowT) resTy argTys + +-- | Turns +-- +-- @ +-- [k1, k2] k3 +-- @ +-- +-- into +-- +-- @ +-- k1 -> k2 -> k3 +-- @ +makeFunKind :: [Kind] -> Kind -> Kind +#if MIN_VERSION_template_haskell(2,8,0) +makeFunKind = makeFunType +#else +makeFunKind argKinds resKind = foldr' ArrowK resKind argKinds +#endif + -- | Is the given type a type family constructor (and not a data family constructor)? isTyFamily :: Type -> Q Bool isTyFamily (ConT n) = do @@ -357,14 +403,6 @@ go VarT{} = False go _ = True --- | Returns 'True' is a 'Kind' contains no kind variables. -isKindMonomorphic :: Kind -> Bool -#if MIN_VERSION_template_haskell(2,8,0) -isKindMonomorphic = isTypeMonomorphic -#else -isKindMonomorphic _ = True -- There are no kind variables -#endif - -- | Peel off a kind signature from a Type (if it has one). unSigT :: Type -> Type unSigT (SigT t _) = t @@ -456,11 +494,12 @@ data GenericKind = Gen0 | Gen1 Name (Maybe Name) --- Determines the universally quantified type variables, the types of a constructor's +-- Determines the universally quantified type variables (possibly after +-- substituting * in the case of Generic1), the types of a constructor's -- arguments, and the last type parameter name (if there is one). reifyConTys :: GenericClass -> Name - -> Q ([TyVarBndr], [Type], GenericKind) + -> Q ([Type], [Type], GenericKind) reifyConTys gClass conName = do info <- reify conName let (tvbs, uncTy) = case info of @@ -479,43 +518,48 @@ -- -- which you'd only be able to tell was legal if you expand Constant a b to a! resTyExp <- expandSyn resTy - let numResTyVars = length . nub $ visibleTyVarsOfType resTyExp - -- ^ We need to grab a number of type variables from the constructor's + let numResTyVars = length . nub $ requiredTyVarsOfType resTyExp + -- We need to grab a number of types from the constructor's -- type signature to re-use for the Rep(1) type synonym's type variable -- binders. As it turns out, that number is equal to the number of distinct -- type variables which appear in the result type. -- - -- We assume that the visible type variables all come last in the list + -- We assume that the required types all come last in the list -- of forall'd type variables. I suppose nothing guarantees this, but -- this seems to always be the case via experimentation. Fingers crossed. - -- TODO: This doesn't work with -XTypeInType and data families - visibleTvbs = drop (length tvbs - numResTyVars) tvbs - let (visibleTvbs', gk) = case gClass of - Generic -> (visibleTvbs, Gen0) + requiredTvbs = drop (length tvbs - numResTyVars) tvbs + let (requiredTyVars', gk) = case gClass of + Generic -> (map tyVarBndrToType requiredTvbs, Gen0) Generic1 -> -- If deriving Generic1 and the last type variable is polykinded, -- make sure to substitute that kind with * in the other type -- variable binders' kind signatures - let headVisibleTvbs :: [TyVarBndr] - lastVisibleTvb :: TyVarBndr - (headVisibleTvbs, [lastVisibleTvb]) = - splitAt (length visibleTvbs - 1) visibleTvbs + let headRequiredTvbs :: [TyVarBndr] + lastRequiredTvb :: TyVarBndr + (headRequiredTvbs, [lastRequiredTvb]) = + splitAt (length requiredTvbs - 1) requiredTvbs mbLastArgKindName :: Maybe Name mbLastArgKindName = starKindStatusToName . canRealizeKindStar - $ tyVarBndrToType lastVisibleTvb + $ tyVarBndrToType lastRequiredTvb - visibleTvbsSubst :: [TyVarBndr] - visibleTvbsSubst = + requiredTyVars :: [Type] + requiredTyVars = case mbLastArgKindName of - Nothing -> headVisibleTvbs - Just lakn -> map (substNameWithKindStarInTyVarBndr lakn) - headVisibleTvbs - in ( visibleTvbsSubst - , Gen1 (tyVarBndrName lastVisibleTvb) mbLastArgKindName + Nothing -> map tyVarBndrToType headRequiredTvbs + Just _lakn -> +-- See Note [Generic1 is polykinded on GHC 8.2] in Generics.Deriving.TH +#if __GLASGOW_HASKELL__ >= 801 + map tyVarBndrToType headRequiredTvbs +#else + map (substNameWithKindStarInTyVarBndr _lakn) + headRequiredTvbs +#endif + in ( requiredTyVars + , Gen1 (tyVarBndrName lastRequiredTvb) mbLastArgKindName ) - return (visibleTvbs', argTys, gk) + return (requiredTyVars', argTys, gk) -- | Indicates whether Generic(1) is being derived for a plain data type (DataPlain) -- or a data family instance (DataFamily). DataFamily bundles the Name of the data @@ -576,21 +620,6 @@ -- when deriving Generic(1) rankNError :: a rankNError = error "Cannot have polymorphic arguments" - --- | Cannot have a Generic(1) instance where the instance head's type is instantiated --- to be a more "saturated" type than the original data declaration. That means --- something like this would be rejected: --- --- @ --- {-# LANGUAGE TypeInType #-} --- data Hm k (a :: k) deriving Generic1 --- @ --- --- Since having a Generic1 instance would force k to be instantiated with *, --- resulting in an instance Generic1 (Hm *) instead of instance Generic1 (Hm k). -instantiationError :: Name -> a -instantiationError tyConName = error $ - nameBase tyConName ++ " must not be instantiated" -- | Boilerplate for top level splices. --