diff options
| author | Matthew Pickering <matthewtpickering@gmail.com> | 2021-11-30 17:05:11 +0000 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-01-29 02:41:21 -0500 |
| commit | 268efcc9a45da36458442d9203c66a415b48f2b3 (patch) | |
| tree | 8d99c80c3ebf68cd91c4262573a1a8634863f90a | |
| parent | bb15c34784a3143ef048807fd351667d6775e399 (diff) | |
| download | haskell-268efcc9a45da36458442d9203c66a415b48f2b3.tar.gz | |
Rework the handling of SkolemInfo
The main purpose of this patch is to attach a SkolemInfo directly to
each SkolemTv. This fixes the large number of bugs which have
accumulated over the years where we failed to report errors due to
having "no skolem info" for particular type variables. Now the origin of
each type varible is stored on the type variable we can always report
accurately where it cames from.
Fixes #20969 #20732 #20680 #19482 #20232 #19752 #10946
#19760 #20063 #13499 #14040
The main changes of this patch are:
* SkolemTv now contains a SkolemInfo field which tells us how the
SkolemTv was created. Used when reporting errors.
* Enforce invariants relating the SkolemInfoAnon and level of an implication (ic_info, ic_tclvl)
to the SkolemInfo and level of the type variables in ic_skols.
* All ic_skols are TcTyVars -- Check is currently disabled
* All ic_skols are SkolemTv
* The tv_lvl of the ic_skols agrees with the ic_tclvl
* The ic_info agrees with the SkolInfo of the implication.
These invariants are checked by a debug compiler by
checkImplicationInvariants.
* Completely refactor kcCheckDeclHeader_sig which kept
doing my head in. Plus, it wasn't right because it wasn't skolemising
the binders as it decomposed the kind signature.
The new story is described in Note [kcCheckDeclHeader_sig]. The code
is considerably shorter than before (roughly 240 lines turns into 150
lines).
It still has the same awkward complexity around computing arity as
before, but that is a language design issue.
See Note [Arity inference in kcCheckDeclHeader_sig]
* I added new type synonyms MonoTcTyCon and PolyTcTyCon, and used
them to be clear which TcTyCons have "finished" kinds etc, and
which are monomorphic. See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon]
* I renamed etaExpandAlgTyCon to splitTyConKind, becuase that's a
better name, and it is very useful in kcCheckDeclHeader_sig, where
eta-expansion isn't an issue.
* Kill off the nasty `ClassScopedTvEnv` entirely.
Co-authored-by: Simon Peyton Jones <simon.peytonjones@gmail.com>
116 files changed, 2371 insertions, 1405 deletions
diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs index f54d364359..656b5addae 100644 --- a/compiler/GHC/Core/Coercion.hs +++ b/compiler/GHC/Core/Coercion.hs @@ -1772,7 +1772,8 @@ composeSteppers step1 step2 rec_nts tc tys unwrapNewTypeStepper :: NormaliseStepper Coercion unwrapNewTypeStepper rec_nts tc tys | Just (ty', co) <- instNewTyCon_maybe tc tys - = case checkRecTc rec_nts tc of + = -- pprTrace "unNS" (ppr tc <+> ppr (getUnique tc) <+> ppr tys $$ ppr ty' $$ ppr rec_nts) $ + case checkRecTc rec_nts tc of Just rec_nts' -> NS_Step rec_nts' ty' co Nothing -> NS_Abort @@ -1796,6 +1797,8 @@ topNormaliseTypeX :: NormaliseStepper ev -> Type -> Maybe (ev, Type) topNormaliseTypeX stepper plus ty | Just (tc, tys) <- splitTyConApp_maybe ty + -- SPJ: The default threshold for initRecTc is 100 which is extremely dangerous + -- for certain type synonyms, we should think about reducing it (see #20990) , NS_Step rec_nts ty' ev <- stepper initRecTc tc tys = go rec_nts ev ty' | otherwise diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs index 31c8813e10..fae7c7de19 100644 --- a/compiler/GHC/Core/TyCo/Rep.hs +++ b/compiler/GHC/Core/TyCo/Rep.hs @@ -1051,7 +1051,7 @@ mkForAllTys tyvars ty = foldr ForAllTy ty tyvars -- | Wraps foralls over the type using the provided 'InvisTVBinder's from left to right mkInvisForAllTys :: [InvisTVBinder] -> Type -> Type -mkInvisForAllTys tyvars ty = foldr ForAllTy ty $ tyVarSpecToBinders tyvars +mkInvisForAllTys tyvars = mkForAllTys (tyVarSpecToBinders tyvars) mkPiTy :: TyCoBinder -> Type -> Type mkPiTy (Anon af ty1) ty2 = mkScaledFunTy af ty1 ty2 diff --git a/compiler/GHC/Core/TyCo/Tidy.hs b/compiler/GHC/Core/TyCo/Tidy.hs index 97d3adf8e0..36f1bb015a 100644 --- a/compiler/GHC/Core/TyCo/Tidy.hs +++ b/compiler/GHC/Core/TyCo/Tidy.hs @@ -56,7 +56,7 @@ tidyVarBndr tidy_env@(occ_env, subst) var avoidNameClashes :: [TyCoVar] -> TidyEnv -> TidyEnv -- Seed the occ_env with clashes among the names, see --- Note [Tidying multiple names at once] in GHC.Types.Names.OccName +-- Note [Tidying multiple names at once] in GHC.Types.Name.Occurrence avoidNameClashes tvs (occ_env, subst) = (avoidClashesOccEnv occ_env occs, subst) where diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs index 18a01226d7..7c4ad2dfcf 100644 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -25,7 +25,7 @@ module GHC.Core.TyCon( mkRequiredTyConBinder, mkAnonTyConBinder, mkAnonTyConBinders, tyConBinderArgFlag, tyConBndrVisArgFlag, isNamedTyConBinder, - isVisibleTyConBinder, isInvisibleTyConBinder, + isVisibleTyConBinder, isInvisibleTyConBinder, isVisibleTcbVis, -- ** Field labels tyConFieldLabels, lookupTyConFieldLabel, @@ -640,6 +640,8 @@ They fit together like so: Note that there are three binders here, including the kind variable k. + See Note [tyConBinders and lexical scoping] + * See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep for what the visibility flag means. @@ -668,7 +670,47 @@ They fit together like so: * For an algebraic data type, or data instance, the tyConResKind is always (TYPE r); that is, the tyConBinders are enough to saturate the type constructor. I'm not quite sure why we have this invariant, - but it's enforced by etaExpandAlgTyCon + but it's enforced by splitTyConKind + +Note [tyConBinders and lexical scoping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a TyCon, and a PolyTcTyCon, we obey the following rule: + + The Name of the TyConBinder is precisely + the lexically scoped Name from the original declaration + (precisely = both OccName and Unique) + +For example, + data T a (b :: wombat) = MkT +We will get tyConBinders of [k, wombat, a::k, b::wombat] +The 'k' is made up; the user didn't specify it. But for the kind of 'b' +we must use 'wombat'. + +Why do we have this invariant? + +* Similarly, when typechecking default definitions for class methods, in + GHC.Tc.TyCl.Class.tcClassDecl2, we only have the (final) Class available; + but the variables bound in that class must be in scope. Eample (#19738): + + type P :: k -> Type + data P a = MkP + + type T :: k -> Constraint + class T (a :: j) where + f :: P a + f = MkP @j @a -- 'j' must be in scope when we typecheck 'f' + +* When typechecking `deriving` clauses for top-level data declarations, the + tcTyConScopedTyVars are brought into scope in through the `di_scoped_tvs` + field of GHC.Tc.Deriv.DerivInfo. Example (#16731): + + class C x1 x2 + + type T :: a -> Type + data T (x :: z) deriving (C z) + + When typechecking `C z`, we want `z` to map to `a`, which is exactly what the + tcTyConScopedTyVars for T give us. -} instance OutputableBndr tv => Outputable (VarBndr tv TyConBndrVis) where @@ -727,7 +769,7 @@ data TyCon tyConName :: Name, -- ^ Name of the constructor -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders + tyConBinders :: [TyConBinder], -- ^ Full binders tyConResKind :: Kind, -- ^ Result kind tyConKind :: Kind, -- ^ Kind of this TyCon tyConArity :: Arity, -- ^ Arity @@ -947,15 +989,18 @@ data TyCon -- arguments to the type constructor; see the use -- of tyConArity in generaliseTcTyCon - tcTyConScopedTyVars :: [(Name,TyVar)], + tcTyConScopedTyVars :: [(Name,TcTyVar)], -- ^ Scoped tyvars over the tycon's body - -- See Note [Scoped tyvars in a TcTyCon] + -- The range is always a skolem or TcTyVar, be + -- MonoTcTyCon only: see Note [Scoped tyvars in a TcTyCon] tcTyConIsPoly :: Bool, -- ^ Is this TcTyCon already generalized? + -- Used only to make zonking more efficient tcTyConFlavour :: TyConFlavour -- ^ What sort of 'TyCon' this represents. } + {- Note [Scoped tyvars in a TcTyCon] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The tcTyConScopedTyVars field records the lexicial-binding connection @@ -970,37 +1015,8 @@ where * required_tvs the same as tyConTyVars * tyConArity = length required_tvs -There are some situations where we need to keep the tcTyConScopedTyVars around -for later use, even after the TcTyCon has been zonked away: - -* When typechecking `deriving` clauses for top-level data declarations, the - tcTyConScopedTyVars are brought into scope in through the `di_scoped_tvs` - field of GHC.Tc.Deriv.DerivInfo. Example (#16731): - - class C x1 x2 - - type T :: a -> Type - data T (x :: z) deriving (C z) - - When typechecking `C z`, we want `z` to map to `a`, which is exactly what the - tcTyConScopedTyVars for T give us. - -* Similarly, when typechecking default definitions for class methods, the - tcTyConScopedTyVars ought to be brought into scope. Example (#19738): - - type P :: k -> Type - data P a = MkP - - type T :: k -> Constraint - class T (a :: j) where - f :: P a - f = MkP @j @a - - We pass the tcTyConScopedTyVars to GHC.Tc.TyCl.Class.tcClassDecl2, the - function responsible for typechecking the default definition of `f`, by way - of a ClassScopedTVEnv, which maps each class name to its scoped tyvars. - -See also Note [How TcTyCons work] in GHC.Tc.TyCl +tcTyConScopedTyVars are used only for MonoTcTyCons, not PolyTcTyCons. +See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.Utils.TcType. Note [Promoted GADT data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Data/IOEnv.hs b/compiler/GHC/Data/IOEnv.hs index 33cd0ed61e..836ca856d0 100644 --- a/compiler/GHC/Data/IOEnv.hs +++ b/compiler/GHC/Data/IOEnv.hs @@ -61,7 +61,8 @@ import Control.Concurrent (forkIO, killThread) newtype IOEnv env a = IOEnv' (env -> IO a) - deriving (MonadThrow, MonadCatch, MonadMask) via (ReaderT env IO) + deriving (MonadThrow, MonadCatch, MonadMask, MonadFix) via (ReaderT env IO) + -- See Note [The one-shot state monad trick] in GHC.Utils.Monad instance Functor (IOEnv env) where diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index 343f021a45..b99ffe905a 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -1060,7 +1060,7 @@ getDictionaryBindings :: PredType -> TcM CtEvidence getDictionaryBindings theta = do dictName <- newName (mkDictOcc (mkVarOcc "magic")) let dict_var = mkVanillaGlobal dictName theta - loc <- getCtLocM (GivenOrigin UnkSkol) Nothing + loc <- getCtLocM (GivenOrigin (getSkolemInfo unkSkol)) Nothing -- Generate a wanted here because at the end of constraint -- solving, most derived constraints get thrown away, which in certain diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs index e1a688cd55..afae21e9d7 100644 --- a/compiler/GHC/Tc/Deriv.hs +++ b/compiler/GHC/Tc/Deriv.hs @@ -439,6 +439,7 @@ makeDerivSpecs :: [DerivInfo] -> TcM [EarlyDerivSpec] makeDerivSpecs deriv_infos deriv_decls = do { eqns1 <- sequenceA + -- MP: scoped_tvs here magically converts TyVar into TcTyVar [ deriveClause rep_tc scoped_tvs dcs (deriv_clause_preds dct) err_ctxt | DerivInfo { di_rep_tc = rep_tc , di_scoped_tvs = scoped_tvs @@ -633,6 +634,8 @@ deriveStandalone (L loc (DerivDecl _ deriv_ty mb_lderiv_strat overlap_mode)) ; traceTc "Deriving strategy (standalone deriving)" $ vcat [ppr mb_lderiv_strat, ppr deriv_ty] ; (mb_lderiv_strat, via_tvs) <- tcDerivStrategy mb_lderiv_strat + ; traceTc "Deriving strategy (standalone deriving) 2" $ + vcat [ppr mb_lderiv_strat, ppr via_tvs] ; (cls_tvs, deriv_ctxt, cls, inst_tys) <- tcExtendTyVarEnv via_tvs $ tcStandaloneDerivInstType ctxt deriv_ty diff --git a/compiler/GHC/Tc/Deriv/Infer.hs b/compiler/GHC/Tc/Deriv/Infer.hs index f5f9e9d9ba..db54c9bab4 100644 --- a/compiler/GHC/Tc/Deriv/Infer.hs +++ b/compiler/GHC/Tc/Deriv/Infer.hs @@ -718,14 +718,14 @@ simplifyDeriv :: PredType -- ^ @C inst_ty@, head of the instance we are -> TcM ThetaType -- ^ Needed constraints (after simplification), -- i.e. @['PredType']@. simplifyDeriv pred tvs thetas - = do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize + = do { skol_info <- mkSkolemInfo (DerivSkol pred) + ; (skol_subst, tvs_skols) <- tcInstSkolTyVars skol_info tvs -- Skolemize -- The constraint solving machinery -- expects *TcTyVars* not TyVars. -- We use *non-overlappable* (vanilla) skolems -- See Note [Overlap and deriving] ; let skol_set = mkVarSet tvs_skols - skol_info = DerivSkol pred doc = text "deriving" <+> parens (ppr pred) mk_given_ev :: PredType -> TcM EvVar @@ -766,7 +766,7 @@ simplifyDeriv pred tvs thetas = do { ac_given_evs <- mapM mk_given_ev ac_givens ; (_, wanteds) <- captureConstraints $ - checkConstraints skol_info ac_skols ac_given_evs $ + checkConstraints (getSkolemInfo skol_info) ac_skols ac_given_evs $ -- The checkConstraints bumps the TcLevel, and -- wraps the wanted constraints in an implication, -- when (but only when) necessary @@ -841,7 +841,7 @@ simplifyDeriv pred tvs thetas -- forall tvs. min_theta => solved_wanteds ; min_theta_vars <- mapM newEvVar min_theta ; (leftover_implic, _) - <- buildImplicationFor tc_lvl skol_info tvs_skols + <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) tvs_skols min_theta_vars solved_wanteds -- This call to simplifyTop is purely for error reporting -- See Note [Error reporting for deriving clauses] diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs index 2036e98300..91a11c9af6 100644 --- a/compiler/GHC/Tc/Deriv/Utils.hs +++ b/compiler/GHC/Tc/Deriv/Utils.hs @@ -507,13 +507,18 @@ mkPredOrigin origin t_or_k pred = PredOrigin pred origin t_or_k mkThetaOrigin :: CtOrigin -> TypeOrKind -> [TyVar] -> [TyVar] -> ThetaType -> ThetaType -> ThetaOrigin -mkThetaOrigin origin t_or_k skols metas givens - = ThetaOrigin skols metas givens . map (mkPredOrigin origin t_or_k) +mkThetaOrigin origin t_or_k skols metas givens wanteds + = ThetaOrigin { to_anyclass_skols = skols + , to_anyclass_metas = metas + , to_anyclass_givens = givens + , to_wanted_origins = map (mkPredOrigin origin t_or_k) wanteds } -- A common case where the ThetaOrigin only contains wanted constraints, with -- no givens or locally scoped type variables. mkThetaOriginFromPreds :: [PredOrigin] -> ThetaOrigin -mkThetaOriginFromPreds = ThetaOrigin [] [] [] +mkThetaOriginFromPreds origins + = ThetaOrigin { to_anyclass_skols = [], to_anyclass_metas = [] + , to_anyclass_givens = [], to_wanted_origins = origins } substPredOrigin :: HasCallStack => TCvSubst -> PredOrigin -> PredOrigin substPredOrigin subst (PredOrigin pred origin t_or_k) diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index b08fd6b3a8..2901078004 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -6,6 +6,8 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ParallelListComp #-} module GHC.Tc.Errors( reportUnsolved, reportAllUnsolved, warnAllUnsolved, @@ -49,6 +51,7 @@ import GHC.Types.Name.Env import GHC.Types.SrcLoc import GHC.Types.Basic import GHC.Types.Error +import qualified GHC.Types.Unique.Map as UM --import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) ) import GHC.Unit.Module @@ -79,9 +82,13 @@ import Control.Monad ( unless, when, foldM, forM_ ) import Data.Foldable ( toList ) import Data.Functor ( (<&>) ) import Data.Function ( on ) -import Data.List ( partition, mapAccumL ) +import Data.List ( partition, mapAccumL, sort ) import Data.List.NonEmpty ( NonEmpty(..), (<|) ) import qualified Data.List.NonEmpty as NE ( map, reverse ) +import Data.List ( sortBy ) +import Data.Ord ( comparing ) +import GHC.Tc.Errors.Ppr + {- ************************************************************************ @@ -215,6 +222,7 @@ report_unsolved type_errors expr_holes ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted) ; wanted <- zonkWC wanted -- Zonk to reveal all information + ; let tidy_env = tidyFreeTyCoVars emptyTidyEnv free_tvs free_tvs = filterOut isCoVar $ tyCoVarsOfWCList wanted @@ -322,11 +330,12 @@ previously suppressed. (e.g. partial-sigs/should_fail/T14584) -} reportImplic :: ReportErrCtxt -> Implication -> TcM () -reportImplic ctxt implic@(Implic { ic_skols = tvs - , ic_given = given +reportImplic ctxt implic@(Implic { ic_skols = tvs + , ic_given = given , ic_wanted = wanted, ic_binds = evb , ic_status = status, ic_info = info - , ic_tclvl = tc_lvl }) + , ic_env = tcl_env + , ic_tclvl = tc_lvl }) | BracketSkol <- info , not insoluble = return () -- For Template Haskell brackets report only @@ -335,7 +344,11 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs -- certainly be un-satisfied constraints | otherwise - = do { traceTc "reportImplic" (ppr implic') + = do { traceTc "reportImplic" $ vcat + [ text "tidy env:" <+> ppr (cec_tidy ctxt) + , text "skols: " <+> pprTyVars tvs + , text "tidy skols:" <+> pprTyVars tvs' ] + ; when bad_telescope $ reportBadTelescope ctxt tcl_env info tvs -- Do /not/ use the tidied tvs because then are in the -- wrong order, so tidying will rename things wrongly @@ -343,7 +356,6 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs ; when (cec_warn_redundant ctxt) $ warnRedundantConstraints ctxt' tcl_env info' dead_givens } where - tcl_env = ic_env implic insoluble = isInsolubleStatus status (env1, tvs') = mapAccumL tidyVarBndr (cec_tidy ctxt) $ scopedSort tvs @@ -351,7 +363,7 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs -- (see Note [Skolems in an implication] in GHC.Tc.Types.Constraint) -- but tidying goes wrong on out-of-order constraints; -- so we sort them here before tidying - info' = tidySkolemInfo env1 info + info' = tidySkolemInfoAnon env1 info implic' = implic { ic_skols = tvs' , ic_given = map (tidyEvVar env1) given , ic_info = info' } @@ -376,7 +388,7 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs IC_BadTelescope -> True _ -> False -warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [EvVar] -> TcM () +warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [EvVar] -> TcM () -- See Note [Tracking redundant constraints] in GHC.Tc.Solver warnRedundantConstraints ctxt env info ev_vars | null redundant_evs @@ -417,7 +429,7 @@ warnRedundantConstraints ctxt env info ev_vars improving pred -- (transSuperClasses p) does not include p = any isImprovementPred (pred : transSuperClasses pred) -reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [TcTyVar] -> TcM () +reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [TcTyVar] -> TcM () reportBadTelescope ctxt env (ForAllSkol telescope) skols = do { msg <- mkErrorReport env @@ -1198,10 +1210,10 @@ mkHoleError lcl_name_cache tidy_simples ctxt ; (ctxt, hole_fits) <- if show_valid_hole_fits then validHoleFits ctxt tidy_simples hole else return (ctxt, noValidHoleFits) - + ; (grouped_skvs, other_tvs) <- zonkAndGroupSkolTvs hole_ty ; let reason | ExprHole _ <- sort = cec_expr_holes ctxt | otherwise = cec_type_holes ctxt - errs = [ReportWithCtxt ctxt $ ReportHoleError hole $ HoleError sort] + errs = [ReportWithCtxt ctxt $ ReportHoleError hole $ HoleError sort other_tvs grouped_skvs] supp = [ SupplementaryBindings rel_binds , SupplementaryCts relevant_cts , SupplementaryHoleFits hole_fits ] @@ -1214,6 +1226,21 @@ mkHoleError lcl_name_cache tidy_simples ctxt where lcl_env = ctLocEnv ct_loc +-- | For all the skolem type variables in a type, zonk the skolem info and group together +-- all the type variables with the same origin. +zonkAndGroupSkolTvs :: Type -> TcM ([(SkolemInfoAnon, [TcTyVar])], [TcTyVar]) +zonkAndGroupSkolTvs hole_ty = do + zonked_info <- mapM (\(sk, tv) -> (,) <$> (zonkSkolemInfoAnon . getSkolemInfo $ sk) <*> pure (fst <$> tv)) skolem_list + return (zonked_info, other_tvs) + where + tvs = tyCoVarsOfTypeList hole_ty + (skol_tvs, other_tvs) = partition (\tv -> isTcTyVar tv && isSkolemTyVar tv) tvs + + group_skolems :: UM.UniqMap SkolemInfo ([(TcTyVar, Int)]) + group_skolems = bagToList <$> UM.listToUniqMap_C unionBags [(skolemSkolInfo tv, unitBag (tv, n)) | tv <- skol_tvs | n <- [0..]] + + skolem_list = sortBy (comparing (sort . map snd . snd)) (UM.nonDetEltsUniqMap group_skolems) + {- Note [Adding deferred bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1459,32 +1486,34 @@ mkTyVarEqErr :: ReportErrCtxt -> Ct mkTyVarEqErr ctxt ct tv1 ty2 = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2) ; dflags <- getDynFlags - ; return $ mkTyVarEqErr' dflags ctxt ct tv1 ty2 } + ; mkTyVarEqErr' dflags ctxt ct tv1 ty2 } mkTyVarEqErr' :: DynFlags -> ReportErrCtxt -> Ct - -> TcTyVar -> TcType -> (AccReportMsgs, [GhcHint]) + -> TcTyVar -> TcType -> TcM (AccReportMsgs, [GhcHint]) mkTyVarEqErr' dflags ctxt ct tv1 ty2 -- impredicativity is a simple error to understand; try it first - | check_eq_result `cterHasProblem` cteImpredicative - , let + | check_eq_result `cterHasProblem` cteImpredicative = do + tyvar_eq_info <- extraTyVarEqInfo tv1 ty2 + let poly_msg = CannotUnifyWithPolytype ct tv1 ty2 - tyvar_eq_info = extraTyVarEqInfo tv1 ty2 poly_msg_with_info | isSkolemTyVar tv1 = mkTcReportWithInfo poly_msg tyvar_eq_info | otherwise = poly_msg - = -- Unlike the other reports, this discards the old 'report_important' + -- Unlike the other reports, this discards the old 'report_important' -- instead of augmenting it. This is because the details are not likely -- to be helpful since this is just an unimplemented feature. - (poly_msg_with_info <| headline_msg :| [], []) + return (poly_msg_with_info <| headline_msg :| [], []) | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar; we would have -- swapped in Solver.Canonical.canEqTyVarHomo || isTyVarTyVar tv1 && not (isTyVarTy ty2) || ctEqRel ct == ReprEq -- The cases below don't really apply to ReprEq (except occurs check) - = (mkTcReportWithInfo headline_msg tv_extra :| [], add_sig) + = do + tv_extra <- extraTyVarEqInfo tv1 ty2 + return (mkTcReportWithInfo headline_msg tv_extra :| [], add_sig) | cterHasOccursCheck check_eq_result -- We report an "occurs check" even for a ~ F t a, where F is a type @@ -1501,7 +1530,7 @@ mkTyVarEqErr' dflags ctxt ct tv1 ty2 [] -> [] (tv : tvs) -> [OccursCheckInterestingTyVars (tv :| tvs)] - in (mkTcReportWithInfo headline_msg (extras2 ++ extras3) :| [], []) + in return (mkTcReportWithInfo headline_msg (extras2 ++ extras3) :| [], []) -- If the immediately-enclosing implication has 'tv' a skolem, and -- we know by now its an InferSkol kind of skolem, then presumably @@ -1510,14 +1539,16 @@ mkTyVarEqErr' dflags ctxt ct tv1 ty2 | (implic:_) <- cec_encl ctxt , Implic { ic_skols = skols } <- implic , tv1 `elem` skols - = (mkTcReportWithInfo mismatch_msg tv_extra :| [], []) + = do + tv_extra <- extraTyVarEqInfo tv1 ty2 + return (mkTcReportWithInfo mismatch_msg tv_extra :| [], []) -- Check for skolem escape | (implic:_) <- cec_encl ctxt -- Get the innermost context , Implic { ic_skols = skols } <- implic , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols , not (null esc_skols) - = (SkolemEscape ct implic esc_skols :| [mismatch_msg], []) + = return (SkolemEscape ct implic esc_skols :| [mismatch_msg], []) -- Nastiest case: attempt to unify an untouchable variable -- So tv is a meta tyvar (or started that way before we @@ -1527,20 +1558,19 @@ mkTyVarEqErr' dflags ctxt ct tv1 ty2 | (implic:_) <- cec_encl ctxt -- Get the innermost context , Implic { ic_tclvl = lvl } <- implic = assertPpr (not (isTouchableMetaTyVar lvl tv1)) - (ppr tv1 $$ ppr lvl) $ -- See Note [Error messages for untouchables] + (ppr tv1 $$ ppr lvl) $ do -- See Note [Error messages for untouchables] let tclvl_extra = UntouchableVariable tv1 implic - in - (mkTcReportWithInfo tclvl_extra tv_extra :| [mismatch_msg], add_sig) + tv_extra <- extraTyVarEqInfo tv1 ty2 + return (mkTcReportWithInfo tclvl_extra tv_extra :| [mismatch_msg], add_sig) | otherwise - = (reportEqErr ctxt ct (mkTyVarTy tv1) ty2 :| [], []) + = return (reportEqErr ctxt ct (mkTyVarTy tv1) ty2 :| [], []) -- This *can* happen (#6123) -- Consider an ambiguous top-level constraint (a ~ F a) -- Not an occurs check, because F is a type function. where headline_msg = misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2 mismatch_msg = mkMismatchMsg ct ty1 ty2 - tv_extra = extraTyVarEqInfo tv1 ty2 add_sig = maybeToList $ suggestAddSig ctxt ty1 ty2 ty1 = mkTyVarTy tv1 @@ -1653,18 +1683,24 @@ addition to superclasses (see Note [Remove redundant provided dicts] in GHC.Tc.TyCl.PatSyn). -} -extraTyVarEqInfo :: TcTyVar -> TcType -> [TcReportInfo] +extraTyVarEqInfo :: TcTyVar -> TcType -> TcM [TcReportInfo] -- Add on extra info about skolem constants -- NB: The types themselves are already tidied extraTyVarEqInfo tv1 ty2 - = extraTyVarInfo tv1 : ty_extra ty2 + = (:) <$> extraTyVarInfo tv1 <*> ty_extra ty2 where ty_extra ty = case tcGetCastedTyVar_maybe ty of - Just (tv, _) -> [extraTyVarInfo tv] - Nothing -> [] + Just (tv, _) -> (:[]) <$> extraTyVarInfo tv + Nothing -> return [] + +extraTyVarInfo :: TcTyVar -> TcM TcReportInfo +extraTyVarInfo tv = assertPpr (isTyVar tv) (ppr tv) $ + case tcTyVarDetails tv of + SkolemTv skol_info lvl overlaps -> do + new_skol_info <- zonkSkolemInfo skol_info + return $ TyVarInfo (mkTcTyVar (tyVarName tv) (tyVarKind tv) (SkolemTv new_skol_info lvl overlaps)) + _ -> return $ TyVarInfo tv -extraTyVarInfo :: TcTyVar -> TcReportInfo -extraTyVarInfo tv = assertPpr (isTyVar tv) (ppr tv) $ TyVarInfo tv suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> Maybe GhcHint -- See Note [Suggest adding a type signature] @@ -1966,7 +2002,6 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) = assert (matches `lengthIs` 1 && not (null unsafe_ispecs)) $ UnsafeOverlap ct ispecs unsafe_ispecs - {- Note [Report candidate instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have an unsolved (Num Int), where `Int` is not the Prelude Int, @@ -2054,6 +2089,7 @@ getAmbigTkvs ct tkvs = tyCoVarsOfCtList ct ambig_tkvs = filter isAmbiguousTyVar tkvs dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs) + ----------------------- -- relevantBindings looks at the value environment and finds values whose -- types mention any of the offending type variables. It has to be diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index 0fc6407da4..edd4b127ee 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -7,6 +7,9 @@ module GHC.Tc.Errors.Ppr ( pprTypeDoesNotHaveFixedRuntimeRep , pprScopeError + -- + , tidySkolemInfo + , tidySkolemInfoAnon ) where @@ -74,6 +77,8 @@ import Data.Function (on) import Data.List ( groupBy, sortBy, tails , partition, unfoldr ) import Data.Ord ( comparing ) +import Data.Bifunctor +import GHC.Types.Name.Env instance Diagnostic TcRnMessage where @@ -2117,9 +2122,9 @@ pprTcReportInfo _ (Ambiguity prepend_msg (ambig_kvs, ambig_tvs)) = msg | otherwise -- "The type variable 't0' is ambiguous" = text "The" <+> what <+> text "variable" <> plural tkvs <+> pprQuotedList tkvs <+> isOrAre tkvs <+> text "ambiguous" -pprTcReportInfo ctxt (TyVarInfo tv) = +pprTcReportInfo ctxt (TyVarInfo tv ) = case tcTyVarDetails tv of - SkolemTv {} -> pprSkols ctxt [tv] + SkolemTv sk_info _ _ -> pprSkols ctxt [(getSkolemInfo sk_info, [tv])] RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem" MetaTv {} -> empty pprTcReportInfo _ (NonInjectiveTyFam tc) = @@ -2210,7 +2215,7 @@ pprHoleError _ (Hole { hole_ty, hole_occ = occ }) (OutOfScopeHole imp_errs) | boring_type = hang herald 2 (ppr occ) | otherwise = hang herald 2 (pp_occ_with_type occ hole_ty) boring_type = isTyVarTy hole_ty -pprHoleError ctxt (Hole { hole_ty, hole_occ }) (HoleError sort) = +pprHoleError ctxt (Hole { hole_ty, hole_occ}) (HoleError sort other_tvs hole_skol_info) = vcat [ hole_msg , tyvars_msg , case sort of { ExprHole {} -> expr_hole_hint; _ -> type_hole_hint } ] @@ -2241,10 +2246,7 @@ pprHoleError ctxt (Hole { hole_ty, hole_occ }) (HoleError sort) = tyvars = tyCoVarsOfTypeList hole_ty tyvars_msg = ppUnless (null tyvars) $ text "Where:" <+> (vcat (map loc_msg other_tvs) - $$ pprSkols ctxt skol_tvs) - where - (skol_tvs, other_tvs) = partition is_skol tyvars - is_skol tv = isTcTyVar tv && isSkolemTyVar tv + $$ pprSkols ctxt hole_skol_info) -- Coercion variables can be free in the -- hole, via kind casts expr_hole_hint -- Give hint for, say, f x = _x @@ -2379,7 +2381,7 @@ ctxtFixes has_ambig_tvs pred implics ppr_skol (PatSkol (PatSynCon ps) _) = text "the pattern synonym" <+> quotes (ppr ps) ppr_skol skol_info = ppr skol_info -usefulContext :: [Implication] -> PredType -> [SkolemInfo] +usefulContext :: [Implication] -> PredType -> [SkolemInfoAnon] -- usefulContext picks out the implications whose context -- the programmer might plausibly augment to solve 'pred' usefulContext implics pred @@ -2464,15 +2466,67 @@ pprWithArising (ct:cts) * * **********************************************************************-} -pprSkols :: ReportErrCtxt -> [TcTyVar] -> SDoc -pprSkols ctxt tvs - = vcat (map pp_one (getSkolemInfo (cec_encl ctxt) tvs)) + +tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo +tidySkolemInfo env (SkolemInfo u sk_anon) = SkolemInfo u (tidySkolemInfoAnon env sk_anon) + +---------------- +tidySkolemInfoAnon :: TidyEnv -> SkolemInfoAnon -> SkolemInfoAnon +tidySkolemInfoAnon env (DerivSkol ty) = DerivSkol (tidyType env ty) +tidySkolemInfoAnon env (SigSkol cx ty tv_prs) = tidySigSkol env cx ty tv_prs +tidySkolemInfoAnon env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids) +tidySkolemInfoAnon env (UnifyForAllSkol ty) = UnifyForAllSkol (tidyType env ty) +tidySkolemInfoAnon _ info = info + +tidySigSkol :: TidyEnv -> UserTypeCtxt + -> TcType -> [(Name,TcTyVar)] -> SkolemInfoAnon +-- We need to take special care when tidying SigSkol +-- See Note [SigSkol SkolemInfo] in "GHC.Tc.Types.Origin" +tidySigSkol env cx ty tv_prs + = SigSkol cx (tidy_ty env ty) tv_prs' + where + tv_prs' = mapSnd (tidyTyCoVarOcc env) tv_prs + inst_env = mkNameEnv tv_prs' + + tidy_ty env (ForAllTy (Bndr tv vis) ty) + = ForAllTy (Bndr tv' vis) (tidy_ty env' ty) + where + (env', tv') = tidy_tv_bndr env tv + + tidy_ty env ty@(FunTy InvisArg w arg res) -- Look under c => t + = ty { ft_mult = tidy_ty env w, + ft_arg = tidyType env arg, + ft_res = tidy_ty env res } + + tidy_ty env ty = tidyType env ty + + tidy_tv_bndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) + tidy_tv_bndr env@(occ_env, subst) tv + | Just tv' <- lookupNameEnv inst_env (tyVarName tv) + = ((occ_env, extendVarEnv subst tv tv'), tv') + + | otherwise + = tidyVarBndr env tv + +pprSkols :: ReportErrCtxt -> [(SkolemInfoAnon, [TcTyVar])] -> SDoc +pprSkols ctxt zonked_ty_vars + = + let tidy_ty_vars = map (bimap (tidySkolemInfoAnon (cec_tidy ctxt)) id) zonked_ty_vars + in vcat (map pp_one tidy_ty_vars) where - pp_one (UnkSkol, tvs) + + no_msg = text "No skolem info - we could not find the origin of the following variables" <+> ppr zonked_ty_vars + $$ text "This should not happen, please report it as a bug following the instructions at:" + $$ text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug" + + + pp_one (UnkSkol cs, tvs) = vcat [ hang (pprQuotedList tvs) 2 (is_or_are tvs "a" "(rigid, skolem)") , nest 2 (text "of unknown origin") - , nest 2 (text "bound at" <+> ppr (foldr1 combineSrcSpans (map getSrcSpan tvs))) + , nest 2 (text "bound at" <+> ppr (skolsSpan tvs)) + , no_msg + , prettyCallStackDoc cs ] pp_one (RuntimeUnkSkol, tvs) = hang (pprQuotedList tvs) @@ -2481,13 +2535,16 @@ pprSkols ctxt tvs = vcat [ hang (pprQuotedList tvs) 2 (is_or_are tvs "a" "rigid" <+> text "bound by") , nest 2 (pprSkolInfo skol_info) - , nest 2 (text "at" <+> ppr (foldr1 combineSrcSpans (map getSrcSpan tvs))) ] + , nest 2 (text "at" <+> ppr (skolsSpan tvs)) ] is_or_are [_] article adjective = text "is" <+> text article <+> text adjective <+> text "type variable" is_or_are _ _ adjective = text "are" <+> text adjective <+> text "type variables" +skolsSpan :: [TcTyVar] -> SrcSpan +skolsSpan skol_tvs = foldr1 combineSrcSpans (map getSrcSpan skol_tvs) + {- ********************************************************************* * * Utilities for expected/actual messages diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index d05a2cc6da..04b3acefa0 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -35,7 +35,7 @@ module GHC.Tc.Errors.Types ( , SolverReport(..), SolverReportSupplementary(..) , ReportWithCtxt(..) , ReportErrCtxt(..) - , getUserGivens, discardProvCtxtGivens, getSkolemInfo + , getUserGivens, discardProvCtxtGivens , TcReportMsg(..), TcReportInfo(..) , CND_Extra(..) , mkTcReportWithInfo @@ -57,9 +57,9 @@ import {-# SOURCE #-} GHC.Tc.Types (TcIdSigInfo) import {-# SOURCE #-} GHC.Tc.Errors.Hole.FitTypes (HoleFit) import GHC.Tc.Types.Constraint import GHC.Tc.Types.Evidence (EvBindsVar) -import GHC.Tc.Types.Origin (CtOrigin (ProvCtxtOrigin), TypedThing, TyVarBndrs, SkolemInfo (SigSkol, UnkSkol, RuntimeUnkSkol), FRROrigin, UserTypeCtxt (PatSynCtxt)) +import GHC.Tc.Types.Origin (CtOrigin (ProvCtxtOrigin), SkolemInfoAnon (SigSkol), UserTypeCtxt (PatSynCtxt), TyVarBndrs, TypedThing, FRROrigin) import GHC.Tc.Types.Rank (Rank) -import GHC.Tc.Utils.TcType (TcType, isRuntimeUnkSkol) +import GHC.Tc.Utils.TcType (TcType) import GHC.Types.Error import GHC.Types.FieldLabel (FieldLabelString) import GHC.Types.Name (Name, OccName, getSrcLoc) @@ -83,13 +83,11 @@ import GHC.Unit.State (UnitState) import GHC.Unit.Module.Name (ModuleName) import GHC.Types.Basic import GHC.Utils.Misc (filterOut) -import GHC.Utils.Trace (pprTraceUserWarning) import qualified GHC.LanguageExtensions as LangExt import qualified Data.List.NonEmpty as NE import Data.Typeable hiding (TyCon) import qualified Data.Semigroup as Semigroup -import Data.List (partition) {- Note [Migrating TcM Messages] @@ -188,7 +186,7 @@ data TcRnMessage where Test cases: T9939, T10632, T18036a, T20602, PluralS, T19296. -} - TcRnRedundantConstraints :: [Id] -> (SkolemInfo, Bool) -> TcRnMessage + TcRnRedundantConstraints :: [Id] -> (SkolemInfoAnon, Bool) -> TcRnMessage {-| TcRnInaccessibleCode is a warning that is emitted when the RHS of a pattern match is inaccessible, because the constraint solver has detected a contradiction. @@ -1979,31 +1977,6 @@ discardProvCtxtGivens orig givens -- See Note [discardProvCtxtGivens] discard _ _ = False -getSkolemInfo :: [Implication] -> [TcTyVar] - -> [(SkolemInfo, [TcTyVar])] -- #14628 --- Get the skolem info for some type variables --- from the implication constraints that bind them. --- --- In the returned (skolem, tvs) pairs, the 'tvs' part is non-empty -getSkolemInfo _ [] - = [] - -getSkolemInfo [] tvs - | all isRuntimeUnkSkol tvs = [(RuntimeUnkSkol, tvs)] -- #14628 - | otherwise = -- See https://gitlab.haskell.org/ghc/ghc/-/issues?label_name[]=No%20skolem%20info - pprTraceUserWarning msg [(UnkSkol,tvs)] - where - msg = text "No skolem info - we could not find the origin of the following variables" <+> ppr tvs - $$ text "This should not happen, please report it as a bug following the instructions at:" - $$ text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug" - - -getSkolemInfo (implic:implics) tvs - | null tvs_here = getSkolemInfo implics tvs - | otherwise = (ic_info implic, tvs_here) : getSkolemInfo implics tvs_other - where - (tvs_here, tvs_other) = partition (`elem` ic_skols implic) tvs - -- | An error reported after constraint solving. -- This is usually, some sort of unsolved constraint error, -- but we try to be specific about the precise problem we encountered. @@ -2313,6 +2286,8 @@ data HoleError = OutOfScopeHole [ImportError] -- | Report a typed hole, or wildcard, with additional information. | HoleError HoleSort + [TcTyVar] -- Other type variables which get computed on the way. + [(SkolemInfoAnon, [TcTyVar])] -- Zonked and grouped skolems for the type of the hole. -- | A message that aims to explain why two types couldn't be seen -- to be representationally equal. diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs index da8bf7901f..b5a7c5a7b2 100644 --- a/compiler/GHC/Tc/Gen/Arrow.hs +++ b/compiler/GHC/Tc/Gen/Arrow.hs @@ -184,7 +184,8 @@ tc_cmd env (HsCmdIf x fun@(SyntaxExprRn {}) pred b1 b2) res_ty -- Rebindable syn -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r -- because we're going to apply it to the environment, not -- the return value. - ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar] + ; skol_info <- mkSkolemInfo ArrowReboundIfSkol + ; (_, [r_tv]) <- tcInstSkolTyVars skol_info [alphaTyVar] ; let r_ty = mkTyVarTy r_tv ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty)) TcRnArrowIfThenElsePredDependsOnResultTy diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index c9024a5cf5..cf566bdcf9 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -5,6 +5,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RecursiveDo #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -32,14 +33,15 @@ module GHC.Tc.Gen.HsType ( bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol, - bindOuterFamEqnTKBndrs, bindOuterFamEqnTKBndrs_Q_Tv, - tcOuterTKBndrs, scopedSortOuter, + bindOuterFamEqnTKBndrs_Q_Tv, bindOuterFamEqnTKBndrs, + tcOuterTKBndrs, scopedSortOuter, outerTyVars, outerTyVarBndrs, bindOuterSigTKBndrs_Tv, tcExplicitTKBndrs, bindNamedWildCardBinders, -- Type checking type and class decls, and instances thereof - bindTyClTyVars, tcFamTyPats, + bindTyClTyVars, bindTyClTyVarsAndZonk, + tcFamTyPats, etaExpandAlgTyCon, tcbVisibilities, -- tyvars @@ -50,14 +52,14 @@ module GHC.Tc.Gen.HsType ( InitialKindStrategy(..), SAKS_or_CUSK(..), ContextKind(..), - kcDeclHeader, + kcDeclHeader, checkForDuplicateScopedTyVars, tcHsLiftedType, tcHsOpenType, tcHsLiftedTypeNC, tcHsOpenTypeNC, tcInferLHsType, tcInferLHsTypeKind, tcInferLHsTypeUnsaturated, tcCheckLHsType, tcHsContext, tcLHsPredType, - kindGeneralizeAll, kindGeneralizeSome, kindGeneralizeNone, + kindGeneralizeAll, -- Sort-checking kinds tcLHsKindSig, checkDataKindSig, DataSort(..), @@ -94,7 +96,7 @@ import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBindersN, - tcInstInvisibleTyBinder ) + tcInstInvisibleTyBinder, tcSkolemiseInvisibleBndrs ) import GHC.Core.Type import GHC.Builtin.Types.Prim import GHC.Types.Error @@ -114,21 +116,25 @@ import GHC.Types.Basic import GHC.Types.SrcLoc import GHC.Types.Unique import GHC.Types.Unique.FM -import GHC.Types.Unique.Set import GHC.Utils.Misc import GHC.Types.Unique.Supply import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Data.FastString import GHC.Builtin.Names hiding ( wildCardName ) import GHC.Driver.Session import qualified GHC.LanguageExtensions as LangExt +import GHC.Data.FastString +import GHC.Data.List.SetOps import GHC.Data.Maybe import GHC.Data.Bag( unitBag ) -import Data.List ( find ) + +import Data.Function ( on ) +import Data.List.NonEmpty as NE( NonEmpty(..), nubBy ) +import Data.List ( find, mapAccumL ) import Control.Monad +import Data.Tuple( swap ) {- ---------------------------- @@ -314,7 +320,7 @@ Note [Promotion in signatures] If an unsolved metavariable in a signature is not generalized (because we're not generalizing the construct -- e.g., pattern sig -- or because the metavars are constrained -- see kindGeneralizeSome) -we need to promote to maintain (WantedTvInv) of Note [TcLevel invariants] +we need to promote to maintain (WantedInv) of Note [TcLevel invariants] in GHC.Tc.Utils.TcType. Note that promotion is identical in effect to generalizing and the reinstantiating with a fresh metavariable at the current level. So in some sense, we generalize *all* variables, but then re-instantiate @@ -331,7 +337,7 @@ than the surrounding context.) This kappa cannot be solved for while checking the pattern signature (which is not kind-generalized). When we are checking the *body* of foo, though, we need to unify the type of x with the argument type of bar. At this point, the ambient TcLevel is 1, and spotting a -matavariable with level 2 would violate the (WantedTvInv) invariant of +matavariable with level 2 would violate the (WantedInv) invariant of Note [TcLevel invariants]. So, instead of kind-generalizing, we promote the metavariable to level 1. This is all done in kindGeneralizeNone. @@ -393,7 +399,8 @@ tcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM Type -- Does not do validity checking tcClassSigType names sig_ty = addSigCtxt sig_ctxt sig_ty $ - do { (implic, ty) <- tc_lhs_sig_type skol_info sig_ty (TheKind liftedTypeKind) + do { skol_info <- mkSkolemInfo skol_info_anon + ; (implic, ty) <- tc_lhs_sig_type skol_info sig_ty (TheKind liftedTypeKind) ; emitImplication implic ; return ty } -- Do not zonk-to-Type, nor perform a validity check @@ -414,7 +421,7 @@ tcClassSigType names sig_ty -- painfully delicate. where sig_ctxt = funsSigCtxt names - skol_info = SigTypeSkol sig_ctxt + skol_info_anon = SigTypeSkol sig_ctxt tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type -- Does validity checking @@ -422,7 +429,7 @@ tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type tcHsSigType ctxt sig_ty = addSigCtxt ctxt sig_ty $ do { traceTc "tcHsSigType {" (ppr sig_ty) - + ; skol_info <- mkSkolemInfo skol_info -- Generalise here: see Note [Kind generalisation] ; (implic, ty) <- tc_lhs_sig_type skol_info sig_ty (expectedKindInCtxt ctxt) @@ -464,15 +471,15 @@ tc_lhs_sig_type skol_info full_hs_ty@(L loc (HsSig { sig_bndrs = hs_outer_bndrs ; doNotQuantifyTyVars exp_kind_dvs (mk_doc exp_kind) ; traceTc "tc_lhs_sig_type" (ppr hs_outer_bndrs $$ ppr outer_bndrs) - ; (outer_tv_bndrs :: [InvisTVBinder]) <- scopedSortOuter outer_bndrs - - ; let ty1 = mkInvisForAllTys outer_tv_bndrs ty + ; outer_bndrs <- scopedSortOuter outer_bndrs - ; kvs <- kindGeneralizeSome wanted ty1 + ; let outer_tv_bndrs :: [InvisTVBinder] = outerTyVarBndrs outer_bndrs + ty1 = mkInvisForAllTys outer_tv_bndrs ty + ; kvs <- kindGeneralizeSome skol_info wanted ty1 -- Build an implication for any as-yet-unsolved kind equalities -- See Note [Skolem escape in type signatures] - ; implic <- buildTvImplication skol_info kvs tc_lvl wanted + ; implic <- buildTvImplication (getSkolemInfo skol_info) kvs tc_lvl wanted ; return (implic, mkInfForAllTys kvs ty1) } where @@ -578,7 +585,9 @@ tcStandaloneKindSig (L _ (StandaloneKindSig _ (L _ name) ksig)) tcTopLHsType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type tcTopLHsType ctxt lsig_ty - = tc_top_lhs_type TypeLevel ctxt lsig_ty + = checkNoErrs $ -- Fail eagerly to avoid follow-on errors. We are at + -- top level so these constraints will never be solved later. + tc_top_lhs_type TypeLevel ctxt lsig_ty tc_top_lhs_type :: TypeOrKind -> UserTypeCtxt -> LHsSigType GhcRn -> TcM Type -- tc_top_lhs_type is used for kind-checking top-level LHsSigTypes where @@ -591,16 +600,18 @@ tc_top_lhs_type tyki ctxt (L loc sig_ty@(HsSig { sig_bndrs = hs_outer_bndrs , sig_body = body })) = setSrcSpanA loc $ do { traceTc "tc_top_lhs_type {" (ppr sig_ty) + ; skol_info <- mkSkolemInfo skol_info_anon ; (tclvl, wanted, (outer_bndrs, ty)) <- pushLevelAndSolveEqualitiesX "tc_top_lhs_type" $ tcOuterTKBndrs skol_info hs_outer_bndrs $ do { kind <- newExpectedKind (expectedKindInCtxt ctxt) ; tc_lhs_type (mkMode tyki) body kind } - ; outer_tv_bndrs <- scopedSortOuter outer_bndrs - ; let ty1 = mkInvisForAllTys outer_tv_bndrs ty + ; outer_bndrs <- scopedSortOuter outer_bndrs + ; let outer_tv_bndrs = outerTyVarBndrs outer_bndrs + ty1 = mkInvisForAllTys outer_tv_bndrs ty - ; kvs <- kindGeneralizeAll ty1 -- "All" because it's a top-level type + ; kvs <- kindGeneralizeAll skol_info ty1 -- "All" because it's a top-level type ; reportUnsolvedEqualities skol_info kvs tclvl wanted ; ze <- mkEmptyZonkEnv NoFlexi @@ -608,7 +619,7 @@ tc_top_lhs_type tyki ctxt (L loc sig_ty@(HsSig { sig_bndrs = hs_outer_bndrs ; traceTc "tc_top_lhs_type }" (vcat [ppr sig_ty, ppr final_ty]) ; return final_ty } where - skol_info = SigTypeSkol ctxt + skol_info_anon = SigTypeSkol ctxt ----------------- tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind]) @@ -619,9 +630,7 @@ tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind]) -- returns ([k], C, [k, Int], [k->k]) -- Return values are fully zonked tcHsDeriv hs_ty - = do { ty <- checkNoErrs $ -- Avoid redundant error report - -- with "illegal deriving", below - tcTopLHsType DerivClauseCtxt hs_ty + = do { ty <- tcTopLHsType DerivClauseCtxt hs_ty ; let (tvs, pred) = splitForAllTyCoVars ty (kind_args, _) = splitFunTys (tcTypeKind pred) ; case getClassPredTys_maybe pred of @@ -631,12 +640,11 @@ tcHsDeriv hs_ty -- | Typecheck a deriving strategy. For most deriving strategies, this is a -- no-op, but for the @via@ strategy, this requires typechecking the @via@ type. -tcDerivStrategy :: - Maybe (LDerivStrategy GhcRn) - -- ^ The deriving strategy - -> TcM (Maybe (LDerivStrategy GhcTc), [TyVar]) - -- ^ The typechecked deriving strategy and the tyvars that it binds - -- (if using 'ViaStrategy'). +tcDerivStrategy :: Maybe (LDerivStrategy GhcRn) + -- ^ The deriving strategy + -> TcM (Maybe (LDerivStrategy GhcTc), [TcTyVar]) + -- ^ The typechecked deriving strategy and the tyvars that it binds + -- (if using 'ViaStrategy'). tcDerivStrategy mb_lds = case mb_lds of Nothing -> boring_case Nothing @@ -647,18 +655,15 @@ tcDerivStrategy mb_lds where tc_deriv_strategy :: DerivStrategy GhcRn -> TcM (DerivStrategy GhcTc, [TyVar]) - tc_deriv_strategy (StockStrategy _) - = boring_case (StockStrategy noExtField) - tc_deriv_strategy (AnyclassStrategy _) - = boring_case (AnyclassStrategy noExtField) - tc_deriv_strategy (NewtypeStrategy _) - = boring_case (NewtypeStrategy noExtField) - tc_deriv_strategy (ViaStrategy ty) = do - ty' <- checkNoErrs $ tcTopLHsType DerivClauseCtxt ty - let (via_tvs, via_pred) = splitForAllTyCoVars ty' - pure (ViaStrategy via_pred, via_tvs) - - boring_case :: ds -> TcM (ds, [TyVar]) + tc_deriv_strategy (StockStrategy _) = boring_case (StockStrategy noExtField) + tc_deriv_strategy (AnyclassStrategy _) = boring_case (AnyclassStrategy noExtField) + tc_deriv_strategy (NewtypeStrategy _) = boring_case (NewtypeStrategy noExtField) + tc_deriv_strategy (ViaStrategy hs_sig) + = do { ty <- tcTopLHsType DerivClauseCtxt hs_sig + ; rec { (via_tvs, via_pred) <- tcSkolemiseInvisibleBndrs (DerivSkol via_pred) ty} + ; pure (ViaStrategy via_pred, via_tvs) } + + boring_case :: ds -> TcM (ds, [a]) boring_case ds = pure (ds, []) tcHsClsInstType :: UserTypeCtxt -- InstDeclCtxt or SpecInstCtxt @@ -667,12 +672,7 @@ tcHsClsInstType :: UserTypeCtxt -- InstDeclCtxt or SpecInstCtxt -- Like tcHsSigType, but for a class instance declaration tcHsClsInstType user_ctxt hs_inst_ty = setSrcSpan (getLocA hs_inst_ty) $ - do { -- Fail eagerly if tcTopLHsType fails. We are at top level so - -- these constraints will never be solved later. And failing - -- eagerly avoids follow-on errors when checkValidInstance - -- sees an unsolved coercion hole - inst_ty <- checkNoErrs $ - tcTopLHsType user_ctxt hs_inst_ty + do { inst_ty <- tcTopLHsType user_ctxt hs_inst_ty ; checkValidInstance user_ctxt hs_inst_ty inst_ty ; return inst_ty } @@ -2348,7 +2348,7 @@ kcCheckDeclHeader -> TyConFlavour -- ^ What sort of 'TyCon' is being checked -> LHsQTyVars GhcRn -- ^ Binders in the header -> TcM ContextKind -- ^ The result kind. AnyKind == no result signature - -> TcM TcTyCon -- ^ A suitably-kinded generalized TcTyCon + -> TcM PolyTcTyCon -- ^ A suitably-kinded generalized TcTyCon kcCheckDeclHeader (SAKS sig) = kcCheckDeclHeader_sig sig kcCheckDeclHeader CUSK = kcCheckDeclHeader_cusk @@ -2357,17 +2357,18 @@ kcCheckDeclHeader_cusk -> TyConFlavour -- ^ What sort of 'TyCon' is being checked -> LHsQTyVars GhcRn -- ^ Binders in the header -> TcM ContextKind -- ^ The result kind - -> TcM TcTyCon -- ^ A suitably-kinded generalized TcTyCon + -> TcM PolyTcTyCon -- ^ A suitably-kinded generalized TcTyCon kcCheckDeclHeader_cusk name flav (HsQTvs { hsq_ext = kv_ns , hsq_explicit = hs_tvs }) kc_res_ki -- CUSK case -- See note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl = addTyConFlavCtxt name flav $ - do { (tclvl, wanted, (scoped_kvs, (tc_tvs, res_kind))) + do { skol_info <- mkSkolemInfo skol_info_anon + ; (tclvl, wanted, (scoped_kvs, (tc_tvs, res_kind))) <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_cusk" $ - bindImplicitTKBndrs_Q_Skol kv_ns $ - bindExplicitTKBndrs_Q_Skol ctxt_kind hs_tvs $ + bindImplicitTKBndrs_Q_Skol skol_info kv_ns $ + bindExplicitTKBndrs_Q_Skol skol_info ctxt_kind hs_tvs $ newExpectedKind =<< kc_res_ki -- Now, because we're in a CUSK, @@ -2375,36 +2376,37 @@ kcCheckDeclHeader_cusk name flav ; let spec_req_tkvs = scoped_kvs ++ tc_tvs all_kinds = res_kind : map tyVarKind spec_req_tkvs - ; candidates' <- candidateQTyVarsOfKinds all_kinds + ; candidates <- candidateQTyVarsOfKinds all_kinds -- 'candidates' are all the variables that we are going to -- skolemise and then quantify over. We do not include spec_req_tvs -- because they are /already/ skolems - ; let non_tc_candidates = filter (not . isTcTyVar) (nonDetEltsUniqSet (tyCoVarsOfTypes all_kinds)) - candidates = candidates' { dv_kvs = dv_kvs candidates' `extendDVarSetList` non_tc_candidates } - inf_candidates = candidates `delCandidates` spec_req_tkvs - - ; inferred <- quantifyTyVars DefaultNonStandardTyVars inf_candidates + ; inferred <- quantifyTyVars skol_info DefaultNonStandardTyVars $ + candidates `delCandidates` spec_req_tkvs -- NB: 'inferred' comes back sorted in dependency order - ; scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs - ; tc_tvs <- mapM zonkTyCoVarKind tc_tvs + ; scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs -- scoped_kvs and tc_tvs are skolems, + ; tc_tvs <- mapM zonkTyCoVarKind tc_tvs -- so zonkTyCoVarKind suffices ; res_kind <- zonkTcType res_kind ; let mentioned_kv_set = candidateKindVars candidates specified = scopedSort scoped_kvs -- NB: maintain the L-R order of scoped_kvs - final_tc_binders = mkNamedTyConBinders Inferred inferred - ++ mkNamedTyConBinders Specified specified - ++ map (mkRequiredTyConBinder mentioned_kv_set) tc_tvs + all_tcbs = mkNamedTyConBinders Inferred inferred + ++ mkNamedTyConBinders Specified specified + ++ map (mkRequiredTyConBinder mentioned_kv_set) tc_tvs + + -- Eta expand if necessary; we are building a PolyTyCon + ; (eta_tcbs, res_kind) <- etaExpandAlgTyCon flav skol_info all_tcbs res_kind - all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) - tycon = mkTcTyCon name final_tc_binders res_kind all_tv_prs + ; let all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) + final_tcbs = all_tcbs `chkAppend` eta_tcbs + tycon = mkTcTyCon name final_tcbs res_kind all_tv_prs True -- it is generalised flav - ; reportUnsolvedEqualities skol_info (binderVars final_tc_binders) + ; reportUnsolvedEqualities skol_info (binderVars final_tcbs) tclvl wanted -- If the ordering from @@ -2414,22 +2416,25 @@ kcCheckDeclHeader_cusk name flav ; traceTc "kcCheckDeclHeader_cusk " $ vcat [ text "name" <+> ppr name + , text "candidates" <+> ppr candidates + , text "mentioned_kv_set" <+> ppr mentioned_kv_set , text "kv_ns" <+> ppr kv_ns , text "hs_tvs" <+> ppr hs_tvs , text "scoped_kvs" <+> ppr scoped_kvs - , text "tc_tvs" <+> ppr tc_tvs + , text "spec_req_tvs" <+> pprTyVars spec_req_tkvs + , text "all_kinds" <+> ppr all_kinds + , text "tc_tvs" <+> pprTyVars tc_tvs , text "res_kind" <+> ppr res_kind - , text "candidates" <+> ppr candidates , text "inferred" <+> ppr inferred , text "specified" <+> ppr specified - , text "final_tc_binders" <+> ppr final_tc_binders + , text "final_tcbs" <+> ppr final_tcbs , text "mkTyConKind final_tc_bndrs res_kind" - <+> ppr (mkTyConKind final_tc_binders res_kind) + <+> ppr (mkTyConKind final_tcbs res_kind) , text "all_tv_prs" <+> ppr all_tv_prs ] ; return tycon } where - skol_info = TyConSkol flav name + skol_info_anon = TyConSkol flav name ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind | otherwise = AnyKind @@ -2442,7 +2447,7 @@ kcInferDeclHeader -> TyConFlavour -- ^ What sort of 'TyCon' is being checked -> LHsQTyVars GhcRn -> TcM ContextKind -- ^ The result kind - -> TcM TcTyCon -- ^ A suitably-kinded non-generalized TcTyCon + -> TcM MonoTcTyCon -- ^ A suitably-kinded non-generalized TcTyCon kcInferDeclHeader name flav (HsQTvs { hsq_ext = kv_ns , hsq_explicit = hs_tvs }) kc_res_ki @@ -2489,247 +2494,202 @@ kcInferDeclHeader name flav | otherwise = AnyKind -- | Kind-check a declaration header against a standalone kind signature. --- See Note [Arity inference in kcCheckDeclHeader_sig] +-- See Note [kcCheckDeclHeader_sig] kcCheckDeclHeader_sig :: Kind -- ^ Standalone kind signature, fully zonked! (zonkTcTypeToType) -> Name -- ^ of the thing being checked -> TyConFlavour -- ^ What sort of 'TyCon' is being checked -> LHsQTyVars GhcRn -- ^ Binders in the header -> TcM ContextKind -- ^ The result kind. AnyKind == no result signature - -> TcM TcTyCon -- ^ A suitably-kinded TcTyCon -kcCheckDeclHeader_sig kisig name flav + -> TcM PolyTcTyCon -- ^ A suitably-kinded, fully generalised TcTyCon +-- Postcondition to (kcCheckDeclHeader_sig sig_kind n f hs_tvs kc_res_ki): +-- kind(returned PolyTcTyCon) = sig_kind +-- +kcCheckDeclHeader_sig sig_kind name flav (HsQTvs { hsq_ext = implicit_nms - , hsq_explicit = explicit_nms }) kc_res_ki + , hsq_explicit = hs_tv_bndrs }) kc_res_ki = addTyConFlavCtxt name flav $ - do { -- Step 1: zip user-written binders with quantifiers from the kind signature. - -- For example: - -- - -- type F :: forall k -> k -> forall j. j -> Type - -- data F i a b = ... - -- - -- Results in the following 'zipped_binders': - -- - -- TyBinder LHsTyVarBndr - -- --------------------------------------- - -- ZippedBinder forall k -> i - -- ZippedBinder k -> a - -- ZippedBinder forall j. - -- ZippedBinder j -> b - -- - let (zipped_binders, excess_bndrs, kisig') = zipBinders kisig explicit_nms - - -- Report binders that don't have a corresponding quantifier. - -- For example: - -- - -- type T :: Type -> Type - -- data T b1 b2 b3 = ... - -- - -- Here, b1 is zipped with Type->, while b2 and b3 are excess binders. - -- - ; unless (null excess_bndrs) $ failWithTc (tooManyBindersErr kisig' excess_bndrs) - - -- Convert each ZippedBinder to TyConBinder for tyConBinders - -- and to [(Name, TcTyVar)] for tcTyConScopedTyVars - ; (vis_tcbs, concat -> explicit_tv_prs) <- mapAndUnzipM zipped_to_tcb zipped_binders - - ; (tclvl, wanted, (implicit_tvs, (invis_binders, r_ki))) - <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_sig" $ -- #16687 - bindImplicitTKBndrs_Tv implicit_nms $ - tcExtendNameTyVarEnv explicit_tv_prs $ - do { -- Check that inline kind annotations on binders are valid. - -- For example: - -- - -- type T :: Maybe k -> Type - -- data T (a :: Maybe j) = ... - -- - -- Here we unify Maybe k ~ Maybe j - mapM_ check_zipped_binder zipped_binders - - -- Kind-check the result kind annotation, if present: - -- - -- data T a b :: res_ki where - -- ^^^^^^^^^ - -- We do it here because at this point the environment has been - -- extended with both 'implicit_tcv_prs' and 'explicit_tv_prs'. - ; ctx_k <- kc_res_ki - ; m_res_ki <- case ctx_k of - AnyKind -> return Nothing - _ -> Just <$> newExpectedKind ctx_k - - -- Step 2: split off invisible binders. - -- For example: - -- - -- type F :: forall k1 k2. (k1, k2) -> Type - -- type family F - -- - -- Does 'forall k1 k2' become a part of 'tyConBinders' or 'tyConResKind'? - -- See Note [Arity inference in kcCheckDeclHeader_sig] - ; let (invis_binders, r_ki) = split_invis kisig' m_res_ki - - -- Check that the inline result kind annotation is valid. - -- For example: - -- - -- type T :: Type -> Maybe k - -- type family T a :: Maybe j where - -- - -- Here we unify Maybe k ~ Maybe j - ; whenIsJust m_res_ki $ \res_ki -> - discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] - unifyKind Nothing r_ki res_ki - - ; return (invis_binders, r_ki) } - - -- Convert each invisible TyCoBinder to TyConBinder for tyConBinders. - ; invis_tcbs <- mapM invis_to_tcb invis_binders - - -- Zonk the implicitly quantified variables. - ; implicit_tvs <- mapM zonkTcTyVarToTyVar implicit_tvs - - -- Build the final, generalized TcTyCon - ; let tcbs = vis_tcbs ++ invis_tcbs - implicit_tv_prs = implicit_nms `zip` implicit_tvs - all_tv_prs = implicit_tv_prs ++ explicit_tv_prs - tc = mkTcTyCon name tcbs r_ki all_tv_prs True flav - skol_info = TyConSkol flav name + do { skol_info <- mkSkolemInfo (TyConSkol flav name) + ; (sig_tcbs :: [TcTyConBinder], sig_res_kind :: Kind) + <- splitTyConKind skol_info emptyInScopeSet + (map getOccName hs_tv_bndrs) sig_kind + + ; traceTc "kcCheckDeclHeader_sig {" $ + vcat [ text "sig_kind:" <+> ppr sig_kind + , text "sig_tcbs:" <+> ppr sig_tcbs + , text "sig_res_kind:" <+> ppr sig_res_kind ] + + ; (tclvl, wanted, (implicit_tvs, (skol_tcbs, (extra_tcbs, tycon_res_kind)))) + <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_sig" $ -- #16687 + bindImplicitTKBndrs_Q_Tv implicit_nms $ -- Q means don't clone + matchUpSigWithDecl sig_tcbs sig_res_kind hs_tv_bndrs $ \ excess_sig_tcbs sig_res_kind -> + do { -- Kind-check the result kind annotation, if present: + -- data T a b :: res_ki where ... + -- ^^^^^^^^^ + -- We do it here because at this point the environment has been + -- extended with both 'implicit_tcv_prs' and 'explicit_tv_prs'. + ; ctx_k <- kc_res_ki + + -- Work out extra_arity, the number of extra invisible binders from + -- the kind signature that should be part of the TyCon's arity. + -- See Note [Arity inference in kcCheckDeclHeader_sig] + ; let n_invis_tcbs = countWhile isInvisibleTyConBinder excess_sig_tcbs + invis_arity = case ctx_k of + AnyKind -> n_invis_tcbs -- No kind signature, so make all the invisible binders + -- the signature into part of the arity of the TyCon + OpenKind -> n_invis_tcbs -- Result kind is (TYPE rr), so again make all the + -- invisible binders part of the arity of the TyCon + TheKind ki -> 0 `max` (n_invis_tcbs - invisibleTyBndrCount ki) + + ; let (invis_tcbs, resid_tcbs) = splitAt invis_arity excess_sig_tcbs + ; let sig_res_kind' = mkTyConKind resid_tcbs sig_res_kind + + ; traceTc "kcCheckDeclHeader_sig 2" $ vcat [ ppr excess_sig_tcbs + , ppr invis_arity, ppr invis_tcbs + , ppr n_invis_tcbs ] + + -- Unify res_ki (from the type declaration) with the residual kind from + -- the kind signature. Don't forget to apply the skolemising 'subst' first. + ; case ctx_k of + AnyKind -> return () -- No signature + _ -> do { res_ki <- newExpectedKind ctx_k + ; discardResult (unifyKind Nothing sig_res_kind' res_ki) } + + -- Add more binders for data/newtype, so the result kind has no arrows + -- See Note [Datatype return kinds] + ; if null resid_tcbs || not (needsEtaExpansion flav) + then return (invis_tcbs, sig_res_kind') + else return (excess_sig_tcbs, sig_res_kind) + } - -- Check that there are no unsolved equalities - ; reportUnsolvedEqualities skol_info (binderVars tcbs) tclvl wanted - ; traceTc "kcCheckDeclHeader_sig done:" $ vcat + -- Check that there are no unsolved equalities + ; let all_tcbs = skol_tcbs ++ extra_tcbs + ; reportUnsolvedEqualities skol_info (binderVars all_tcbs) tclvl wanted + + -- Check that distinct binders map to distinct tyvars (see #20916). For example + -- type T :: k -> k -> Type + -- data T (a::p) (b::q) = ... + -- Here p and q both map to the same kind variable k. We don't allow this + -- so we must check that they are distinct. A similar thing happens + -- in GHC.Tc.TyCl.swizzleTcTyConBinders during inference. + ; implicit_tvs <- zonkTcTyVarsToTcTyVars implicit_tvs + ; let implicit_prs = implicit_nms `zip` implicit_tvs + ; checkForDuplicateScopedTyVars implicit_prs + + -- Swizzle the Names so that the TyCon uses the user-declared implicit names + -- E.g type T :: k -> Type + -- data T (a :: j) = .... + -- We want the TyConBinders of T to be [j, a::j], not [k, a::k] + -- Why? So that the TyConBinders of the TyCon will lexically scope over the + -- associated types and methods of a class. + ; let swizzle_env = mkVarEnv (map swap implicit_prs) + (subst, swizzled_tcbs) = mapAccumL (swizzleTcb swizzle_env) emptyTCvSubst all_tcbs + swizzled_kind = substTy subst tycon_res_kind + all_tv_prs = mkTyVarNamePairs (binderVars swizzled_tcbs) + + ; traceTc "kcCheckDeclHeader swizzle" $ vcat + [ text "implicit_prs = " <+> ppr implicit_prs + , text "implicit_nms = " <+> ppr implicit_nms + , text "hs_tv_bndrs = " <+> ppr hs_tv_bndrs + , text "all_tcbs = " <+> pprTyVars (binderVars all_tcbs) + , text "swizzled_tcbs = " <+> pprTyVars (binderVars swizzled_tcbs) + , text "tycon_res_kind =" <+> ppr tycon_res_kind + , text "swizzled_kind =" <+> ppr swizzled_kind ] + + -- Build the final, generalized PolyTcTyCon + -- NB: all_tcbs must bind the tyvars in the range of all_tv_prs + -- because the tv_prs is used when (say) typechecking the RHS of + -- a type synonym. + ; let tc = mkTcTyCon name swizzled_tcbs swizzled_kind all_tv_prs True flav + + ; traceTc "kcCheckDeclHeader_sig }" $ vcat [ text "tyConName = " <+> ppr (tyConName tc) - , text "kisig =" <+> debugPprType kisig + , text "sig_kind =" <+> debugPprType sig_kind , text "tyConKind =" <+> debugPprType (tyConKind tc) , text "tyConBinders = " <+> ppr (tyConBinders tc) - , text "tcTyConScopedTyVars" <+> ppr (tcTyConScopedTyVars tc) , text "tyConResKind" <+> debugPprType (tyConResKind tc) ] ; return tc } + +matchUpSigWithDecl + :: [TcTyConBinder] -- TcTyConBinders (with skolem TcTyVars) from the separate kind signature + -> TcKind -- The tail end of the kind signature + -> [LHsTyVarBndr () GhcRn] -- User-written binders in decl + -> ([TcTyConBinder] -> TcKind -> TcM a) -- All user-written binders are in scope + -- Argument is excess TyConBinders and tail kind + -> TcM ( [TcTyConBinder] -- Skolemised binders, with TcTyVars + , a ) +-- See Note [Matching a kind sigature with a declaration] +-- Invariant: Length of returned TyConBinders + length of excess TyConBinders +-- = length of incoming TyConBinders +matchUpSigWithDecl sig_tcbs sig_res_kind hs_bndrs thing_inside + = go emptyTCvSubst sig_tcbs hs_bndrs where - -- Consider this declaration: - -- - -- type T :: forall a. forall b -> (a~b) => Proxy a -> Type - -- data T x p = MkT - -- - -- Here, we have every possible variant of ZippedBinder: - -- - -- TyBinder LHsTyVarBndr - -- ---------------------------------------------- - -- ZippedBinder forall {k}. - -- ZippedBinder forall (a::k). - -- ZippedBinder forall (b::k) -> x - -- ZippedBinder (a~b) => - -- ZippedBinder Proxy a -> p - -- - -- Given a ZippedBinder zipped_to_tcb produces: - -- - -- * TyConBinder for tyConBinders - -- * (Name, TcTyVar) for tcTyConScopedTyVars, if there's a user-written LHsTyVarBndr - -- - zipped_to_tcb :: ZippedBinder -> TcM (TyConBinder, [(Name, TcTyVar)]) - zipped_to_tcb zb = case zb of - - -- Inferred variable, no user-written binder. - -- Example: forall {k}. - ZippedBinder (Named (Bndr v Specified)) Nothing -> - return (mkNamedTyConBinder Specified v, []) - - -- Specified variable, no user-written binder. - -- Example: forall (a::k). - ZippedBinder (Named (Bndr v Inferred)) Nothing -> - return (mkNamedTyConBinder Inferred v, []) - - -- Constraint, no user-written binder. - -- Example: (a~b) => - ZippedBinder (Anon InvisArg bndr_ki) Nothing -> do - name <- newSysName (mkTyVarOccFS (fsLit "ev")) - let tv = mkTyVar name (scaledThing bndr_ki) - return (mkAnonTyConBinder InvisArg tv, []) - - -- Non-dependent visible argument with a user-written binder. - -- Example: Proxy a -> - ZippedBinder (Anon VisArg bndr_ki) (Just b) -> - return $ - let v_name = getName b - tv = mkTyVar v_name (scaledThing bndr_ki) - tcb = mkAnonTyConBinder VisArg tv - in (tcb, [(v_name, tv)]) - - -- Dependent visible argument with a user-written binder. - -- Example: forall (b::k) -> - ZippedBinder (Named (Bndr v Required)) (Just b) -> - return $ - let v_name = getName b - tcb = mkNamedTyConBinder Required v - in (tcb, [(v_name, v)]) - - -- 'zipBinders' does not produce any other variants of ZippedBinder. - _ -> panic "goVis: invalid ZippedBinder" - - -- Given an invisible binder that comes from 'split_invis', - -- convert it to TyConBinder. - invis_to_tcb :: TyCoBinder -> TcM TyConBinder - invis_to_tcb tb = do - (tcb, stv) <- zipped_to_tcb (ZippedBinder tb Nothing) - massert (null stv) - return tcb - - -- Check that the inline kind annotation on a binder is valid - -- by unifying it with the kind of the quantifier. - check_zipped_binder :: ZippedBinder -> TcM () - check_zipped_binder (ZippedBinder _ Nothing) = return () - check_zipped_binder (ZippedBinder tb (Just b)) = - case unLoc b of - UserTyVar _ _ _ -> return () - KindedTyVar _ _ v v_hs_ki -> do - v_ki <- tcLHsKindSig (TyVarBndrKindCtxt (unLoc v)) v_hs_ki - discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] - unifyKind (Just . NameThing $ unLoc v) - (tyBinderType tb) - v_ki - - -- Split the invisible binders that should become a part of 'tyConBinders' - -- rather than 'tyConResKind'. - -- See Note [Arity inference in kcCheckDeclHeader_sig] - split_invis :: Kind -> Maybe Kind -> ([TyCoBinder], Kind) - split_invis sig_ki Nothing = - -- instantiate all invisible binders - splitInvisPiTys sig_ki - split_invis sig_ki (Just res_ki) = - -- subtraction a la checkExpectedKind - let n_res_invis_bndrs = invisibleTyBndrCount res_ki - n_sig_invis_bndrs = invisibleTyBndrCount sig_ki - n_inst = n_sig_invis_bndrs - n_res_invis_bndrs - in splitInvisPiTysN n_inst sig_ki - --- A quantifier from a kind signature zipped with a user-written binder for it. -data ZippedBinder = ZippedBinder TyBinder (Maybe (LHsTyVarBndr () GhcRn)) - --- See Note [Arity inference in kcCheckDeclHeader_sig] -zipBinders - :: Kind -- Kind signature - -> [LHsTyVarBndr () GhcRn] -- User-written binders - -> ( [ZippedBinder] -- Zipped binders - , [LHsTyVarBndr () GhcRn] -- Leftover user-written binders - , Kind ) -- Remainder of the kind signature -zipBinders = zip_binders [] emptyTCvSubst - where - -- subst: we substitute as we go, to ensure that the resulting - -- binders in the [ZippedBndr] all have distinct uniques. - -- If not, the TyCon may get multiple binders with the same unique, - -- which results in chaos (see #19092,3,4) - -- (The incoming kind might be forall k. k -> forall k. k -> Type - -- where those two k's have the same unique. Without the substitution - -- we'd get a repeated 'k'.) - zip_binders acc subst ki bs - | (b:bs') <- bs -- Stop as soon as 'bs' becomes empty - , Just (tb,ki') <- tcSplitPiTy_maybe ki - , let (subst', tb') = substTyCoBndr subst tb - = if isInvisibleBinder tb - then zip_binders (ZippedBinder tb' Nothing : acc) subst' ki' bs - else zip_binders (ZippedBinder tb' (Just b) : acc) subst' ki' bs' + go subst tcbs [] + = do { let (subst', tcbs') = substTyConBindersX subst tcbs + ; res <- thing_inside tcbs' (substTy subst' sig_res_kind) + ; return ([], res) } + + go _ [] hs_bndrs + = failWithTc (tooManyBindersErr sig_res_kind hs_bndrs) + + go subst (tcb : tcbs') hs_bndrs + | Bndr tv vis <- tcb + , isVisibleTcbVis vis + , (L _ hs_bndr : hs_bndrs') <- hs_bndrs -- hs_bndrs is non-empty + = -- Visible TyConBinder, so match up with the hs_bndrs + do { let tv' = updateTyVarKind (substTy subst) $ + setTyVarName tv (getName hs_bndr) + -- Give the skolem the Name of the HsTyVarBndr, so that if it + -- appears in an error message it has a name and binding site + -- that come from the type declaration, not the kind signature + subst' = extendTCvSubstWithClone subst tv tv' + ; tc_hs_bndr hs_bndr (tyVarKind tv') + ; (tcbs', res) <- tcExtendTyVarEnv [tv'] $ + go subst' tcbs' hs_bndrs' + ; return (Bndr tv' vis : tcbs', res) } | otherwise - = (reverse acc, bs, substTy subst ki) + = -- Invisible TyConBinder, so do not consume one of the hs_bndrs + do { let (subst', tcb') = substTyConBinderX subst tcb + ; (tcbs', res) <- go subst' tcbs' hs_bndrs + -- NB: pass on hs_bndrs unchanged; we do not consume a + -- HsTyVarBndr for an invisible TyConBinder + ; return (tcb' : tcbs', res) } + + tc_hs_bndr :: HsTyVarBndr () GhcRn -> TcKind -> TcM () + tc_hs_bndr (UserTyVar _ _ _) _ + = return () + tc_hs_bndr (KindedTyVar _ _ (L _ hs_nm) lhs_kind) expected_kind + = do { sig_kind <- tcLHsKindSig (TyVarBndrKindCtxt hs_nm) lhs_kind + ; discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] + unifyKind (Just (NameThing hs_nm)) sig_kind expected_kind } + +substTyConBinderX :: TCvSubst -> TyConBinder -> (TCvSubst, TyConBinder) +substTyConBinderX subst (Bndr tv vis) + = (subst', Bndr tv' vis) + where + (subst', tv') = substTyVarBndr subst tv + +substTyConBindersX :: TCvSubst -> [TyConBinder] -> (TCvSubst, [TyConBinder]) +substTyConBindersX = mapAccumL substTyConBinderX + +swizzleTcb :: VarEnv Name -> TCvSubst -> TyConBinder -> (TCvSubst, TyConBinder) +swizzleTcb swizzle_env subst (Bndr tv vis) + = (subst', Bndr tv2 vis) + where + subst' = extendTCvSubstWithClone subst tv tv2 + tv1 = updateTyVarKind (substTy subst) tv + tv2 = case lookupVarEnv swizzle_env tv of + Just user_name -> setTyVarName tv1 user_name + Nothing -> tv1 + -- NB: the SrcSpan on an implicitly-bound name deliberately spans + -- the whole declaration. e.g. + -- data T (a :: k) (b :: Type -> k) = .... + -- There is no single binding site for 'k'. + -- See Note [Source locations for implicitly bound type variables] + -- in GHC.Tc.Rename.HsType tooManyBindersErr :: Kind -> [LHsTyVarBndr () GhcRn] -> TcRnMessage tooManyBindersErr ki bndrs = TcRnUnknownMessage $ mkPlainError noHints $ @@ -2738,52 +2698,95 @@ tooManyBindersErr ki bndrs = TcRnUnknownMessage $ mkPlainError noHints $ hang (text "but extra binders found:") 4 (fsep (map ppr bndrs)) -{- Note [Arity inference in kcCheckDeclHeader_sig] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given a kind signature 'kisig' and a declaration header, kcCheckDeclHeader_sig -verifies that the declaration conforms to the signature. The end result is a -TcTyCon 'tc' such that: - - tyConKind tc == kisig - -This TcTyCon would be rather easy to produce if we didn't have to worry about -arity. Consider these declarations: - - type family S1 :: forall k. k -> Type - type family S2 (a :: k) :: Type +{- See Note [kcCheckDeclHeader_sig] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given a kind signature 'sig_kind' and a declaration header, +kcCheckDeclHeader_sig verifies that the declaration conforms to the +signature. The end result is a PolyTcTyCon 'tc' such that: + tyConKind tc == sig_kind + +Basic plan is this: + * splitTyConKind: Take the Kind from the separate kind signature, and + decompose it all the way to a [TyConBinder] and a Kind in the corner. + + NB: these TyConBinders contain TyVars, not TcTyVars. + + * matchUpSigWithDecl: match the [TyConBinder] from the signature with + the [LHsTyVarBndr () GhcRn] from the declaration. The latter are the + explicit, user-written binders. e.g. + data T (a :: k) b = .... + There may be more of the former than the latter, because the former + include invisible binders. matchUpSigWithDecl uses isVisibleTcbVis + to decide which TyConBinders are visible. + + * matchUpSigWithDecl also skolemises the [TyConBinder] to produce + a [TyConBinder], corresponding 1-1 with the consumed [TyConBinder]. + Each new TyConBinder + - Uses the Name from the LHsTyVarBndr, if available, both because that's + what the user expects, and because the binding site accurately comes + from the data/type declaration. + - Uses a skolem TcTyVar. We need these to allow unification. + + * machUpSigWithDecl also unifies the user-supplied kind signature for each + LHsTyVarBndr with the kind that comes from the TyConBinder (itself coming + from the separate kind signature). + + * Finally, kcCheckDeclHeader_sig unifies the return kind of the separate + signature with the kind signature (if any) in the data/type declaration. + E.g. + type S :: forall k. k -> k -> Type + type family S (a :: j) :: j -> Type + Here we match up the 'k ->' with (a :: j); and then must unify the leftover + part of the signature (k -> Type) with the kind signature of the decl, + (j -> Type). This unification, done in kcCheckDeclHeader, needs TcTyVars. + + * The tricky extra_arity part is described in + Note [Arity inference in kcCheckDeclHeader_sig] + +Note [Arity inference in kcCheckDeclHeader_sig] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider these declarations: + type family S1 :: forall k2. k1 -> k2 -> Type + type family S2 (a :: k1) (b :: k2) :: Type Both S1 and S2 can be given the same standalone kind signature: + type S1 :: forall k1 k2. k1 -> k2 -> Type + type S2 :: forall k1 k2. k1 -> k2 -> Type - type S2 :: forall k. k -> Type - -And, indeed, tyConKind S1 == tyConKind S2. However, tyConKind is built from -tyConBinders and tyConResKind, such that - - tyConKind tc == mkTyConKind (tyConBinders tc) (tyConResKind tc) +And, indeed, tyConKind S1 == tyConKind S2. However, +tyConBinders and tyConResKind for S1 and S2 are different: -For S1 and S2, tyConBinders and tyConResKind are different: + tyConBinders S1 == [spec k1] + tyConResKind S1 == forall k2. k1 -> k2 -> Type + tyConKind S1 == forall k1 k2. k1 -> k2 -> Type - tyConBinders S1 == [] - tyConResKind S1 == forall k. k -> Type - tyConKind S1 == forall k. k -> Type - - tyConBinders S2 == [spec k, anon-vis (a :: k)] + tyConBinders S2 == [spec k1, spec k2, anon-vis (a :: k1), anon-vis (b :: k2)] tyConResKind S2 == Type - tyConKind S1 == forall k. k -> Type - -This difference determines the arity: + tyConKind S1 == forall k1 k2. k1 -> k2 -> Type +This difference determines the /arity/: tyConArity tc == length (tyConBinders tc) +That is, the arity of S1 is 1, while the arity of S2 is 4. -That is, the arity of S1 is 0, while the arity of S2 is 2. +'kcCheckDeclHeader_sig' needs to infer the desired arity, to split the +standalone kind signature into binders and the result kind. It does so +in two rounds: -'kcCheckDeclHeader_sig' needs to infer the desired arity to split the standalone -kind signature into binders and the result kind. It does so in two rounds: +1. matchUpSigWithDecl matches up + - the [TyConBinder] from (applying splitTyConKind to) the kind signature + - with the [LHsTyVarBndr] from the type declaration. + That may leave some excess TyConBinder: in the case of S2 there are + no excess TyConBinders, but in the case of S1 there are two (since + there are no LHsTYVarBndrs. -1. zip user-written binders (vis_tcbs) -2. split off invisible binders (invis_tcbs) +2. Split off further TyConBinders (in the case of S1, one more) to + make it possible to unify the residual return kind with the + signature in the type declaration. More precisely, split off such + enough invisible that the remainder of the standalone kind + signature and the user-written result kind signature have the same + number of invisible quantifiers. -Consider the following declarations: +As another example consider the following declarations: type F :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type type family F a b @@ -2791,66 +2794,34 @@ Consider the following declarations: type G :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type type family G a b :: forall r2. (r1, r2) -> Type -In step 1 (zip user-written binders), we zip the quantifiers in the signature -with the binders in the header using 'zipBinders'. In both F and G, this results in -the following zipped binders: - - TyBinder LHsTyVarBndr - --------------------------------------- - ZippedBinder Type -> a - ZippedBinder forall j. - ZippedBinder j -> b - - -At this point, we have accumulated three zipped binders which correspond to a -prefix of the standalone kind signature: - - Type -> forall j. j -> ... - -In step 2 (split off invisible binders), we have to decide how much remaining -invisible binders of the standalone kind signature to split off: - - forall k1 k2. (k1, k2) -> Type - ^^^^^^^^^^^^^ - split off or not? - -This decision is made in 'split_invis': - -* If a user-written result kind signature is not provided, as in F, - then split off all invisible binders. This is why we need special treatment - for AnyKind. -* If a user-written result kind signature is provided, as in G, - then do as checkExpectedKind does and split off (n_sig - n_res) binders. - That is, split off such an amount of binders that the remainder of the - standalone kind signature and the user-written result kind signature have the - same amount of invisible quantifiers. - -For F, split_invis splits away all invisible binders, and we have 2: +For both F and G, the signature (after splitTyConKind) has + sig_tcbs :: [TyConBinder] + = [ anon-vis (@a_aBq), spec (@j_auA), anon-vis (@(b_aBr :: j_auA)) + , spec (@k1_auB), spec (@k2_auC) + , anon-vis (@(c_aBs :: (k1_auB, k2_auC)))] - forall k1 k2. (k1, k2) -> Type - ^^^^^^^^^^^^^ - split away both binders +matchUpSigWithDecl will consume the first three of these, passing on + excess_sig_tcbs + = [ spec (@k1_auB), spec (@k2_auC) + , anon-vis (@(c_aBs :: (k1_auB, k2_auC)))] -The resulting arity of F is 3+2=5. (length vis_tcbs = 3, - length invis_tcbs = 2, - length tcbs = 5) +For F, there is no result kind signature in the declaration for F, so +we absorb all invisible binders into F's arity. The resulting arity of +F is 3+2=5. -For G, split_invis decides to split off 1 invisible binder, so that we have the -same amount of invisible quantifiers left: +Now, in the case of G, we have a result kind sig 'forall r2. (r2,r2)->Type'. +This has one invisible binder, so we split of enough extra binders from +our excess_sig_tcbs to leave just one to match 'r2'. res_ki = forall r2. (r1, r2) -> Type kisig = forall k1 k2. (k1, k2) -> Type ^^^ split off this one. -The resulting arity of G is 3+1=4. (length vis_tcbs = 3, - length invis_tcbs = 1, - length tcbs = 4) +The resulting arity of G is 3+1=4. --} - -{- Note [discardResult in kcCheckDeclHeader_sig] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [discardResult in kcCheckDeclHeader_sig] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We use 'unifyKind' to check inline kind annotations in declaration headers against the signature. @@ -2982,12 +2953,12 @@ these first. ********************************************************************* -} -- | Describes the kind expected in a certain context. -data ContextKind = TheKind Kind -- ^ a specific kind +data ContextKind = TheKind TcKind -- ^ a specific kind | AnyKind -- ^ any kind will do | OpenKind -- ^ something of the form @TYPE _@ ----------------------- -newExpectedKind :: ContextKind -> TcM Kind +newExpectedKind :: ContextKind -> TcM TcKind newExpectedKind (TheKind k) = return k newExpectedKind AnyKind = newMetaKindVar newExpectedKind OpenKind = newOpenTypeKind @@ -3011,6 +2982,50 @@ expectedKindInCtxt _ = OpenKind {- ********************************************************************* * * + Scoped tyvars that map to the same thing +* * +********************************************************************* -} + +checkForDuplicateScopedTyVars :: [(Name,TcTyVar)] -> TcM () +-- Check for duplicates +-- E.g. data SameKind (a::k) (b::k) +-- data T (a::k1) (b::k2) c = MkT (SameKind a b) c +-- Here k1 and k2 start as TyVarTvs, and get unified with each other +-- If this happens, things get very confused later, so fail fast +-- +-- In the CUSK case k1 and k2 are skolems so they won't unify; +-- but in the inference case (see generaliseTcTyCon), +-- and the type-sig case (see kcCheckDeclHeader_sig), they are +-- TcTyVars, so we must check. +checkForDuplicateScopedTyVars scoped_prs + = unless (null err_prs) $ + do { mapM_ report_dup err_prs; failM } + where + -------------- Error reporting ------------ + err_prs :: [(Name,Name)] + err_prs = [ (n1,n2) + | prs :: NonEmpty (Name,TyVar) <- findDupsEq ((==) `on` snd) scoped_prs + , (n1,_) :| ((n2,_) : _) <- [NE.nubBy ((==) `on` fst) prs] ] + -- This nubBy avoids bogus error reports when we have + -- [("f", f), ..., ("f",f)....] in swizzle_prs + -- which happens with class C f where { type T f } + + report_dup :: (Name,Name) -> TcM () + report_dup (n1,n2) + = setSrcSpan (getSrcSpan n2) $ + addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Different names for the same type variable:") 2 info + where + info | nameOccName n1 /= nameOccName n2 + = quotes (ppr n1) <+> text "and" <+> quotes (ppr n2) + | otherwise -- Same OccNames! See C2 in + -- Note [Swizzling the tyvars before generaliseTcTyCon] + = vcat [ quotes (ppr n1) <+> text "bound at" <+> ppr (getSrcLoc n1) + , quotes (ppr n2) <+> text "bound at" <+> ppr (getSrcLoc n2) ] + + +{- ********************************************************************* +* * Bringing type variables into scope * * ********************************************************************* -} @@ -3023,20 +3038,26 @@ tcTKTelescope :: TcTyMode -> HsForAllTelescope GhcRn -> TcM a -> TcM ([TcTyVarBinder], a) +-- A HsForAllTelescope comes only from a HsForAllTy, +-- an explicit, user-written forall type tcTKTelescope mode tele thing_inside = case tele of HsForAllVis { hsf_vis_bndrs = bndrs } - -> do { (req_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside + -> do { skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> bndrs))) + ; let skol_mode = smVanilla { sm_clone = False, sm_holes = mode_holes mode + , sm_tvtv = SMDSkolemTv skol_info } + ; (req_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside -- req_tv_bndrs :: [VarBndr TyVar ()], -- but we want [VarBndr TyVar ArgFlag] ; return (tyVarReqToBinders req_tv_bndrs, thing) } HsForAllInvis { hsf_invis_bndrs = bndrs } - -> do { (inv_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside + -> do { skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> bndrs))) + ; let skol_mode = smVanilla { sm_clone = False, sm_holes = mode_holes mode + , sm_tvtv = SMDSkolemTv skol_info } + ; (inv_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside -- inv_tv_bndrs :: [VarBndr TyVar Specificity], -- but we want [VarBndr TyVar ArgFlag] ; return (tyVarSpecToBinders inv_tv_bndrs, thing) } - where - skol_mode = smVanilla { sm_clone = False, sm_holes = mode_holes mode } -------------------------------------- -- HsOuterTyVarBndrs @@ -3059,29 +3080,35 @@ bindOuterTKBndrsX skol_mode outer_bndrs thing_inside , hso_bndrs = exp_bndrs } , thing) } -getOuterTyVars :: HsOuterTyVarBndrs flag GhcTc -> [TcTyVar] +--------------- +outerTyVars :: HsOuterTyVarBndrs flag GhcTc -> [TcTyVar] -- The returned [TcTyVar] is not necessarily in dependency order -- at least for the HsOuterImplicit case -getOuterTyVars (HsOuterImplicit { hso_ximplicit = tvs }) = tvs -getOuterTyVars (HsOuterExplicit { hso_xexplicit = tvbs }) = binderVars tvbs +outerTyVars (HsOuterImplicit { hso_ximplicit = tvs }) = tvs +outerTyVars (HsOuterExplicit { hso_xexplicit = tvbs }) = binderVars tvbs + +--------------- +outerTyVarBndrs :: HsOuterTyVarBndrs Specificity GhcTc -> [InvisTVBinder] +outerTyVarBndrs (HsOuterImplicit{hso_ximplicit = imp_tvs}) = [Bndr tv SpecifiedSpec | tv <- imp_tvs] +outerTyVarBndrs (HsOuterExplicit{hso_xexplicit = exp_tvs}) = exp_tvs --------------- -scopedSortOuter :: HsOuterTyVarBndrs Specificity GhcTc -> TcM [InvisTVBinder] +scopedSortOuter :: HsOuterTyVarBndrs flag GhcTc -> TcM (HsOuterTyVarBndrs flag GhcTc) -- Sort any /implicit/ binders into dependency order -- (zonking first so we can see the dependencies) -- /Explicit/ ones are already in the right order scopedSortOuter (HsOuterImplicit{hso_ximplicit = imp_tvs}) = do { imp_tvs <- zonkAndScopedSort imp_tvs - ; return [Bndr tv SpecifiedSpec | tv <- imp_tvs] } -scopedSortOuter (HsOuterExplicit{hso_xexplicit = exp_tvs}) + ; return (HsOuterImplicit { hso_ximplicit = imp_tvs }) } +scopedSortOuter bndrs@(HsOuterExplicit{}) = -- No need to dependency-sort (or zonk) explicit quantifiers - return exp_tvs + return bndrs --------------- bindOuterSigTKBndrs_Tv :: HsOuterSigTyVarBndrs GhcRn -> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a) bindOuterSigTKBndrs_Tv - = bindOuterTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = True }) + = bindOuterTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv }) bindOuterSigTKBndrs_Tv_M :: TcTyMode -> HsOuterSigTyVarBndrs GhcRn @@ -3091,26 +3118,25 @@ bindOuterSigTKBndrs_Tv_M :: TcTyMode -- Note [Using TyVarTvs for kind-checking GADTs] in GHC.Tc.TyCl -- Note [Checking partial type signatures] bindOuterSigTKBndrs_Tv_M mode - = bindOuterTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = True + = bindOuterTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv , sm_holes = mode_holes mode }) bindOuterFamEqnTKBndrs_Q_Tv :: HsOuterFamEqnTyVarBndrs GhcRn -> TcM a - -> TcM ([TcTyVar], a) + -> TcM (HsOuterFamEqnTyVarBndrs GhcTc, a) bindOuterFamEqnTKBndrs_Q_Tv hs_bndrs thing_inside - = liftFstM getOuterTyVars $ - bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = True - , sm_tvtv = True }) + = bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = True + , sm_tvtv = SMDTyVarTv }) hs_bndrs thing_inside -- sm_clone=False: see Note [Cloning for type variable binders] -bindOuterFamEqnTKBndrs :: HsOuterFamEqnTyVarBndrs GhcRn +bindOuterFamEqnTKBndrs :: SkolemInfo + -> HsOuterFamEqnTyVarBndrs GhcRn -> TcM a - -> TcM ([TcTyVar], a) -bindOuterFamEqnTKBndrs hs_bndrs thing_inside - = liftFstM getOuterTyVars $ - bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = True }) - hs_bndrs thing_inside + -> TcM (HsOuterFamEqnTyVarBndrs GhcTc, a) +bindOuterFamEqnTKBndrs skol_info + = bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = True + , sm_tvtv = SMDSkolemTv skol_info }) -- sm_clone=False: see Note [Cloning for type variable binders] --------------- @@ -3118,7 +3144,10 @@ tcOuterTKBndrs :: OutputableBndrFlag flag 'Renamed => SkolemInfo -> HsOuterTyVarBndrs flag GhcRn -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a) -tcOuterTKBndrs = tcOuterTKBndrsX (smVanilla { sm_clone = False }) +tcOuterTKBndrs skol_info + = tcOuterTKBndrsX (smVanilla { sm_clone = False + , sm_tvtv = SMDSkolemTv skol_info }) + skol_info -- Do not clone the outer binders -- See Note [Cloning for type variable binder] under "must not" @@ -3144,63 +3173,88 @@ tcOuterTKBndrsX skol_mode skol_info outer_bndrs thing_inside -------------------------------------- tcExplicitTKBndrs :: OutputableBndrFlag flag 'Renamed - => [LHsTyVarBndr flag GhcRn] + => SkolemInfo + -> [LHsTyVarBndr flag GhcRn] -> TcM a -> TcM ([VarBndr TyVar flag], a) -tcExplicitTKBndrs = tcExplicitTKBndrsX (smVanilla { sm_clone = True }) +tcExplicitTKBndrs skol_info + = tcExplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDSkolemTv skol_info }) tcExplicitTKBndrsX :: OutputableBndrFlag flag 'Renamed => SkolemMode -> [LHsTyVarBndr flag GhcRn] -> TcM a -> TcM ([VarBndr TyVar flag], a) --- Push level, capture constraints, --- and emit an implication constraint with a ForAllSkol ic_info, --- so that it is subject to a telescope test. +-- Push level, capture constraints, and emit an implication constraint. +-- The implication constraint has a ForAllSkol ic_info, +-- so that it is subject to a telescope test. tcExplicitTKBndrsX skol_mode bndrs thing_inside + | null bndrs + = do { res <- thing_inside + ; return ([], res) } + + | otherwise = do { (tclvl, wanted, (skol_tvs, res)) <- pushLevelAndCaptureConstraints $ bindExplicitTKBndrsX skol_mode bndrs $ thing_inside - ; let skol_info = ForAllSkol (HsTyVarBndrsRn $ map unLoc bndrs) - -- Notice that we use ForAllSkol here, ignoring the enclosing - -- skol_info unlike tc_implicit_tk_bndrs, because the bad-telescope - -- test applies only to ForAllSkol - ; emitResidualTvConstraint skol_info (binderVars skol_tvs) tclvl wanted + -- Set up SkolemInfo for telescope test + ; let bndr_1 = head bndrs; bndr_n = last bndrs + ; skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> bndrs))) + -- Notice that we use ForAllSkol here, ignoring the enclosing + -- skol_info unlike tcImplicitTKBndrs, because the bad-telescope + -- test applies only to ForAllSkol + + ; setSrcSpan (combineSrcSpans (getLocA bndr_1) (getLocA bndr_n)) + $ emitResidualTvConstraint skol_info (binderVars skol_tvs) tclvl wanted ; return (skol_tvs, res) } ---------------- -- | Skolemise the 'HsTyVarBndr's in an 'HsForAllTelescope' with the supplied -- 'TcTyMode'. -bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv +bindExplicitTKBndrs_Skol + :: (OutputableBndrFlag flag 'Renamed) + => SkolemInfo + -> [LHsTyVarBndr flag GhcRn] + -> TcM a + -> TcM ([VarBndr TyVar flag], a) + +bindExplicitTKBndrs_Tv :: (OutputableBndrFlag flag 'Renamed) => [LHsTyVarBndr flag GhcRn] -> TcM a -> TcM ([VarBndr TyVar flag], a) -bindExplicitTKBndrs_Skol = bindExplicitTKBndrsX (smVanilla { sm_clone = False }) -bindExplicitTKBndrs_Tv = bindExplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = True }) +bindExplicitTKBndrs_Skol skol_info = bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_tvtv = SMDSkolemTv skol_info }) +bindExplicitTKBndrs_Tv = bindExplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv }) -- sm_clone: see Note [Cloning for type variable binders] -bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Q_Tv +bindExplicitTKBndrs_Q_Skol + :: SkolemInfo + -> ContextKind + -> [LHsTyVarBndr () GhcRn] + -> TcM a + -> TcM ([TcTyVar], a) + +bindExplicitTKBndrs_Q_Tv :: ContextKind -> [LHsTyVarBndr () GhcRn] -> TcM a -> TcM ([TcTyVar], a) -- These do not clone: see Note [Cloning for type variable binders] -bindExplicitTKBndrs_Q_Skol ctxt_kind hs_bndrs thing_inside +bindExplicitTKBndrs_Q_Skol skol_info ctxt_kind hs_bndrs thing_inside = liftFstM binderVars $ bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True - , sm_kind = ctxt_kind }) + , sm_kind = ctxt_kind, sm_tvtv = SMDSkolemTv skol_info }) hs_bndrs thing_inside -- sm_clone=False: see Note [Cloning for type variable binders] -bindExplicitTKBndrs_Q_Tv ctxt_kind hs_bndrs thing_inside +bindExplicitTKBndrs_Q_Tv ctxt_kind hs_bndrs thing_inside = liftFstM binderVars $ bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True - , sm_tvtv = True, sm_kind = ctxt_kind }) + , sm_tvtv = SMDTyVarTv, sm_kind = ctxt_kind }) hs_bndrs thing_inside -- sm_clone=False: see Note [Cloning for type variable binders] @@ -3264,9 +3318,10 @@ newTyVarBndr (SM { sm_clone = clone, sm_tvtv = tvtv }) name kind ; return (setNameUnique name uniq) } False -> return name ; details <- case tvtv of - True -> newMetaDetails TyVarTv - False -> do { lvl <- getTcLevel - ; return (SkolemTv lvl False) } + SMDTyVarTv -> newMetaDetails TyVarTv + SMDSkolemTv skol_info -> + do { lvl <- getTcLevel + ; return (SkolemTv skol_info lvl False) } ; return (mkTcTyVar name kind details) } -------------------------------------- @@ -3278,9 +3333,7 @@ tcImplicitTKBndrsX :: SkolemMode -> SkolemInfo -> TcM a -> TcM ([TcTyVar], a) -- The workhorse: --- push level, capture constraints, --- and emit an implication constraint with a ForAllSkol ic_info, --- so that it is subject to a telescope test. +-- push level, capture constraints, and emit an implication constraint tcImplicitTKBndrsX skol_mode skol_info bndrs thing_inside | null bndrs -- Short-cut the common case with no quantifiers -- E.g. f :: Int -> Int @@ -3298,17 +3351,18 @@ tcImplicitTKBndrsX skol_mode skol_info bndrs thing_inside ; return (skol_tvs, res) } ------------------ -bindImplicitTKBndrs_Skol, bindImplicitTKBndrs_Tv, - bindImplicitTKBndrs_Q_Skol, bindImplicitTKBndrs_Q_Tv - :: [Name] -> TcM a -> TcM ([TcTyVar], a) -bindImplicitTKBndrs_Skol = bindImplicitTKBndrsX (smVanilla { sm_clone = True }) -bindImplicitTKBndrs_Tv = bindImplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = True }) -bindImplicitTKBndrs_Q_Skol = bindImplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True }) -bindImplicitTKBndrs_Q_Tv = bindImplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True, sm_tvtv = True }) +bindImplicitTKBndrs_Skol, + bindImplicitTKBndrs_Q_Skol :: SkolemInfo -> [Name] -> TcM a -> TcM ([TcTyVar], a) + +bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Q_Tv :: [Name] -> TcM a -> TcM ([TcTyVar], a) +bindImplicitTKBndrs_Skol skol_info = bindImplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDSkolemTv skol_info }) +bindImplicitTKBndrs_Tv = bindImplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv }) +bindImplicitTKBndrs_Q_Skol skol_info = bindImplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True, sm_tvtv = SMDSkolemTv skol_info }) +bindImplicitTKBndrs_Q_Tv = bindImplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True, sm_tvtv = SMDTyVarTv }) bindImplicitTKBndrsX :: SkolemMode - -> [Name] + -> [Name] -- Generated by renamer; not in dependency order -> TcM a -> TcM ([TcTyVar], a) -- Returned [TcTyVar] are in 1-1 correspondence -- with the passed in [Name] @@ -3343,7 +3397,7 @@ data SkolemMode , sm_clone :: Bool -- True <=> fresh unique -- See Note [Cloning for type variable binders] - , sm_tvtv :: Bool -- True <=> use a TyVarTv, rather than SkolemTv + , sm_tvtv :: SkolemModeDetails -- True <=> use a TyVarTv, rather than SkolemTv -- Why? See Note [Inferring kinds for type declarations] -- in GHC.Tc.TyCl, and (in this module) -- Note [Checking partial type signatures] @@ -3353,10 +3407,15 @@ data SkolemMode , sm_holes :: HoleInfo -- What to do for wildcards in the kind } -smVanilla :: SkolemMode +data SkolemModeDetails + = SMDTyVarTv + | SMDSkolemTv SkolemInfo + + +smVanilla :: HasCallStack => SkolemMode smVanilla = SM { sm_clone = panic "sm_clone" -- We always override this , sm_parent = False - , sm_tvtv = False + , sm_tvtv = pprPanic "sm_tvtv" callStackDoc -- We always override this , sm_kind = AnyKind , sm_holes = Nothing } @@ -3432,19 +3491,28 @@ When we /must/ clone. -- kind-checking and typechecking phases -------------------------------------- -bindTyClTyVars :: Name - -> (TcTyCon -> [TyConBinder] -> Kind -> TcM a) -> TcM a --- ^ Used for the type variables of a type or class decl +bindTyClTyVars :: Name -> ([TcTyConBinder] -> TcKind -> TcM a) -> TcM a +-- ^ Bring into scope the binders of a PolyTcTyCon +-- Used for the type variables of a type or class decl -- in the "kind checking" and "type checking" pass, -- but not in the initial-kind run. bindTyClTyVars tycon_name thing_inside - = do { tycon <- tcLookupTcTyCon tycon_name - ; let scoped_prs = tcTyConScopedTyVars tycon - res_kind = tyConResKind tycon + = do { tycon <- tcLookupTcTyCon tycon_name -- The tycon is a PolyTcTyCon + ; let res_kind = tyConResKind tycon binders = tyConBinders tycon - ; traceTc "bindTyClTyVars" (ppr tycon_name <+> ppr binders $$ ppr scoped_prs) - ; tcExtendNameTyVarEnv scoped_prs $ - thing_inside tycon binders res_kind } + ; traceTc "bindTyClTyVars" (ppr tycon_name $$ ppr binders) + ; tcExtendTyVarEnv (binderVars binders) $ + thing_inside binders res_kind } + +bindTyClTyVarsAndZonk :: Name -> ([TyConBinder] -> Kind -> TcM a) -> TcM a +-- Like bindTyClTyVars, but in addition +-- zonk the skolem TcTyVars of a PolyTcTyCon to TyVars +bindTyClTyVarsAndZonk tycon_name thing_inside + = bindTyClTyVars tycon_name $ \ tc_bndrs tc_kind -> + do { ze <- mkEmptyZonkEnv NoFlexi + ; (ze, bndrs) <- zonkTyVarBindersX ze tc_bndrs + ; kind <- zonkTcTypeToTypeX ze tc_kind + ; thing_inside bndrs kind } {- ********************************************************************* @@ -3455,7 +3523,7 @@ bindTyClTyVars tycon_name thing_inside zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar] zonkAndScopedSort spec_tkvs - = do { spec_tkvs <- mapM zonkTcTyVarToTyVar spec_tkvs + = do { spec_tkvs <- zonkTcTyVarsToTcTyVars spec_tkvs -- Zonk the kinds, to we can do the dependency analayis -- Do a stable topological sort, following @@ -3484,16 +3552,17 @@ zonkAndScopedSort spec_tkvs -- The resulting KindVar are the variables to quantify over, in the -- correct, well-scoped order. They should generally be Inferred, not -- Specified, but that's really up to the caller of this function. -kindGeneralizeSome :: WantedConstraints +kindGeneralizeSome :: SkolemInfo + -> WantedConstraints -> TcType -- ^ needn't be zonked -> TcM [KindVar] -kindGeneralizeSome wanted kind_or_type +kindGeneralizeSome skol_info wanted kind_or_type = do { -- Use the "Kind" variant here, as any types we see -- here will already have all type variables quantified; -- thus, every free variable is really a kv, never a tv. ; dvs <- candidateQTyVarsOfKind kind_or_type ; dvs <- filterConstrainedCandidates wanted dvs - ; quantifyTyVars DefaultNonStandardTyVars dvs } + ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs } filterConstrainedCandidates :: WantedConstraints -- Don't quantify over variables free in these @@ -3517,11 +3586,11 @@ filterConstrainedCandidates wanted dvs -- |- Specialised version of 'kindGeneralizeSome', but with empty -- WantedConstraints, so no filtering is needed -- i.e. kindGeneraliseAll = kindGeneralizeSome emptyWC -kindGeneralizeAll :: TcType -> TcM [KindVar] -kindGeneralizeAll kind_or_type +kindGeneralizeAll :: SkolemInfo -> TcType -> TcM [KindVar] +kindGeneralizeAll skol_info kind_or_type = do { traceTc "kindGeneralizeAll" (ppr kind_or_type) ; dvs <- candidateQTyVarsOfKind kind_or_type - ; quantifyTyVars DefaultNonStandardTyVars dvs } + ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs } -- | Specialized version of 'kindGeneralizeSome', but where no variables -- can be generalized, but perhaps some may need to be promoted. @@ -3602,54 +3671,78 @@ Hence using zonked_kinds when forming tvs'. -} ----------------------------------- -etaExpandAlgTyCon :: [TyConBinder] - -> Kind -- must be zonked - -> TcM ([TyConBinder], Kind) +etaExpandAlgTyCon :: TyConFlavour -> SkolemInfo + -> [TcTyConBinder] -> Kind + -> TcM ([TcTyConBinder], Kind) +etaExpandAlgTyCon flav skol_info tcbs res_kind + | needsEtaExpansion flav + = splitTyConKind skol_info in_scope avoid_occs res_kind + | otherwise + = return ([], res_kind) + where + tyvars = binderVars tcbs + in_scope = mkInScopeSet (mkVarSet tyvars) + avoid_occs = map getOccName tyvars + +needsEtaExpansion :: TyConFlavour -> Bool +needsEtaExpansion NewtypeFlavour = True +needsEtaExpansion DataTypeFlavour = True +needsEtaExpansion ClassFlavour = True +needsEtaExpansion _ = False + +splitTyConKind :: SkolemInfo + -> InScopeSet + -> [OccName] -- Avoid these OccNames + -> Kind -- Must be zonked + -> TcM ([TcTyConBinder], TcKind) -- GADT decls can have a (perhaps partial) kind signature -- e.g. data T a :: * -> * -> * where ... -- This function makes up suitable (kinded) TyConBinders for the -- argument kinds. E.g. in this case it might return -- ([b::*, c::*], *) +-- Skolemises the type as it goes, returning skolem TcTyVars -- Never emits constraints. --- It's a little trickier than you might think: see --- Note [TyConBinders for the result kind signature of a data type] --- See Note [Datatype return kinds] in GHC.Tc.TyCl -etaExpandAlgTyCon tc_bndrs kind +-- It's a little trickier than you might think: see Note [splitTyConKind] +-- See also Note [Datatype return kinds] in GHC.Tc.TyCl +splitTyConKind skol_info in_scope avoid_occs kind = do { loc <- getSrcSpanM ; uniqs <- newUniqueSupply ; rdr_env <- getLocalRdrEnv + ; lvl <- getTcLevel ; let new_occs = [ occ | str <- allNameStrings , let occ = mkOccName tvName str , isNothing (lookupLocalRdrOcc rdr_env occ) -- Note [Avoid name clashes for associated data types] - , not (occ `elem` lhs_occs) ] + , not (occ `elem` avoid_occs) ] new_uniqs = uniqsFromSupply uniqs - subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet lhs_tvs)) - ; return (go loc new_occs new_uniqs subst [] kind) } - where - lhs_tvs = map binderVar tc_bndrs - lhs_occs = map getOccName lhs_tvs - - go loc occs uniqs subst acc kind - = case splitPiTy_maybe kind of - Nothing -> (reverse acc, substTy subst kind) - - Just (Anon af arg, kind') - -> go loc occs' uniqs' subst' (tcb : acc) kind' - where - arg' = substTy subst (scaledThing arg) - tv = mkTyVar (mkInternalName uniq occ loc) arg' - subst' = extendTCvInScope subst tv - tcb = Bndr tv (AnonTCB af) - (uniq:uniqs') = uniqs - (occ:occs') = occs - - Just (Named (Bndr tv vis), kind') - -> go loc occs uniqs subst' (tcb : acc) kind' - where - (subst', tv') = substTyVarBndr subst tv - tcb = Bndr tv' (NamedTCB vis) + subst = mkEmptyTCvSubst in_scope + details = SkolemTv skol_info (pushTcLevel lvl) False + -- As always, allocate skolems one level in + + go occs uniqs subst acc kind + = case splitPiTy_maybe kind of + Nothing -> (reverse acc, substTy subst kind) + + Just (Anon af arg, kind') + -> go occs' uniqs' subst' (tcb : acc) kind' + where + tcb = Bndr tv (AnonTCB af) + arg' = substTy subst (scaledThing arg) + name = mkInternalName uniq occ loc + tv = mkTcTyVar name arg' details + subst' = extendTCvInScope subst tv + (uniq:uniqs') = uniqs + (occ:occs') = occs + + Just (Named (Bndr tv vis), kind') + -> go occs uniqs subst' (tcb : acc) kind' + where + tcb = Bndr tv' (NamedTCB vis) + tc_tyvar = mkTcTyVar (tyVarName tv) (tyVarKind tv) details + (subst', tv') = substTyVarBndr subst tc_tyvar + + ; return (go new_occs new_uniqs subst [] kind) } -- | A description of whether something is a -- @@ -3834,33 +3927,48 @@ tcbVisibilities tc orig_args = pprPanic "addTcbVisibilities" (ppr tc <+> ppr orig_args) -{- Note [TyConBinders for the result kind signature of a data type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [splitTyConKind] +~~~~~~~~~~~~~~~~~~~~~~~~ Given data T (a::*) :: * -> forall k. k -> * we want to generate the extra TyConBinders for T, so we finally get (a::*) (b::*) (k::*) (c::k) -The function etaExpandAlgTyCon generates these extra TyConBinders from -the result kind signature. +The function splitTyConKind generates these extra TyConBinders from +the result kind signature. The same function is also used by +kcCheckDeclHeader_sig to get the [TyConBinder] from the Kind of +the TyCon given in a standalone kind signature. E.g. + type T :: forall (a::*). * -> forall k. k -> * We need to take care to give the TyConBinders - (a) OccNames that are fresh (because the TyConBinders of a TyCon - must have distinct OccNames - - (b) Uniques that are fresh (obviously) - -For (a) we need to avoid clashes with the tyvars declared by -the user before the "::"; in the above example that is 'a'. -And also see Note [Avoid name clashes for associated data types]. - -For (b) suppose we have + (a) Uniques that are fresh: the TyConBinders of a TyCon + must have distinct uniques. + + (b) Preferably, OccNames that are fresh. If we happen to re-use + OccNames that are other TyConBinders, we'll get a TyCon with + TyConBinders like [a_72, a_53]; same OccName, different Uniques. + Then when pretty-printing (e.g. in GHCi :info) we'll see + data T a a0 + whereas we'd prefer + data T a b + (NB: the tidying happens in the conversion to Iface syntax, + which happens as part of pretty-printing a TyThing.) + + Using fresh OccNames is not essential; it's cosmetic. + And also see Note [Avoid name clashes for associated data types]. + +For (a) perhaps surprisingly, duplicated uniques can happen, even if +we use fresh uniques for Anon arrows. Consider data T :: forall k. k -> forall k. k -> * where the two k's are identical even up to their uniques. Surprisingly, -this can happen: see #14515. +this can happen: see #14515, #19092,3,4. Then if we use those k's in +as TyConBinders we'll get duplicated uniques. + +For (b) we'd like to avoid OccName clashes with the tyvars declared by +the user before the "::"; in the above example that is 'a'. It's reasonably easy to solve all this; just run down the list with a -substitution; hence the recursive 'go' function. But it has to be -done. +substitution; hence the recursive 'go' function. But for the Uniques +it has to be done. Note [Avoid name clashes for associated data types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -3919,7 +4027,8 @@ tcHsPartialSigType ctxt sig_ty ; return (wcs, wcx, theta, tau) } ; traceTc "tcHsPartialSigType 2" empty - ; outer_tv_bndrs <- scopedSortOuter outer_bndrs + ; outer_bndrs <- scopedSortOuter outer_bndrs + ; let outer_tv_bndrs = outerTyVarBndrs outer_bndrs ; traceTc "tcHsPartialSigType 3" empty -- No kind-generalization here: @@ -4150,7 +4259,9 @@ tcHsPatSigType ctxt hole_mode new_implicit_tv name = do { kind <- newMetaKindVar ; tv <- case ctxt of - RuleSigCtxt {} -> newSkolemTyVar name kind + RuleSigCtxt rname _ -> do + skol_info <- mkSkolemInfo (RuleSkol rname) + newSkolemTyVar skol_info name kind _ -> newPatSigTyVar name kind -- See Note [Typechecking pattern signature binders] -- NB: tv's Name may be fresh (in the case of newPatSigTyVar) diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs index 2fbd7dcf8c..121b4b2d94 100644 --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -912,7 +912,11 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty_scaled -- We want to create a well-kinded substitution, so -- that the instantiated type is well-kinded - ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX tenv1 ex_tvs + ; let mc = case pe_ctxt penv of + LamPat mc -> mc + LetPat {} -> PatBindRhs + ; skol_info <- mkSkolemInfo (PatSkol (RealDataCon data_con) mc) + ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX skol_info tenv1 ex_tvs -- Get location from monad, not from ex_tvs -- This freshens: See Note [Freshen existentials] -- Why "super"? See Note [Binding when lookup up instances] @@ -953,16 +957,12 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty_scaled { let theta' = substTheta tenv (eqSpecPreds eq_spec ++ theta) -- order is *important* as we generate the list of -- dictionary binders from theta' - skol_info = PatSkol (RealDataCon data_con) mc - mc = case pe_ctxt penv of - LamPat mc -> mc - LetPat {} -> PatBindRhs ; when (not (null eq_spec) || any isEqPred theta) warnMonoLocalBinds ; given <- newEvVars theta' ; (ev_binds, (arg_pats', res)) - <- checkConstraints skol_info ex_tvs' given $ + <- checkConstraints (getSkolemInfo skol_info) ex_tvs' given $ tcConArgs (RealDataCon data_con) arg_tys_scaled tenv penv arg_pats thing_inside ; let res_pat = ConPat @@ -993,7 +993,11 @@ tcPatSynPat penv (L con_span con_name) pat_syn pat_ty arg_pats thing_inside ; let all_arg_tys = ty : prov_theta ++ (map scaledThing arg_tys) ; checkGADT (PatSynCon pat_syn) ex_tvs all_arg_tys penv - ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs + ; skol_info <- case pe_ctxt penv of + LamPat mc -> mkSkolemInfo (PatSkol (PatSynCon pat_syn) mc) + LetPat {} -> return unkSkol -- Doesn't matter + + ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX skol_info subst ex_tvs -- This freshens: Note [Freshen existentials] ; let ty' = substTy tenv ty @@ -1019,9 +1023,6 @@ tcPatSynPat penv (L con_span con_name) pat_syn pat_ty arg_pats thing_inside ; prov_dicts' <- newEvVars prov_theta' - ; let skol_info = case pe_ctxt penv of - LamPat mc -> PatSkol (PatSynCon pat_syn) mc - LetPat {} -> UnkSkol -- Doesn't matter ; req_wrap <- instCall (OccurrenceOf con_name) (mkTyVarTys univ_tvs') req_theta' -- Origin (OccurrenceOf con_name): @@ -1030,7 +1031,7 @@ tcPatSynPat penv (L con_span con_name) pat_syn pat_ty arg_pats thing_inside ; traceTc "checkConstraints {" Outputable.empty ; (ev_binds, (arg_pats', res)) - <- checkConstraints skol_info ex_tvs' prov_dicts' $ + <- checkConstraints (getSkolemInfo skol_info) ex_tvs' prov_dicts' $ tcConArgs (PatSynCon pat_syn) arg_tys_scaled tenv penv arg_pats thing_inside ; traceTc "checkConstraints }" (ppr ev_binds) diff --git a/compiler/GHC/Tc/Gen/Rule.hs b/compiler/GHC/Tc/Gen/Rule.hs index 40e4d55ecf..4aa3a764a8 100644 --- a/compiler/GHC/Tc/Gen/Rule.hs +++ b/compiler/GHC/Tc/Gen/Rule.hs @@ -28,7 +28,7 @@ import GHC.Tc.Types.Evidence( mkTcCoVarCo ) import GHC.Core.Type import GHC.Core.TyCon( isTypeFamilyTyCon ) import GHC.Types.Id -import GHC.Types.Var( EvVar ) +import GHC.Types.Var( EvVar, tyVarName ) import GHC.Types.Var.Set import GHC.Types.Basic ( RuleName, NonStandardDefaultingStrategy(..) ) import GHC.Types.SrcLoc @@ -119,10 +119,10 @@ tcRule (HsRule { rd_ext = ext , rd_rhs = rhs }) = addErrCtxt (ruleCtxt name) $ do { traceTc "---- Rule ------" (pprFullRuleName rname) - + ; skol_info <- mkSkolemInfo (RuleSkol name) -- Note [Typechecking rules] ; (tc_lvl, stuff) <- pushTcLevelM $ - generateRuleConstraints ty_bndrs tm_bndrs lhs rhs + generateRuleConstraints name ty_bndrs tm_bndrs lhs rhs ; let (id_bndrs, lhs', lhs_wanted , rhs', rhs_wanted, rule_ty) = stuff @@ -151,11 +151,13 @@ tcRule (HsRule { rd_ext = ext -- See Note [Re-quantify type variables in rules] ; forall_tkvs <- candidateQTyVarsOfTypes (rule_ty : map idType tpl_ids) - ; qtkvs <- quantifyTyVars DefaultNonStandardTyVars forall_tkvs + ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars forall_tkvs ; traceTc "tcRule" (vcat [ pprFullRuleName rname , ppr forall_tkvs , ppr qtkvs , ppr rule_ty + , ppr ty_bndrs + , ppr (qtkvs ++ tpl_ids) , vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ] ]) @@ -164,12 +166,10 @@ tcRule (HsRule { rd_ext = ext -- For the LHS constraints we must solve the remaining constraints -- (a) so that we report insoluble ones -- (b) so that we bind any soluble ones - ; let skol_info = RuleSkol name - ; (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl skol_info qtkvs + ; (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs lhs_evs residual_lhs_wanted - ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl skol_info qtkvs + ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs lhs_evs rhs_wanted - ; emitImplications (lhs_implic `unionBags` rhs_implic) ; return $ HsRule { rd_ext = ext , rd_name = rname @@ -180,21 +180,21 @@ tcRule (HsRule { rd_ext = ext , rd_lhs = mkHsDictLet lhs_binds lhs' , rd_rhs = mkHsDictLet rhs_binds rhs' } } -generateRuleConstraints :: Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn] +generateRuleConstraints :: FastString + -> Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn] -> LHsExpr GhcRn -> LHsExpr GhcRn -> TcM ( [TcId] , LHsExpr GhcTc, WantedConstraints , LHsExpr GhcTc, WantedConstraints , TcType ) -generateRuleConstraints ty_bndrs tm_bndrs lhs rhs +generateRuleConstraints rule_name ty_bndrs tm_bndrs lhs rhs = do { ((tv_bndrs, id_bndrs), bndr_wanted) <- captureConstraints $ - tcRuleBndrs ty_bndrs tm_bndrs + tcRuleBndrs rule_name ty_bndrs tm_bndrs -- bndr_wanted constraints can include wildcard hole -- constraints, which we should not forget about. -- It may mention the skolem type variables bound by -- the RULE. c.f. #10072 - - ; tcExtendTyVarEnv tv_bndrs $ + ; tcExtendNameTyVarEnv [(tyVarName tv, tv) | tv <- tv_bndrs] $ tcExtendIdEnv id_bndrs $ do { -- See Note [Solve order for RULES] ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs) @@ -204,38 +204,39 @@ generateRuleConstraints ty_bndrs tm_bndrs lhs rhs ; return (id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } } -- See Note [TcLevel in type checking rules] -tcRuleBndrs :: Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn] +tcRuleBndrs :: FastString -> Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn] -> TcM ([TcTyVar], [Id]) -tcRuleBndrs (Just bndrs) xs - = do { (tybndrs1,(tys2,tms)) <- bindExplicitTKBndrs_Skol bndrs $ - tcRuleTmBndrs xs +tcRuleBndrs rule_name (Just bndrs) xs + = do { skol_info <- mkSkolemInfo (RuleSkol rule_name) + ; (tybndrs1,(tys2,tms)) <- bindExplicitTKBndrs_Skol skol_info bndrs $ + tcRuleTmBndrs rule_name xs ; let tys1 = binderVars tybndrs1 ; return (tys1 ++ tys2, tms) } -tcRuleBndrs Nothing xs - = tcRuleTmBndrs xs +tcRuleBndrs rule_name Nothing xs + = tcRuleTmBndrs rule_name xs -- See Note [TcLevel in type checking rules] -tcRuleTmBndrs :: [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id]) -tcRuleTmBndrs [] = return ([],[]) -tcRuleTmBndrs (L _ (RuleBndr _ (L _ name)) : rule_bndrs) +tcRuleTmBndrs :: FastString -> [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id]) +tcRuleTmBndrs _ [] = return ([],[]) +tcRuleTmBndrs rule_name (L _ (RuleBndr _ (L _ name)) : rule_bndrs) = do { ty <- newOpenFlexiTyVarTy - ; (tyvars, tmvars) <- tcRuleTmBndrs rule_bndrs + ; (tyvars, tmvars) <- tcRuleTmBndrs rule_name rule_bndrs ; return (tyvars, mkLocalId name Many ty : tmvars) } -tcRuleTmBndrs (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs) +tcRuleTmBndrs rule_name (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs) -- e.g x :: a->a -- The tyvar 'a' is brought into scope first, just as if you'd written -- a::*, x :: a->a -- If there's an explicit forall, the renamer would have already reported an -- error for each out-of-scope type variable used - = do { let ctxt = RuleSigCtxt name + = do { let ctxt = RuleSigCtxt rule_name name ; (_ , tvs, id_ty) <- tcHsPatSigType ctxt HM_Sig rn_ty OpenKind ; let id = mkLocalId name Many id_ty -- See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType -- The type variables scope over subsequent bindings; yuk ; (tyvars, tmvars) <- tcExtendNameTyVarEnv tvs $ - tcRuleTmBndrs rule_bndrs + tcRuleTmBndrs rule_name rule_bndrs ; return (map snd tvs ++ tyvars, id : tmvars) } ruleCtxt :: FastString -> SDoc diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs index 34ae24d68c..82a3290e4c 100644 --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -406,12 +406,12 @@ tcPatSynSig name sig_ty@(L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = hs_ty , (ex_hs_tvbndrs, hs_prov, hs_body_ty) <- splitLHsSigmaTyInvis hs_ty1 = do { traceTc "tcPatSynSig 1" (ppr sig_ty) - ; let skol_info = DataConSkol name + ; skol_info <- mkSkolemInfo (DataConSkol name) ; (tclvl, wanted, (outer_bndrs, (ex_bndrs, (req, prov, body_ty)))) <- pushLevelAndSolveEqualitiesX "tcPatSynSig" $ -- See Note [solveEqualities in tcPatSynSig] - tcOuterTKBndrs skol_info hs_outer_bndrs $ - tcExplicitTKBndrs ex_hs_tvbndrs $ + tcOuterTKBndrs skol_info hs_outer_bndrs $ + tcExplicitTKBndrs skol_info ex_hs_tvbndrs $ do { req <- tcHsContext hs_req ; prov <- tcHsContext hs_prov ; body_ty <- tcHsOpenType hs_body_ty @@ -432,7 +432,7 @@ tcPatSynSig name sig_ty@(L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = hs_ty ; let ungen_patsyn_ty = build_patsyn_type implicit_bndrs univ_bndrs req ex_bndrs prov body_ty ; traceTc "tcPatSynSig" (ppr ungen_patsyn_ty) - ; kvs <- kindGeneralizeAll ungen_patsyn_ty + ; kvs <- kindGeneralizeAll skol_info ungen_patsyn_ty ; reportUnsolvedEqualities skol_info kvs tclvl wanted -- See Note [Report unsolved equalities in tcPatSynSig] diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index 006da15def..fe6ec75568 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -1692,16 +1692,16 @@ reifyInstances' th_nm th_tys rnImplicitTvOccs Nothing tv_rdrs $ \ tv_names -> do { (rn_ty, fvs) <- rnLHsType doc rdr_ty ; return ((tv_names, rn_ty), fvs) } - + ; skol_info <- mkSkolemInfo ReifySkol ; (tclvl, wanted, (tvs, ty)) <- pushLevelAndSolveEqualitiesX "reifyInstances" $ - bindImplicitTKBndrs_Skol tv_names $ + bindImplicitTKBndrs_Skol skol_info tv_names $ tcInferLHsType rn_ty ; tvs <- zonkAndScopedSort tvs -- Avoid error cascade if there are unsolved - ; reportUnsolvedEqualities ReifySkol tvs tclvl wanted + ; reportUnsolvedEqualities skol_info tvs tclvl wanted ; ty <- zonkTcTypeToType ty -- Substitute out the meta type variables diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 1d77f1b593..505f0dd627 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -79,7 +79,6 @@ import GHC.Tc.Gen.Default import GHC.Tc.Utils.Env import GHC.Tc.Gen.Rule import GHC.Tc.Gen.Foreign -import GHC.Tc.TyCl.Class ( ClassScopedTVEnv ) import GHC.Tc.TyCl.Instance import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType @@ -712,7 +711,7 @@ tcRnHsBootDecls hsc_src decls -- Typecheck type/class/instance decls ; traceTc "Tc2 (boot)" empty - ; (tcg_env, inst_infos, _deriv_binds, _class_scoped_tv_env, _th_bndrs) + ; (tcg_env, inst_infos, _deriv_binds, _th_bndrs) <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ; setGblEnv tcg_env $ do { @@ -1471,7 +1470,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, -- Source-language instances, including derivings, -- and import the supporting declarations traceTc "Tc3" empty ; - (tcg_env, inst_infos, class_scoped_tv_env, th_bndrs, + (tcg_env, inst_infos, th_bndrs, XValBindsLR (NValBinds deriv_binds deriv_sigs)) <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ; @@ -1514,8 +1513,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, -- Second pass over class and instance declarations, -- now using the kind-checked decls traceTc "Tc6" empty ; - inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) - inst_infos class_scoped_tv_env ; + inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ; -- Foreign exports traceTc "Tc7" empty ; @@ -1754,7 +1752,6 @@ tcTyClsInstDecls :: [TyClGroup GhcRn] [InstInfo GhcRn], -- Source-code instance decls to -- process; contains all dfuns for -- this module - ClassScopedTVEnv, -- Class scoped type variables ThBindEnv, -- TH binding levels HsValBinds GhcRn) -- Supporting bindings for derived -- instances @@ -1762,7 +1759,7 @@ tcTyClsInstDecls :: [TyClGroup GhcRn] tcTyClsInstDecls tycl_decls deriv_decls binds = tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $ tcAddPatSynPlaceholders (getPatSynBinds binds) $ - do { (tcg_env, inst_info, deriv_info, class_scoped_tv_env, th_bndrs) + do { (tcg_env, inst_info, deriv_info, th_bndrs) <- tcTyAndClassDecls tycl_decls ; ; setGblEnv tcg_env $ do { -- With the @TyClDecl@s and @InstDecl@s checked we're ready to @@ -1776,8 +1773,7 @@ tcTyClsInstDecls tycl_decls deriv_decls binds <- tcInstDeclsDeriv deriv_info deriv_decls ; setGblEnv tcg_env' $ do { failIfErrsM - ; pure ( tcg_env', inst_info' ++ inst_info - , class_scoped_tv_env, th_bndrs, val_binds ) + ; pure ( tcg_env', inst_info' ++ inst_info, th_bndrs, val_binds ) }}} {- ********************************************************************* @@ -2654,7 +2650,7 @@ tcRnType hsc_env flexi normalise rdr_type ; massertPpr (isEmptyBag empty_binds) (ppr empty_binds) -- Do kind generalisation; see Note [Kind-generalise in tcRnType] - ; kvs <- kindGeneralizeAll kind + ; kvs <- kindGeneralizeAll unkSkol kind ; e <- mkEmptyZonkEnv flexi ; ty <- zonkTcTypeToTypeX e ty diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs index 5319a52ad0..6a1f2d3315 100644 --- a/compiler/GHC/Tc/Solver.hs +++ b/compiler/GHC/Tc/Solver.hs @@ -1,4 +1,4 @@ - +{-# LANGUAGE RecursiveDo #-} module GHC.Tc.Solver( InferMode(..), simplifyInfer, findInferredDiff, @@ -59,6 +59,7 @@ import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.Ppr +import GHC.Core.TyCon ( TyConBinder ) import GHC.Builtin.Types ( liftedRepTy, manyDataConTy, liftedDataConTy ) import GHC.Core.Unify ( tcMatchTyKi ) import GHC.Utils.Misc @@ -164,17 +165,17 @@ simplifyTop wanteds ; return (evBindMapBinds binds1 `unionBags` binds2) } -pushLevelAndSolveEqualities :: SkolemInfo -> [TcTyVar] -> TcM a -> TcM a +pushLevelAndSolveEqualities :: SkolemInfoAnon -> [TyConBinder] -> TcM a -> TcM a -- Push level, and solve all resulting equalities -- If there are any unsolved equalities, report them -- and fail (in the monad) -- -- Panics if we solve any non-equality constraints. (In runTCSEqualities -- we use an error thunk for the evidence bindings.) -pushLevelAndSolveEqualities skol_info skol_tvs thing_inside +pushLevelAndSolveEqualities skol_info_anon tcbs thing_inside = do { (tclvl, wanted, res) <- pushLevelAndSolveEqualitiesX "pushLevelAndSolveEqualities" thing_inside - ; reportUnsolvedEqualities skol_info skol_tvs tclvl wanted + ; report_unsolved_equalities skol_info_anon (binderVars tcbs) tclvl wanted ; return res } pushLevelAndSolveEqualitiesX :: String -> TcM a @@ -228,11 +229,11 @@ simplifyAndEmitFlatConstraints wanted -- Emit the bad constraints, wrapped in an implication -- See Note [Wrapping failing kind equalities] ; tclvl <- TcM.getTcLevel - ; implic <- buildTvImplication UnkSkol [] (pushTcLevel tclvl) wanted - -- ^^^^^^ | ^^^^^^^^^^^^^^^^^ - -- it's OK to use UnkSkol | we must increase the TcLevel, - -- because we don't bind | as explained in - -- any skolem variables here | Note [Wrapping failing kind equalities] + ; implic <- buildTvImplication unkSkolAnon [] (pushTcLevel tclvl) wanted + -- ^^^^^^ | ^^^^^^^^^^^^^^^^^ + -- it's OK to use unkSkol | we must increase the TcLevel, + -- because we don't bind | as explained in + -- any skolem variables here | Note [Wrapping failing kind equalities] ; emitImplication implic ; failM } Just (simples, holes) @@ -461,13 +462,20 @@ reportUnsolvedEqualities :: SkolemInfo -> [TcTyVar] -> TcLevel -- -- The provided SkolemInfo and [TcTyVar] arguments are used in an implication to -- provide skolem info for any errors. --- reportUnsolvedEqualities skol_info skol_tvs tclvl wanted + = report_unsolved_equalities (getSkolemInfo skol_info) skol_tvs tclvl wanted + +report_unsolved_equalities :: SkolemInfoAnon -> [TcTyVar] -> TcLevel + -> WantedConstraints -> TcM () +report_unsolved_equalities skol_info_anon skol_tvs tclvl wanted | isEmptyWC wanted = return () - | otherwise + + | otherwise -- NB: we build an implication /even if skol_tvs is empty/, + -- just to ensure that our level invariants hold, specifically + -- (WantedInv). See Note [TcLevel invariants]. = checkNoErrs $ -- Fail - do { implic <- buildTvImplication skol_info skol_tvs tclvl wanted + do { implic <- buildTvImplication skol_info_anon skol_tvs tclvl wanted ; reportAllUnsolved (mkImplicWC (unitBag implic)) } @@ -903,7 +911,7 @@ tcCheckGivens inerts given_ids = do (sat, new_inerts) <- runTcSInerts inerts $ do traceTcS "checkGivens {" (ppr inerts <+> ppr given_ids) lcl_env <- TcS.getLclEnv - let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env + let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) lcl_env let given_cts = mkGivens given_loc (bagToList given_ids) -- See Note [Superclasses and satisfiability] solveSimpleGivens given_cts @@ -1052,7 +1060,9 @@ simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds , pred <- sig_inst_theta sig ] ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus) - ; qtkvs <- quantifyTyVars DefaultNonStandardTyVars dep_vars + + ; skol_info <- mkSkolemInfo (InferSkol name_taus) + ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars dep_vars ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs) ; return (qtkvs, [], emptyTcEvBinds, False) } @@ -1104,10 +1114,16 @@ simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds -- NB: bound_theta are constraints we want to quantify over, -- including the psig_theta, which we always quantify over -- NB: bound_theta are fully zonked - ; (qtvs, bound_theta, co_vars) <- decideQuantification infer_mode rhs_tclvl + ; rec { (qtvs, bound_theta, co_vars) <- decideQuantification skol_info infer_mode rhs_tclvl name_taus partial_sigs quant_pred_candidates - ; bound_theta_vars <- mapM TcM.newEvVar bound_theta + ; bound_theta_vars <- mapM TcM.newEvVar bound_theta + + ; let full_theta = map idType bound_theta_vars + ; skol_info <- mkSkolemInfo (InferSkol [ (name, mkSigmaTy [] full_theta ty) + | (name, ty) <- name_taus ]) + } + -- Now emit the residual constraint ; emitResidualConstraints rhs_tclvl ev_binds_var @@ -1189,7 +1205,7 @@ findInferredDiff annotated_theta inferred_theta do { lcl_env <- TcM.getLclEnv ; given_ids <- mapM TcM.newEvVar annotated_theta ; wanteds <- newWanteds AnnOrigin inferred_theta - ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env + ; let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) lcl_env given_cts = mkGivens given_loc given_ids ; residual <- runTcSDeriveds $ @@ -1332,7 +1348,8 @@ If the monomorphism restriction does not apply, then we quantify as follows: -} decideQuantification - :: InferMode + :: SkolemInfo + -> InferMode -> TcLevel -> [(Name, TcTauType)] -- Variables to be generalised -> [TcIdSigInst] -- Partial type signatures (if any) @@ -1341,7 +1358,7 @@ decideQuantification , [PredType] -- and this context (fully zonked) , VarSet) -- See Note [Deciding quantification] -decideQuantification infer_mode rhs_tclvl name_taus psigs candidates +decideQuantification skol_info infer_mode rhs_tclvl name_taus psigs candidates = do { -- Step 1: find the mono_tvs ; (mono_tvs, candidates, co_vars) <- decideMonoTyVars infer_mode name_taus psigs candidates @@ -1351,7 +1368,7 @@ decideQuantification infer_mode rhs_tclvl name_taus psigs candidates ; candidates <- defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates -- Step 3: decide which kind/type variables to quantify over - ; qtvs <- decideQuantifiedTyVars name_taus psigs candidates + ; qtvs <- decideQuantifiedTyVars skol_info name_taus psigs candidates -- Step 4: choose which of the remaining candidate -- predicates to actually quantify over @@ -1436,7 +1453,7 @@ decideMonoTyVars infer_mode name_taus psigs candidates -- If possible, we quantify over partial-sig qtvs, so they are -- not mono. Need to zonk them because they are meta-tyvar TyVarTvs - ; psig_qtvs <- mapM zonkTcTyVarToTyVar $ binderVars $ + ; psig_qtvs <- zonkTcTyVarsToTcTyVars $ binderVars $ concatMap (map snd . sig_inst_skols) psigs ; psig_theta <- mapM TcM.zonkTcType $ @@ -1587,12 +1604,13 @@ defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates ------------------ decideQuantifiedTyVars - :: [(Name,TcType)] -- Annotated theta and (name,tau) pairs + :: SkolemInfo + -> [(Name,TcType)] -- Annotated theta and (name,tau) pairs -> [TcIdSigInst] -- Partial signatures -> [PredType] -- Candidates, zonked -> TcM [TyVar] -- Fix what tyvars we are going to quantify over, and quantify them -decideQuantifiedTyVars name_taus psigs candidates +decideQuantifiedTyVars skol_info name_taus psigs candidates = do { -- Why psig_tys? We try to quantify over everything free in here -- See Note [Quantification and partial signatures] -- Wrinkles 2 and 3 @@ -1631,7 +1649,7 @@ decideQuantifiedTyVars name_taus psigs candidates , text "grown_tcvs =" <+> ppr grown_tcvs , text "dvs =" <+> ppr dvs_plus]) - ; quantifyTyVars DefaultNonStandardTyVars dvs_plus } + ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs_plus } ------------------ growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet @@ -2192,7 +2210,7 @@ checkBadTelescope (Implic { ic_info = info | otherwise = go (later_skols `extendVarSet` one_skol) earlier_skols -warnRedundantGivens :: SkolemInfo -> Bool +warnRedundantGivens :: SkolemInfoAnon -> Bool warnRedundantGivens (SigSkol ctxt _ _) = case ctxt of FunSigCtxt _ rrc -> reportRedundantConstraints rrc @@ -2835,7 +2853,7 @@ disambigGroup (default_ty:default_tys) group@(the_tv, wanteds) | Just subst <- mb_subst = do { lcl_env <- TcS.getLclEnv ; tc_lvl <- TcS.getTcLevel - ; let loc = mkGivenLoc tc_lvl UnkSkol lcl_env + ; let loc = mkGivenLoc tc_lvl (getSkolemInfo unkSkol) lcl_env -- Equality constraints are possible due to type defaulting plugins ; wanted_evs <- mapM (newWantedNC loc . substTy subst . ctPred) wanteds diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs index db1c3c1652..b7c702e5b9 100644 --- a/compiler/GHC/Tc/Solver/Canonical.hs +++ b/compiler/GHC/Tc/Solver/Canonical.hs @@ -872,13 +872,13 @@ solveForAll ev tvs theta pred pend_sc | CtWanted { ctev_dest = dest } <- ev = -- See Note [Solving a Wanted forall-constraint] setLclEnv (ctLocEnv loc) $ - -- This setLclEnv is important: the emitImplicationTcS uses that - -- TcLclEnv for the implication, and that in turn sets the location - -- for the Givens when solving the constraint (#21006) - do { let skol_info = QuantCtxtSkol - empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ + -- This setLclEnv is important: the emitImplicationTcS uses that + -- TcLclEnv for the implication, and that in turn sets the location + -- for the Givens when solving the constraint (#21006) + do { skol_info <- mkSkolemInfo QuantCtxtSkol + ; let empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ tyCoVarsOfTypes (pred:theta) `delVarSetList` tvs - ; (subst, skol_tvs) <- tcInstSkolTyVarsX empty_subst tvs + ; (subst, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst tvs ; given_ev_vars <- mapM newEvVar (substTheta subst theta) ; (lvl, (w_id, wanteds)) @@ -888,7 +888,7 @@ solveForAll ev tvs theta pred pend_sc ; return ( ctEvEvId wanted_ev , unitBag (mkNonCanonical wanted_ev)) } - ; ev_binds <- emitImplicationTcS lvl skol_info skol_tvs + ; ev_binds <- emitImplicationTcS lvl (getSkolemInfo skol_info) skol_tvs given_ev_vars wanteds ; setWantedEvTerm dest $ @@ -1352,11 +1352,11 @@ can_eq_nc_forall ev eq_rel s1 s2 else do { traceTcS "Creating implication for polytype equality" $ ppr ev ; let empty_subst1 = mkEmptyTCvSubst $ mkInScopeSet free_tvs - ; (subst1, skol_tvs) <- tcInstSkolTyVarsX empty_subst1 $ + ; skol_info <- mkSkolemInfo (UnifyForAllSkol phi1) + ; (subst1, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst1 $ binderVars bndrs1 - ; let skol_info = UnifyForAllSkol phi1 - phi1' = substTy subst1 phi1 + ; let phi1' = substTy subst1 phi1 -- Unify the kinds, extend the substitution go :: [TcTyVar] -> TCvSubst -> [TyVarBinder] @@ -1384,7 +1384,7 @@ can_eq_nc_forall ev eq_rel s1 s2 ; (lvl, (all_co, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $ go skol_tvs empty_subst2 bndrs2 - ; emitTvImplicationTcS lvl skol_info skol_tvs wanteds + ; emitTvImplicationTcS lvl (getSkolemInfo skol_info) skol_tvs wanteds ; setWantedEq orig_dest all_co ; stopWith ev "Deferred polytype equality" } } diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs index 25bde37642..963768ca47 100644 --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -1228,6 +1228,9 @@ instance Monad TcS where m >>= k = mkTcS $ \ebs -> do unTcS m ebs >>= (\r -> unTcS (k r) ebs) +instance MonadIO TcS where + liftIO act = TcS $ \_env -> liftIO act + instance MonadFail TcS where fail err = mkTcS $ \_ -> fail err @@ -1503,7 +1506,7 @@ nestTcS (TcS thing_inside) ; return res } -emitImplicationTcS :: TcLevel -> SkolemInfo +emitImplicationTcS :: TcLevel -> SkolemInfoAnon -> [TcTyVar] -- Skolems -> [EvVar] -- Givens -> Cts -- Wanteds @@ -1524,7 +1527,7 @@ emitImplicationTcS new_tclvl skol_info skol_tvs givens wanteds ; emitImplication imp ; return (TcEvBinds (ic_binds imp)) } -emitTvImplicationTcS :: TcLevel -> SkolemInfo +emitTvImplicationTcS :: TcLevel -> SkolemInfoAnon -> [TcTyVar] -- Skolems -> Cts -- Wanteds -> TcS () @@ -2001,8 +2004,8 @@ matchGlobalInst :: DynFlags matchGlobalInst dflags short_cut cls tys = wrapTcS (TcM.matchGlobalInst dflags short_cut cls tys) -tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcS (TCvSubst, [TcTyVar]) -tcInstSkolTyVarsX subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX subst tvs +tcInstSkolTyVarsX :: SkolemInfo -> TCvSubst -> [TyVar] -> TcS (TCvSubst, [TcTyVar]) +tcInstSkolTyVarsX skol_info subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX skol_info subst tvs -- Creating and setting evidence variables and CtFlavors -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index da6054a74f..3ada6b6dc3 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -23,7 +23,7 @@ module GHC.Tc.TyCl ( tcFamTyPats, tcTyFamInstEqn, tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt, unravelFamInstPats, addConsistencyConstraints, - wrongKindOfFamily + wrongKindOfFamily, checkFamTelescope ) where import GHC.Prelude @@ -88,7 +88,7 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Data.FastString import GHC.Data.Maybe -import GHC.Data.List.SetOps +import GHC.Data.List.SetOps( minusList, equivClasses ) import GHC.Unit @@ -99,9 +99,8 @@ import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc import Control.Monad -import Data.Function ( on ) import Data.Functor.Identity -import Data.List (nubBy, partition) +import Data.List ( partition) import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.Set as Set import Data.Tuple( swap ) @@ -149,7 +148,6 @@ tcTyAndClassDecls :: [TyClGroup GhcRn] -- Mutually-recursive groups in -- and their implicit Ids,DataCons , [InstInfo GhcRn] -- Source-code instance decls info , [DerivInfo] -- Deriving info - , ClassScopedTVEnv -- Class scoped type variables , ThBindEnv -- TH binding levels ) -- Fails if there are any errors @@ -157,30 +155,28 @@ tcTyAndClassDecls tyclds_s -- The code recovers internally, but if anything gave rise to -- an error we'd better stop now, to avoid a cascade -- Type check each group in dependency order folding the global env - = checkNoErrs $ fold_env [] [] emptyNameEnv emptyNameEnv tyclds_s + = checkNoErrs $ fold_env [] [] emptyNameEnv tyclds_s where fold_env :: [InstInfo GhcRn] -> [DerivInfo] - -> ClassScopedTVEnv -> ThBindEnv -> [TyClGroup GhcRn] - -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ClassScopedTVEnv, ThBindEnv) - fold_env inst_info deriv_info class_scoped_tv_env th_bndrs [] + -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv) + fold_env inst_info deriv_info th_bndrs [] = do { gbl_env <- getGblEnv - ; return (gbl_env, inst_info, deriv_info, class_scoped_tv_env, th_bndrs) } - fold_env inst_info deriv_info class_scoped_tv_env th_bndrs (tyclds:tyclds_s) - = do { (tcg_env, inst_info', deriv_info', class_scoped_tv_env', th_bndrs') + ; return (gbl_env, inst_info, deriv_info, th_bndrs) } + fold_env inst_info deriv_info th_bndrs (tyclds:tyclds_s) + = do { (tcg_env, inst_info', deriv_info', th_bndrs') <- tcTyClGroup tyclds ; setGblEnv tcg_env $ -- remaining groups are typechecked in the extended global env. fold_env (inst_info' ++ inst_info) (deriv_info' ++ deriv_info) - (class_scoped_tv_env' `plusNameEnv` class_scoped_tv_env) (th_bndrs' `plusNameEnv` th_bndrs) tyclds_s } tcTyClGroup :: TyClGroup GhcRn - -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ClassScopedTVEnv, ThBindEnv) + -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv) -- Typecheck one strongly-connected component of type, class, and instance decls -- See Note [TyClGroups and dependency analysis] in GHC.Hs.Decls tcTyClGroup (TyClGroup { group_tyclds = tyclds @@ -192,7 +188,7 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds -- Step 1: Typecheck the standalone kind signatures and type/class declarations ; traceTc "---- tcTyClGroup ---- {" empty ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds)) - ; (tyclss, data_deriv_info, class_scoped_tv_env, kindless) <- + ; (tyclss, data_deriv_info, kindless) <- tcExtendKindEnv (mkPromotionErrorEnv tyclds) $ -- See Note [Type environment evolution] do { kisig_env <- mkNameEnv <$> traverse tcStandaloneKindSig kisigs ; tcTyClDecls tyclds kisig_env role_annots } @@ -228,7 +224,7 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds ; let deriv_info = datafam_deriv_info ++ data_deriv_info ; let gbl_env'' = gbl_env' { tcg_ksigs = tcg_ksigs gbl_env' `unionNameSet` kindless } - ; return (gbl_env'', inst_info, deriv_info, class_scoped_tv_env, + ; return (gbl_env'', inst_info, deriv_info, th_bndrs' `plusNameEnv` th_bndrs) } -- Gives the kind for every TyCon that has a standalone kind signature @@ -238,7 +234,7 @@ tcTyClDecls :: [LTyClDecl GhcRn] -> KindSigEnv -> RoleAnnotEnv - -> TcM ([TyCon], [DerivInfo], ClassScopedTVEnv, NameSet) + -> TcM ([TyCon], [DerivInfo], NameSet) tcTyClDecls tyclds kisig_env role_annots = do { -- Step 1: kind-check this group and returns the final -- (possibly-polymorphic) kind of each TyCon and Class @@ -252,12 +248,11 @@ tcTyClDecls tyclds kisig_env role_annots -- NB: We have to be careful here to NOT eagerly unfold -- type synonyms, as we have not tested for type synonym -- loops yet and could fall into a black hole. - ; fixM $ \ ~(rec_tyclss, _, _, _) -> do + ; fixM $ \ ~(rec_tyclss, _, _) -> do { tcg_env <- getGblEnv -- Forced so we don't retain a reference to the TcGblEnv ; let !src = tcg_src tcg_env roles = inferRoles src role_annots rec_tyclss - class_scoped_tv_env = mk_class_scoped_tv_env tc_tycons -- Populate environment with knot-tied ATyCon for TyCons -- NB: if the decls mention any ill-staged data cons @@ -274,7 +269,7 @@ tcTyClDecls tyclds kisig_env role_annots -- Kind and type check declarations for this group mapAndUnzipM (tcTyClDecl roles) tyclds - ; return (tycons, concat data_deriv_infos, class_scoped_tv_env, kindless) + ; return (tycons, concat data_deriv_infos, kindless) } } where ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma @@ -282,16 +277,6 @@ tcTyClDecls tyclds kisig_env role_annots , ppr (tyConResKind tc) , ppr (isTcTyCon tc) ]) - -- Map each class TcTyCon to their tcTyConScopedTyVars. This is ultimately - -- meant to be passed to GHC.Tc.TyCl.Class.tcClassDecl2, which consults - -- it when bringing type variables into scope over class method defaults. - -- See @Note [Scoped tyvars in a TcTyCon]@ in "GHC.Core.TyCon". - mk_class_scoped_tv_env :: [TcTyCon] -> ClassScopedTVEnv - mk_class_scoped_tv_env tc_tycons = - mkNameEnv [ (tyConName tc_tycon, tcTyConScopedTyVars tc_tycon) - | tc_tycon <- tc_tycons, tyConFlavour tc_tycon == ClassFlavour - ] - zipRecTyClss :: [TcTyCon] -> [TyCon] -- Knot-tied -> [(Name,TyThing)] @@ -419,31 +404,50 @@ TcTyCons are used for two distinct purposes see makeRecoveryTyCon. 2. When checking a type/class declaration (in module GHC.Tc.TyCl), we come - upon knowledge of the eventual tycon in bits and pieces. - - S1) First, we use inferInitialKinds to look over the user-provided - kind signature of a tycon (including, for example, the number - of parameters written to the tycon) to get an initial shape of - the tycon's kind. We record that shape in a TcTyCon. - - For CUSK tycons, the TcTyCon has the final, generalised kind. - For non-CUSK tycons, the TcTyCon has as its tyConBinders only - the explicit arguments given -- no kind variables, etc. - - S2) Then, using these initial kinds, we kind-check the body of the - tycon (class methods, data constructors, etc.), filling in the + upon knowledge of the eventual tycon in bits and pieces, and we use + a TcTyCon to record what we know before we are ready to build the + final TyCon. + + We first build a MonoTcTyCon, then generalise to a PolyTcTyCon + See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.Utils.TcType + Specifically: + + S1) In kcTyClGroup, we use checkInitialKinds to get the + utterly-final Kind of all TyCons in the group that + (a) have a kind signature or + (b) have a CUSK. + This produces a PolyTcTyCon, that is, a TcTyCon in which the binders + and result kind are full of TyVars (not TcTyVars). No unification + variables here; everything is in its final form. + + S2) In kcTyClGroup, we use inferInitialKinds to look over the + declaration of any TyCon that lacks a kind signature or + CUSK, to determine its "shape"; for example, the number of + parameters, and any kind signatures. + + We record that shape record that shape in a MonoTcTyCon; it is + "mono" because it has not been been generalised, and its binders + and result kind may have free unification variables. + + S3) Still in kcTyClGroup, we use kcLTyClDecl to kind-check the + body (class methods, data constructors, etc.) of each of + these MonoTcTyCons, which has the effect of filling in the metavariables in the tycon's initial kind. - S3) We then generalize to get the (non-CUSK) tycon's final, fixed - kind. Finally, once this has happened for all tycons in a - mutually recursive group, we can desugar the lot. + S4) Still in kcTyClGroup, we use generaliseTyClDecl to generalize + each MonoTcTyCon to get a PolyTcTyCon, with final TyVars in it, + and a final, fixed kind. - For convenience, we store partially-known tycons in TcTyCons, which - might store meta-variables. These TcTyCons are stored in the local - environment in GHC.Tc.TyCl, until the real full TyCons can be created - during desugaring. A desugared program should never have a TcTyCon. + S5) Finally, back in TcTyClDecls, we extend the environment with + the PolyTcTyCons, and typecheck each declaration (regardless + of kind signatures etc) to get final TyCon. -3. In a TcTyCon, everything is zonked after the kind-checking pass (S2). + These TcTyCons are stored in the local environment in GHC.Tc.TyCl, + until the real full TyCons can be created during desugaring. A + desugared program should never have a TcTyCon. + +3. A MonoTcTyCon can contain unification variables, but a PolyTcTyCon + does not: only skolem TcTyVars. 4. tyConScopedTyVars. A challenging piece in all of this is that we end up taking three separate passes over every declaration: @@ -459,8 +463,10 @@ TcTyCons are used for two distinct purposes GHC.Tc.Gen.HsType.splitTelescopeTvs!) Instead of trying, we just store the list of type variables to - bring into scope, in the tyConScopedTyVars field of the TcTyCon. - These tyvars are brought into scope in GHC.Tc.Gen.HsType.bindTyClTyVars. + bring into scope, in the tyConScopedTyVars field of a MonoTcTyCon. + These tyvars are brought into scope by the calls to + tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) + in kcTyClDecl. In a TcTyCon, why is tyConScopedTyVars :: [(Name,TcTyVar)] rather than just [TcTyVar]? Consider these mutually-recursive decls @@ -657,7 +663,7 @@ been generalized. -} -kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM ([TcTyCon], NameSet) +kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM ([PolyTcTyCon], NameSet) -- Kind check this group, kind generalize, and return the resulting local env -- This binds the TyCons and Classes of the group, but not the DataCons @@ -701,7 +707,7 @@ kcTyClGroup kisig_env decls ; inferred_tcs <- tcExtendKindEnvWithTyCons checked_tcs $ - pushLevelAndSolveEqualities UnkSkol [] $ + pushLevelAndSolveEqualities unkSkolAnon [] $ -- We are going to kind-generalise, so unification -- variables in here must be one level in do { -- Step 1: Bind kind variables for all decls @@ -741,7 +747,7 @@ type ScopedPairs = [(Name, TcTyVar)] -- specified-tvs ++ required-tvs -- You can distinguish them because there are tyConArity required-tvs -generaliseTyClDecl :: NameEnv TcTyCon -> LTyClDecl GhcRn -> TcM [TcTyCon] +generaliseTyClDecl :: NameEnv MonoTcTyCon -> LTyClDecl GhcRn -> TcM [PolyTcTyCon] -- See Note [Swizzling the tyvars before generaliseTcTyCon] generaliseTyClDecl inferred_tc_env (L _ decl) = do { let names_in_this_decl :: [Name] @@ -770,35 +776,38 @@ generaliseTyClDecl inferred_tc_env (L _ decl) at_names (ClassDecl { tcdATs = ats }) = map (familyDeclName . unLoc) ats at_names _ = [] -- Only class decls have associated types - skolemise_tc_tycon :: Name -> TcM (TcTyCon, ScopedPairs) + skolemise_tc_tycon :: Name -> TcM (TcTyCon, SkolemInfo, ScopedPairs) -- Zonk and skolemise the Specified and Required binders skolemise_tc_tycon tc_name = do { let tc = lookupNameEnv_NF inferred_tc_env tc_name -- This lookup should not fail - ; scoped_prs <- mapSndM zonkAndSkolemise (tcTyConScopedTyVars tc) - ; return (tc, scoped_prs) } - - zonk_tc_tycon :: (TcTyCon, ScopedPairs) -> TcM (TcTyCon, ScopedPairs, TcKind) - zonk_tc_tycon (tc, scoped_prs) - = do { scoped_prs <- mapSndM zonkTcTyVarToTyVar scoped_prs + ; skol_info <- mkSkolemInfo (TyConSkol (tyConFlavour tc) tc_name ) + ; scoped_prs <- mapSndM (zonkAndSkolemise skol_info) (tcTyConScopedTyVars tc) + ; return (tc, skol_info, scoped_prs) } + + zonk_tc_tycon :: (TcTyCon, SkolemInfo, ScopedPairs) + -> TcM (TcTyCon, SkolemInfo, ScopedPairs, TcKind) + zonk_tc_tycon (tc, skol_info, scoped_prs) + = do { scoped_prs <- mapSndM zonkTcTyVarToTcTyVar scoped_prs -- We really have to do this again, even though - -- we have just done zonkAndSkolemise + -- we have just done zonkAndSkolemise, so that + -- occurrences in the /kinds/ get zonked to the skolem ; res_kind <- zonkTcType (tyConResKind tc) - ; return (tc, scoped_prs, res_kind) } + ; return (tc, skol_info, scoped_prs, res_kind) } -swizzleTcTyConBndrs :: [(TcTyCon, ScopedPairs, TcKind)] - -> TcM [(TcTyCon, ScopedPairs, TcKind)] +swizzleTcTyConBndrs :: [(TcTyCon, SkolemInfo, ScopedPairs, TcKind)] + -> TcM [(TcTyCon, SkolemInfo, ScopedPairs, TcKind)] swizzleTcTyConBndrs tc_infos | all no_swizzle swizzle_prs -- This fast path happens almost all the time -- See Note [Cloning for type variable binders] in GHC.Tc.Gen.HsType -- "Almost all the time" means not the case of mutual recursion with -- polymorphic kinds. - = do { traceTc "Skipping swizzleTcTyConBndrs for" (ppr (map fstOf3 tc_infos)) + = do { traceTc "Skipping swizzleTcTyConBndrs for" (ppr_infos tc_infos) ; return tc_infos } | otherwise - = do { check_duplicate_tc_binders + = do { checkForDuplicateScopedTyVars swizzle_prs ; traceTc "swizzleTcTyConBndrs" $ vcat [ text "before" <+> ppr_infos tc_infos @@ -808,49 +817,19 @@ swizzleTcTyConBndrs tc_infos ; return swizzled_infos } where - swizzled_infos = [ (tc, mapSnd swizzle_var scoped_prs, swizzle_ty kind) - | (tc, scoped_prs, kind) <- tc_infos ] + swizzled_infos = [ (tc, skol_info, mapSnd swizzle_var scoped_prs, swizzle_ty kind) + | (tc, skol_info, scoped_prs, kind) <- tc_infos ] swizzle_prs :: [(Name,TyVar)] -- Pairs the user-specified Name with its representative TyVar -- See Note [Swizzling the tyvars before generaliseTcTyCon] - swizzle_prs = [ pr | (_, prs, _) <- tc_infos, pr <- prs ] + swizzle_prs = [ pr | (_, _, prs, _) <- tc_infos, pr <- prs ] no_swizzle :: (Name,TyVar) -> Bool no_swizzle (nm, tv) = nm == tyVarName tv ppr_infos infos = vcat [ ppr tc <+> pprTyVars (map snd prs) - | (tc, prs, _) <- infos ] - - -- Check for duplicates - -- E.g. data SameKind (a::k) (b::k) - -- data T (a::k1) (b::k2) = MkT (SameKind a b) - -- Here k1 and k2 start as TyVarTvs, and get unified with each other - -- If this happens, things get very confused later, so fail fast - check_duplicate_tc_binders :: TcM () - check_duplicate_tc_binders = unless (null err_prs) $ - do { mapM_ report_dup err_prs; failM } - - -------------- Error reporting ------------ - err_prs :: [(Name,Name)] - err_prs = [ (n1,n2) - | pr :| prs <- findDupsEq ((==) `on` snd) swizzle_prs - , (n1,_):(n2,_):_ <- [nubBy ((==) `on` fst) (pr:prs)] ] - -- This nubBy avoids bogus error reports when we have - -- [("f", f), ..., ("f",f)....] in swizzle_prs - -- which happens with class C f where { type T f } - - report_dup :: (Name,Name) -> TcM () - report_dup (n1,n2) - = setSrcSpan (getSrcSpan n2) $ addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Different names for the same type variable:") 2 info - where - info | nameOccName n1 /= nameOccName n2 - = quotes (ppr n1) <+> text "and" <+> quotes (ppr n2) - | otherwise -- Same OccNames! See C2 in - -- Note [Swizzling the tyvars before generaliseTcTyCon] - = vcat [ quotes (ppr n1) <+> text "bound at" <+> ppr (getSrcLoc n1) - , quotes (ppr n2) <+> text "bound at" <+> ppr (getSrcLoc n2) ] + | (tc, _, prs, _) <- infos ] -------------- The swizzler ------------ -- This does a deep traverse, simply doing a @@ -886,8 +865,10 @@ swizzleTcTyConBndrs tc_infos swizzle_ty ty = runIdentity (map_type ty) -generaliseTcTyCon :: (TcTyCon, ScopedPairs, TcKind) -> TcM TcTyCon -generaliseTcTyCon (tc, scoped_prs, tc_res_kind) +generaliseTcTyCon :: (MonoTcTyCon, SkolemInfo, ScopedPairs, TcKind) -> TcM PolyTcTyCon +generaliseTcTyCon (tc, skol_info, scoped_prs, tc_res_kind) + -- The scoped_prs are fully zonked skolem TcTyVars + -- And tc_res_kind is fully zonked too -- See Note [Required, Specified, and Inferred for types] = setSrcSpan (getSrcSpan tc) $ addTyConCtxt tc $ @@ -909,7 +890,7 @@ generaliseTcTyCon (tc, scoped_prs, tc_res_kind) -- Step 2b: quantify, mainly meaning skolemise the free variables -- Returned 'inferred' are scope-sorted and skolemised - ; inferred <- quantifyTyVars DefaultNonStandardTyVars dvs2 + ; inferred <- quantifyTyVars skol_info DefaultNonStandardTyVars dvs2 ; traceTc "generaliseTcTyCon: pre zonk" (vcat [ text "tycon =" <+> ppr tc @@ -918,21 +899,18 @@ generaliseTcTyCon (tc, scoped_prs, tc_res_kind) , text "dvs1 =" <+> ppr dvs1 , text "inferred =" <+> pprTyVars inferred ]) - -- Step 3: Final zonk (following kind generalisation) - -- See Note [Swizzling the tyvars before generaliseTcTyCon] - ; ze <- mkEmptyZonkEnv NoFlexi - ; (ze, inferred) <- zonkTyBndrsX ze inferred - ; (ze, sorted_spec_tvs) <- zonkTyBndrsX ze sorted_spec_tvs - ; (ze, req_tvs) <- zonkTyBndrsX ze req_tvs - ; tc_res_kind <- zonkTcTypeToTypeX ze tc_res_kind + -- Step 3: Final zonk: quantifyTyVars may have done some defaulting + ; inferred <- zonkTcTyVarsToTcTyVars inferred + ; sorted_spec_tvs <- zonkTcTyVarsToTcTyVars sorted_spec_tvs + ; req_tvs <- zonkTcTyVarsToTcTyVars req_tvs + ; tc_res_kind <- zonkTcType tc_res_kind ; traceTc "generaliseTcTyCon: post zonk" $ vcat [ text "tycon =" <+> ppr tc , text "inferred =" <+> pprTyVars inferred , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs , text "sorted_spec_tvs =" <+> pprTyVars sorted_spec_tvs - , text "req_tvs =" <+> ppr req_tvs - , text "zonk-env =" <+> ppr ze ] + , text "req_tvs =" <+> ppr req_tvs ] -- Step 4: Make the TyConBinders. ; let dep_fv_set = candidateKindVars dvs1 @@ -941,15 +919,21 @@ generaliseTcTyCon (tc, scoped_prs, tc_res_kind) required_tcbs = map (mkRequiredTyConBinder dep_fv_set) req_tvs -- Step 5: Assemble the final list. - final_tcbs = concat [ inferred_tcbs - , specified_tcbs - , required_tcbs ] + all_tcbs = concat [ inferred_tcbs + , specified_tcbs + , required_tcbs ] + flav = tyConFlavour tc + + -- Eta expand + ; (eta_tcbs, tc_res_kind) <- etaExpandAlgTyCon flav skol_info all_tcbs tc_res_kind -- Step 6: Make the result TcTyCon - tycon = mkTcTyCon (tyConName tc) final_tcbs tc_res_kind - (mkTyVarNamePairs (sorted_spec_tvs ++ req_tvs)) - True {- it's generalised now -} - (tyConFlavour tc) + ; let final_tcbs = all_tcbs `chkAppend` eta_tcbs + tycon = mkTcTyCon (tyConName tc) + final_tcbs tc_res_kind + (mkTyVarNamePairs (sorted_spec_tvs ++ req_tvs)) + True {- it's generalised now -} + flav ; traceTc "generaliseTcTyCon done" $ vcat [ text "tycon =" <+> ppr tc @@ -1174,7 +1158,7 @@ There are some wrinkles Here we will unify k1 with k2, but this time doing so is an error, because k1 and k2 are bound in the same declaration. - We spot this during validity checking (findDupTyVarTvs), + We spot this during validity checking (checkForDuplicateScopeTyVars), in generaliseTcTyCon. * Required arguments. Even the Required arguments should be made @@ -1307,7 +1291,7 @@ mk_prom_err_env decl -- Works for family declarations too -------------- -inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [TcTyCon] +inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [MonoTcTyCon] -- Returns a TcTyCon for each TyCon bound by the decls, -- each with its initial kind @@ -1321,7 +1305,7 @@ inferInitialKinds decls -- Check type/class declarations against their standalone kind signatures or -- CUSKs, producing a generalized TcTyCon for each. -checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [TcTyCon] +checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [PolyTcTyCon] checkInitialKinds decls = do { traceTc "checkInitialKinds {" $ ppr (mapFst (tcdName . unLoc) decls) ; tcs <- concatMapM check_initial_kind decls @@ -1352,18 +1336,17 @@ getInitialKind strategy (ClassDecl { tcdLName = L _ name , tcdTyVars = ktvs , tcdATs = ats }) - = do { cls <- kcDeclHeader strategy name ClassFlavour ktvs $ + = do { cls_tc <- kcDeclHeader strategy name ClassFlavour ktvs $ return (TheKind constraintKind) - ; let parent_tv_prs = tcTyConScopedTyVars cls -- See Note [Don't process associated types in getInitialKind] - ; inner_tcs <- - tcExtendNameTyVarEnv parent_tv_prs $ - mapM (addLocMA (getAssocFamInitialKind cls)) ats - ; return (cls : inner_tcs) } + + ; at_tcs <- tcExtendTyVarEnv (tyConTyVars cls_tc) $ + mapM (addLocMA (getAssocFamInitialKind cls_tc)) ats + ; return (cls_tc : at_tcs) } where getAssocFamInitialKind cls = case strategy of - InitialKindInfer -> get_fam_decl_initial_kind (Just cls) + InitialKindInfer -> get_fam_decl_initial_kind (Just cls) InitialKindCheck _ -> check_initial_kind_assoc_fam cls getInitialKind strategy @@ -1563,7 +1546,7 @@ kcLTyClDecl :: LTyClDecl GhcRn -> TcM () -- Called only for declarations without a signature (no CUSKs or SAKs here) kcLTyClDecl (L loc decl) = setSrcSpanA loc $ - do { tycon <- tcLookupTcTyCon tc_name + do { tycon <- tcLookupTcTyCon tc_name -- Always a MonoTcTyCon ; traceTc "kcTyClDecl {" (ppr tc_name) ; addVDQNote tycon $ -- See Note [Inferring visible dependent quantification] addErrCtxt (tcMkDeclCtxt decl) $ @@ -1572,15 +1555,21 @@ kcLTyClDecl (L loc decl) where tc_name = tcdName decl -kcTyClDecl :: TyClDecl GhcRn -> TcTyCon -> TcM () +kcTyClDecl :: TyClDecl GhcRn -> MonoTcTyCon -> TcM () -- This function is used solely for its side effect on kind variables -- NB kind signatures on the type variables and -- result kind signature have already been dealt with -- by inferInitialKind, so we can ignore them here. -kcTyClDecl (DataDecl { tcdLName = (L _ name), tcdDataDefn = defn }) tycon +-- NB these equations just extend the type environment with carefully constructed +-- TcTyVars rather than create skolemised variables for the bound variables. +-- - inferInitialKinds makes the TcTyCon where the tyvars are TcTyVars +-- - In this function, those TcTyVars are unified with other kind variables during +-- kind inference (see [How TcTyCons work]) + +kcTyClDecl (DataDecl { tcdLName = (L _ _name), tcdDataDefn = defn }) tycon | HsDataDefn { dd_ctxt = ctxt, dd_cons = cons, dd_ND = new_or_data } <- defn - = bindTyClTyVars name $ \ _ _ _ -> + = tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $ -- NB: binding these tyvars isn't necessary for GADTs, but it does no -- harm. For GADTs, each data con brings its own tyvars into scope, -- and the ones from this bindTyClTyVars are either not mentioned or @@ -1590,15 +1579,16 @@ kcTyClDecl (DataDecl { tcdLName = (L _ name), tcdDataDefn = defn }) tycon ; kcConDecls new_or_data (tyConResKind tycon) cons } -kcTyClDecl (SynDecl { tcdLName = L _ name, tcdRhs = rhs }) _tycon - = bindTyClTyVars name $ \ _ _ res_kind -> - discardResult $ tcCheckLHsType rhs (TheKind res_kind) +kcTyClDecl (SynDecl { tcdLName = L _ _name, tcdRhs = rhs }) tycon + = tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $ + let res_kind = tyConResKind tycon + in discardResult $ tcCheckLHsType rhs (TheKind res_kind) -- NB: check against the result kind that we allocated -- in inferInitialKinds. -kcTyClDecl (ClassDecl { tcdLName = L _ name - , tcdCtxt = ctxt, tcdSigs = sigs }) _tycon - = bindTyClTyVars name $ \ _ _ _ -> +kcTyClDecl (ClassDecl { tcdLName = L _ _name + , tcdCtxt = ctxt, tcdSigs = sigs }) tycon + = tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $ do { _ <- tcHsContext ctxt ; mapM_ (wrapLocMA_ kc_sig) sigs } where @@ -1618,7 +1608,7 @@ kcTyClDecl (FamDecl _ (FamilyDecl { fdInfo = fd_info })) fam_tc -- This includes doing kind unification if the type is a newtype. -- See Note [Implementation of UnliftedNewtypes] for why we need -- the first two arguments. -kcConArgTys :: NewOrData -> Kind -> [HsScaled GhcRn (LHsType GhcRn)] -> TcM () +kcConArgTys :: NewOrData -> TcKind -> [HsScaled GhcRn (LHsType GhcRn)] -> TcM () kcConArgTys new_or_data res_kind arg_tys = do { let exp_kind = getArgExpKind new_or_data res_kind ; forM_ arg_tys (\(HsScaled mult ty) -> do _ <- tcCheckLHsType (getBangType ty) exp_kind @@ -1627,7 +1617,7 @@ kcConArgTys new_or_data res_kind arg_tys = do } -- Kind-check the types of arguments to a Haskell98 data constructor. -kcConH98Args :: NewOrData -> Kind -> HsConDeclH98Details GhcRn -> TcM () +kcConH98Args :: NewOrData -> TcKind -> HsConDeclH98Details GhcRn -> TcM () kcConH98Args new_or_data res_kind con_args = case con_args of PrefixCon _ tys -> kcConArgTys new_or_data res_kind tys InfixCon ty1 ty2 -> kcConArgTys new_or_data res_kind [ty1, ty2] @@ -1635,14 +1625,14 @@ kcConH98Args new_or_data res_kind con_args = case con_args of map (hsLinear . cd_fld_type . unLoc) flds -- Kind-check the types of arguments to a GADT data constructor. -kcConGADTArgs :: NewOrData -> Kind -> HsConDeclGADTDetails GhcRn -> TcM () +kcConGADTArgs :: NewOrData -> TcKind -> HsConDeclGADTDetails GhcRn -> TcM () kcConGADTArgs new_or_data res_kind con_args = case con_args of PrefixConGADT tys -> kcConArgTys new_or_data res_kind tys RecConGADT (L _ flds) _ -> kcConArgTys new_or_data res_kind $ map (hsLinear . cd_fld_type . unLoc) flds kcConDecls :: NewOrData - -> Kind -- The result kind signature + -> TcKind -- The result kind signature -- Used only in H98 case -> [LConDecl GhcRn] -- The data constructors -> TcM () @@ -1656,7 +1646,7 @@ kcConDecls new_or_data tc_res_kind cons -- this type. See Note [Implementation of UnliftedNewtypes] for why -- we need the first two arguments. kcConDecl :: NewOrData - -> Kind -- Result kind of the type constructor + -> TcKind -- Result kind of the type constructor -- Usually Type but can be TYPE UnliftedRep -- or even TYPE r, in the case of unlifted newtype -- Used only in H98 case @@ -1682,6 +1672,7 @@ kcConDecl new_or_data = -- See Note [kcConDecls: kind-checking data type decls] addErrCtxt (dataConCtxt names) $ discardResult $ + -- Not sure this is right, should just extend rather than skolemise but no test bindOuterSigTKBndrs_Tv outer_bndrs $ -- Why "_Tv"? See Note [Using TyVarTvs for kind-checking GADTs] do { _ <- tcHsContext cxt @@ -2183,7 +2174,7 @@ newtype instance Foo 'Red = FooRedC Int# Note that, in the GADT case, we might have a kind signature with arrows (newtype XYZ a b :: Type -> Type where ...). We want only the final -component of the kind for checking in kcConDecl, so we call etaExpandAlgTyCon +component of the kind for checking in kcConDecl, so we call etaExpanAlgTyCon in kcTyClDecl. STEP 3: Type-checking (desugaring), as done by tcTyClDecl. The key function @@ -2422,16 +2413,15 @@ tcClassDecl1 :: RolesInfo -> Name -> Maybe (LHsContext GhcRn) -> [LFamilyDecl GhcRn] -> [LTyFamDefltDecl GhcRn] -> TcM Class tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs - = fixM $ \ clas -> - -- We need the knot because 'clas' is passed into tcClassATs - bindTyClTyVars class_name $ \ _ binders res_kind -> + = fixM $ \ clas -> -- We need the knot because 'clas' is passed into tcClassATs + bindTyClTyVars class_name $ \ binders res_kind -> do { checkClassKindSig res_kind ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr binders) ; let tycon_name = class_name -- We use the same name roles = roles_info tycon_name -- for TyCon and Class ; (ctxt, fds, sig_stuff, at_stuff) - <- pushLevelAndSolveEqualities skol_info (binderVars binders) $ + <- pushLevelAndSolveEqualities skol_info binders $ -- The (binderVars binders) is needed bring into scope the -- skolems bound by the class decl header (#17841) do { ctxt <- tcHsContext hs_ctxt @@ -2487,6 +2477,7 @@ tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs ; return clas } where skol_info = TyConSkol ClassFlavour class_name + tc_fundep :: GHC.Hs.FunDep GhcRn -> TcM ([Var],[Var]) tc_fundep (FunDep _ tvs1 tvs2) = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ; @@ -2710,7 +2701,7 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info , fdResultSig = L _ sig , fdInjectivityAnn = inj }) | DataFamily <- fam_info - = bindTyClTyVars tc_name $ \ _ binders res_kind -> do + = bindTyClTyVarsAndZonk tc_name $ \ binders res_kind -> do { traceTc "tcFamDecl1 data family:" (ppr tc_name) ; checkFamFlag tc_name @@ -2736,7 +2727,7 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info ; return tycon } | OpenTypeFamily <- fam_info - = bindTyClTyVars tc_name $ \ _ binders res_kind -> do + = bindTyClTyVarsAndZonk tc_name $ \ binders res_kind -> do { traceTc "tcFamDecl1 open type family:" (ppr tc_name) ; checkFamFlag tc_name ; inj' <- tcInjectivity binders inj @@ -2753,7 +2744,7 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info -- the variables in the header scope only over the injectivity -- declaration but this is not involved here ; (inj', binders, res_kind) - <- bindTyClTyVars tc_name $ \ _ binders res_kind -> + <- bindTyClTyVarsAndZonk tc_name $ \ binders res_kind -> do { inj' <- tcInjectivity binders inj ; return (inj', binders, res_kind) } @@ -2840,7 +2831,7 @@ tcInjectivity tcbs (Just (L loc (InjectivityAnn _ _ lInjNames))) text "Illegal injectivity annotation" $$ text "Use TypeFamilyDependencies to allow this") ; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames - ; inj_tvs <- mapM zonkTcTyVarToTyVar inj_tvs -- zonk the kinds + ; inj_tvs <- zonkTcTyVarsToTcTyVars inj_tvs -- zonk the kinds ; let inj_ktvs = filterVarSet isTyVar $ -- no injective coercion vars closeOverKinds (mkVarSet inj_tvs) ; let inj_bools = map (`elemVarSet` inj_ktvs) tvs @@ -2851,10 +2842,10 @@ tcInjectivity tcbs (Just (L loc (InjectivityAnn _ _ lInjNames))) tcTySynRhs :: RolesInfo -> Name -> LHsType GhcRn -> TcM TyCon tcTySynRhs roles_info tc_name hs_ty - = bindTyClTyVars tc_name $ \ _ binders res_kind -> + = bindTyClTyVars tc_name $ \ binders res_kind -> do { env <- getLclEnv ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env)) - ; rhs_ty <- pushLevelAndSolveEqualities skol_info (binderVars binders) $ + ; rhs_ty <- pushLevelAndSolveEqualities skol_info binders $ tcCheckLHsType hs_ty (TheKind res_kind) -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType @@ -2868,8 +2859,9 @@ tcTySynRhs roles_info tc_name hs_ty , ppr rhs_ty ] ) } ; doNotQuantifyTyVars dvs mk_doc - ; ze <- mkEmptyZonkEnv NoFlexi - ; rhs_ty <- zonkTcTypeToTypeX ze rhs_ty + ; ze <- mkEmptyZonkEnv NoFlexi + ; (ze, binders) <- zonkTyVarBindersX ze binders + ; rhs_ty <- zonkTcTypeToTypeX ze rhs_ty ; let roles = roles_info tc_name ; return (buildSynTyCon tc_name binders res_kind roles rhs_ty) } where @@ -2885,26 +2877,20 @@ tcDataDefn err_ctxt roles_info tc_name -- via inferInitialKinds , dd_cons = cons , dd_derivs = derivs }) - = bindTyClTyVars tc_name $ \ tctc tycon_binders res_kind -> - -- 'tctc' is a 'TcTyCon' and has the 'tcTyConScopedTyVars' that we need - -- unlike the finalized 'tycon' defined above which is an 'AlgTyCon' - -- + = bindTyClTyVars tc_name $ \ tc_bndrs res_kind -> -- The TyCon tyvars must scope over -- - the stupid theta (dd_ctxt) -- - for H98 constructors only, the ConDecl -- But it does no harm to bring them into scope -- over GADT ConDecls as well; and it's awkward not to do { gadt_syntax <- dataDeclChecks tc_name new_or_data ctxt cons - -- see Note [Datatype return kinds] - ; (extra_bndrs, final_res_kind) <- etaExpandAlgTyCon tycon_binders res_kind ; tcg_env <- getGblEnv ; let hsc_src = tcg_src tcg_env ; unless (mk_permissive_kind hsc_src cons) $ - checkDataKindSig (DataDeclSort new_or_data) final_res_kind + checkDataKindSig (DataDeclSort new_or_data) res_kind - ; let skol_tvs = binderVars tycon_binders - ; stupid_tc_theta <- pushLevelAndSolveEqualities skol_info skol_tvs $ + ; stupid_tc_theta <- pushLevelAndSolveEqualities skol_info tc_bndrs $ tcHsContext ctxt -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType @@ -2919,36 +2905,39 @@ tcDataDefn err_ctxt roles_info tc_name , pprTheta theta ] ) } ; doNotQuantifyTyVars dvs mk_doc - ; ze <- mkEmptyZonkEnv NoFlexi - ; stupid_theta <- zonkTcTypesToTypesX ze stupid_tc_theta - -- Check that we don't use kind signatures without the extension ; kind_signatures <- xoptM LangExt.KindSignatures ; when (isJust mb_ksig) $ checkTc (kind_signatures) (badSigTyDecl tc_name) + ; ze <- mkEmptyZonkEnv NoFlexi + ; (ze, bndrs) <- zonkTyVarBindersX ze tc_bndrs + ; stupid_theta <- zonkTcTypesToTypesX ze stupid_tc_theta + ; res_kind <- zonkTcTypeToTypeX ze res_kind + ; tycon <- fixM $ \ rec_tycon -> do - { let final_bndrs = tycon_binders `chkAppend` extra_bndrs - roles = roles_info tc_name - ; data_cons <- tcConDecls - new_or_data DDataType - rec_tycon final_bndrs final_res_kind - cons + { data_cons <- tcConDecls new_or_data DDataType rec_tycon + tc_bndrs res_kind cons ; tc_rhs <- mk_tc_rhs hsc_src rec_tycon data_cons ; tc_rep_nm <- newTyConRepName tc_name + ; return (mkAlgTyCon tc_name - final_bndrs - final_res_kind - roles + bndrs + res_kind + (roles_info tc_name) (fmap unLoc cType) stupid_theta tc_rhs (VanillaAlgTyCon tc_rep_nm) - gadt_syntax) } - ; let deriv_info = DerivInfo { di_rep_tc = tycon - , di_scoped_tvs = tcTyConScopedTyVars tctc + gadt_syntax) + } + + ; let scoped_tvs = mkTyVarNamePairs (binderVars tc_bndrs) + -- scoped_tvs: still the skolem TcTyVars + deriv_info = DerivInfo { di_rep_tc = tycon + , di_scoped_tvs = scoped_tvs , di_clauses = derivs , di_ctxt = err_ctxt } - ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tycon_binders $$ ppr extra_bndrs) + ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tc_bndrs) ; return (tycon, [deriv_info]) } where skol_info = TyConSkol flav tc_name @@ -3094,7 +3083,7 @@ The wildcards are particularly awkward: they may need to be quantified So, we use bindOuterFamEqnTKBndrs (which does not create an implication for the telescope), and generalise over /all/ the variables in the LHS, -without treating the explicitly-quanfitifed ones specially. Wrinkles: +without treating the explicitly-quantifed ones specially. Wrinkles: - When generalising, include the explicit user-specified forall'd variables, so that we get an error from Validity.checkFamPatBinders @@ -3125,16 +3114,17 @@ tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo -> TcM ([TyVar], [TcType], TcType) -- (tyvars, pats, rhs) -- Used only for type families, not data families tcTyFamInstEqnGuts fam_tc mb_clsinfo outer_hs_bndrs hs_pats hs_rhs_ty - = do { traceTc "tcTyFamInstEqnGuts {" (ppr fam_tc) + = do { traceTc "tcTyFamInstEqnGuts {" (ppr fam_tc $$ ppr outer_hs_bndrs $$ ppr hs_pats) -- By now, for type families (but not data families) we should -- have checked that the number of patterns matches tyConArity + ; skol_info <- mkSkolemInfo FamInstSkol -- This code is closely related to the code -- in GHC.Tc.Gen.HsType.kcCheckDeclHeader_cusk - ; (tclvl, wanted, (outer_tvs, (lhs_ty, rhs_ty))) + ; (tclvl, wanted, (outer_bndrs, (lhs_ty, rhs_ty))) <- pushLevelAndSolveEqualitiesX "tcTyFamInstEqnGuts" $ - bindOuterFamEqnTKBndrs outer_hs_bndrs $ + bindOuterFamEqnTKBndrs skol_info outer_hs_bndrs $ do { (lhs_ty, rhs_kind) <- tcFamTyPats fam_tc hs_pats -- Ensure that the instance is consistent with its -- parent class (#16008) @@ -3142,6 +3132,12 @@ tcTyFamInstEqnGuts fam_tc mb_clsinfo outer_hs_bndrs hs_pats hs_rhs_ty ; rhs_ty <- tcCheckLHsType hs_rhs_ty (TheKind rhs_kind) ; return (lhs_ty, rhs_ty) } + ; outer_bndrs <- scopedSortOuter outer_bndrs + ; let outer_tvs = outerTyVars outer_bndrs + ; checkFamTelescope tclvl outer_hs_bndrs outer_tvs + + ; traceTc "tcTyFamInstEqnGuts 1" (pprTyVars outer_tvs $$ ppr skol_info) + -- This code (and the stuff immediately above) is very similar -- to that in tcDataFamInstHeader. Maybe we should abstract the -- common code; but for the moment I concluded that it's @@ -3149,15 +3145,17 @@ tcTyFamInstEqnGuts fam_tc mb_clsinfo outer_hs_bndrs hs_pats hs_rhs_ty -- check there too! -- See Note [Generalising in tcTyFamInstEqnGuts] - ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys outer_tvs) - ; qtvs <- quantifyTyVars TryNotToDefaultNonStandardTyVars dvs - ; reportUnsolvedEqualities FamInstSkol qtvs tclvl wanted - ; checkFamTelescope tclvl outer_hs_bndrs outer_tvs + ; dvs <- candidateQTyVarsWithBinders outer_tvs lhs_ty + ; qtvs <- quantifyTyVars skol_info TryNotToDefaultNonStandardTyVars dvs + ; let final_tvs = scopedSort (qtvs ++ outer_tvs) + -- This scopedSort is important: the qtvs may be /interleaved/ with + -- the outer_tvs. See Note [Generalising in tcTyFamInstEqnGuts] + ; reportUnsolvedEqualities skol_info final_tvs tclvl wanted ; traceTc "tcTyFamInstEqnGuts 2" $ vcat [ ppr fam_tc - , text "lhs_ty" <+> ppr lhs_ty - , text "qtvs" <+> pprTyVars qtvs ] + , text "lhs_ty:" <+> ppr lhs_ty + , text "final_tvs:" <+> pprTyVars final_tvs ] -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType -- Example: typecheck/should_fail/T17301 @@ -3169,20 +3167,24 @@ tcTyFamInstEqnGuts fam_tc mb_clsinfo outer_hs_bndrs hs_pats hs_rhs_ty , ppr rhs_ty ] ) } ; doNotQuantifyTyVars dvs_rhs mk_doc - ; ze <- mkEmptyZonkEnv NoFlexi - ; (ze, qtvs) <- zonkTyBndrsX ze qtvs - ; lhs_ty <- zonkTcTypeToTypeX ze lhs_ty - ; rhs_ty <- zonkTcTypeToTypeX ze rhs_ty + ; ze <- mkEmptyZonkEnv NoFlexi + ; (ze, final_tvs) <- zonkTyBndrsX ze final_tvs + ; lhs_ty <- zonkTcTypeToTypeX ze lhs_ty + ; rhs_ty <- zonkTcTypeToTypeX ze rhs_ty ; let pats = unravelFamInstPats lhs_ty -- Note that we do this after solveEqualities -- so that any strange coercions inside lhs_ty -- have been solved before we attempt to unravel it - ; traceTc "tcTyFamInstEqnGuts }" (ppr fam_tc <+> pprTyVars qtvs) - ; return (qtvs, pats, rhs_ty) } + ; traceTc "tcTyFamInstEqnGuts }" (vcat [ ppr fam_tc, pprTyVars final_tvs ]) + -- Don't try to print 'pats' here, because lhs_ty involves + -- a knot-tied type constructor, so we get a black hole + + ; return (final_tvs, pats, rhs_ty) } -checkFamTelescope :: TcLevel -> HsOuterFamEqnTyVarBndrs GhcRn +checkFamTelescope :: TcLevel + -> HsOuterFamEqnTyVarBndrs GhcRn -> [TcTyVar] -> TcM () -- Emit a constraint (forall a b c. <empty>), so that -- we will do telescope-checking on a,b,c @@ -3191,9 +3193,9 @@ checkFamTelescope tclvl hs_outer_bndrs outer_tvs | HsOuterExplicit { hso_bndrs = bndrs } <- hs_outer_bndrs , (b_first : _) <- bndrs , let b_last = last bndrs - skol_info = ForAllSkol $ HsTyVarBndrsRn (map unLoc bndrs) - = setSrcSpan (combineSrcSpans (getLocA b_first) (getLocA b_last)) $ - emitResidualTvConstraint skol_info outer_tvs tclvl emptyWC + = do { skol_info <- mkSkolemInfo (ForAllSkol $ HsTyVarBndrsRn (map unLoc bndrs)) + ; setSrcSpan (combineSrcSpans (getLocA b_first) (getLocA b_last)) $ do + emitResidualTvConstraint skol_info outer_tvs tclvl emptyWC } | otherwise = return () @@ -3202,11 +3204,11 @@ unravelFamInstPats :: TcType -> [TcType] -- Decompose fam_app to get the argument patterns -- -- We expect fam_app to look like (F t1 .. tn) --- tcFamTyPats is capable of returning ((F ty1 |> co) ty2), --- but that can't happen here because we already checked the --- arity of F matches the number of pattern +-- tcFamTyPats is capable of returning ((F ty1 |> co) ty2), +-- but that can't happen here because we already checked the +-- arity of F matches the number of pattern unravelFamInstPats fam_app - = case splitTyConApp_maybe fam_app of + = case tcSplitTyConApp_maybe fam_app of Just (_, pats) -> pats Nothing -> panic "unravelFamInstPats: Ill-typed LHS of family instance" -- The Nothing case cannot happen for type families, because @@ -3363,7 +3365,7 @@ mkDDHeaderTy dd_info rep_tycon tc_bndrs tcConDecls :: NewOrData -> DataDeclInfo -> KnotTied TyCon -- Representation TyCon - -> [TyConBinder] -- Binders of representation TyCon + -> [TcTyConBinder] -- Binders of representation TyCon -> TcKind -- Result kind -> [LConDecl GhcRn] -> TcM [DataCon] tcConDecls new_or_data dd_info rep_tycon tmpl_bndrs res_kind @@ -3376,7 +3378,7 @@ tcConDecls new_or_data dd_info rep_tycon tmpl_bndrs res_kind tcConDecl :: NewOrData -> DataDeclInfo -> KnotTied TyCon -- Representation tycon. Knot-tied! - -> [TyConBinder] -- Binders of representation TyCon + -> [TcTyConBinder] -- Binders of representation TyCon -> TcKind -- Result kind -> NameEnv ConTag -> ConDecl GhcRn @@ -3396,11 +3398,14 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs res_kind tag_map -- hs_qvars = HsQTvs { hsq_implicit = {k} -- , hsq_explicit = {f,b} } - ; traceTc "tcConDecl 1" (vcat [ ppr name, ppr explicit_tkv_nms ]) + ; traceTc "tcConDecl 1" (vcat [ ppr name + , text "explicit_tkv_nms" <+> ppr explicit_tkv_nms + , text "tc_bndrs" <+> ppr tc_bndrs ]) + ; skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> explicit_tkv_nms))) ; (tclvl, wanted, (exp_tvbndrs, (ctxt, arg_tys, field_lbls, stricts))) <- pushLevelAndSolveEqualitiesX "tcConDecl:H98" $ - tcExplicitTKBndrs explicit_tkv_nms $ + tcExplicitTKBndrs skol_info explicit_tkv_nms $ do { ctxt <- tcHsContext hs_ctxt ; let exp_kind = getArgExpKind new_or_data res_kind ; btys <- tcConH98Args exp_kind hs_args @@ -3427,10 +3432,10 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs res_kind tag_map -- the kvs below are those kind variables entirely unmentioned by the user -- and discovered only by generalization - ; kvs <- kindGeneralizeAll fake_ty + ; kvs <- kindGeneralizeAll skol_info fake_ty - ; let skol_tvs = tc_tvs ++ kvs ++ binderVars exp_tvbndrs - ; reportUnsolvedEqualities skol_info skol_tvs tclvl wanted + ; let all_skol_tvs = tc_tvs ++ kvs + ; reportUnsolvedEqualities skol_info all_skol_tvs tclvl wanted -- The skol_info claims that all the variables are bound -- by the data constructor decl, whereas actually the -- univ_tvs are bound by the data type decl itself. It @@ -3439,16 +3444,17 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs res_kind tag_map -- See test dependent/should_fail/T13780a -- Zonk to Types - ; ze <- mkEmptyZonkEnv NoFlexi - ; (ze, qkvs) <- zonkTyBndrsX ze kvs - ; (ze, user_qtvbndrs) <- zonkTyVarBindersX ze exp_tvbndrs - ; arg_tys <- zonkScaledTcTypesToTypesX ze arg_tys - ; ctxt <- zonkTcTypesToTypesX ze ctxt + ; ze <- mkEmptyZonkEnv NoFlexi + ; (ze, tc_bndrs) <- zonkTyVarBindersX ze tc_bndrs + ; (ze, kvs) <- zonkTyBndrsX ze kvs + ; (ze, exp_tvbndrs) <- zonkTyVarBindersX ze exp_tvbndrs + ; arg_tys <- zonkScaledTcTypesToTypesX ze arg_tys + ; ctxt <- zonkTcTypesToTypesX ze ctxt -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls) ; let univ_tvbs = tyConInvisTVBinders tc_bndrs - ex_tvbs = mkTyVarBinders InferredSpec qkvs ++ user_qtvbndrs + ex_tvbs = mkTyVarBinders InferredSpec kvs ++ exp_tvbndrs ex_tvs = binderVars ex_tvbs -- For H98 datatypes, the user-written tyvar binders are precisely -- the universals followed by the existentials. @@ -3472,8 +3478,6 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs res_kind tag_map -- that way checkValidDataCon can complain if it's wrong. ; return [dc] } - where - skol_info = DataConSkol name tcConDecl new_or_data dd_info rep_tycon tc_bndrs _res_kind tag_map -- NB: don't use res_kind here, as it's ill-scoped. Instead, @@ -3485,7 +3489,7 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs _res_kind tag_map = addErrCtxt (dataConCtxt names) $ do { traceTc "tcConDecl 1 gadt" (ppr names) ; let (L _ name : _) = names - + ; skol_info <- mkSkolemInfo (DataConSkol name) ; (tclvl, wanted, (outer_bndrs, (ctxt, arg_tys, res_ty, field_lbls, stricts))) <- pushLevelAndSolveEqualitiesX "tcConDecl:GADT" $ tcOuterTKBndrs skol_info outer_hs_bndrs $ @@ -3515,12 +3519,14 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs _res_kind tag_map ; return (ctxt, arg_tys, res_ty, field_lbls, stricts) } - ; outer_tv_bndrs <- scopedSortOuter outer_bndrs + ; outer_bndrs <- scopedSortOuter outer_bndrs + ; let outer_tv_bndrs = outerTyVarBndrs outer_bndrs - ; tkvs <- kindGeneralizeAll (mkInvisForAllTys outer_tv_bndrs $ - mkPhiTy ctxt $ - mkVisFunTys arg_tys $ - res_ty) + ; tkvs <- kindGeneralizeAll skol_info + (mkInvisForAllTys outer_tv_bndrs $ + mkPhiTy ctxt $ + mkVisFunTys arg_tys $ + res_ty) ; traceTc "tcConDecl:GADT" (ppr names $$ ppr res_ty $$ ppr tkvs) ; reportUnsolvedEqualities skol_info tkvs tclvl wanted @@ -3561,8 +3567,6 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs _res_kind tag_map -- that way checkValidDataCon can complain if it's wrong. } ; mapM buildOneDataCon names } - where - skol_info = DataConSkol (unLoc (head names)) {- Note [GADT return types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -3649,7 +3653,7 @@ tcInferLHsTypeKind doesn't any gratuitous top-level casts. -- it is OpenKind for datatypes and liftedTypeKind. -- Why do we not check for -XUnliftedNewtypes? See point <Error Messages> -- in Note [Implementation of UnliftedNewtypes] -getArgExpKind :: NewOrData -> Kind -> ContextKind +getArgExpKind :: NewOrData -> TcKind -> ContextKind getArgExpKind NewType res_ki = TheKind res_ki getArgExpKind DataType _ = OpenKind @@ -4631,7 +4635,8 @@ checkValidClass cls pred_tvs = tyCoVarsOfType pred check_at (ATI fam_tc m_dflt_rhs) - = do { checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs) + = do { traceTc "ati" (ppr fam_tc $$ ppr tyvars $$ ppr fam_tvs) + ; checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs) (noClassTyVarErr cls fam_tc) -- Check that the associated type mentions at least -- one of the class type variables diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs index b4c1052385..2f55a9cea1 100644 --- a/compiler/GHC/Tc/TyCl/Class.hs +++ b/compiler/GHC/Tc/TyCl/Class.hs @@ -13,7 +13,6 @@ module GHC.Tc.TyCl.Class ( tcClassSigs , tcClassDecl2 - , ClassScopedTVEnv , findMethodBind , instantiateMethod , tcClassMinimalDef @@ -39,7 +38,7 @@ import GHC.Tc.Utils.Unify import GHC.Tc.Utils.Instantiate( tcSuperSkolTyVars ) import GHC.Tc.Gen.HsType import GHC.Tc.Utils.TcMType -import GHC.Core.Type ( piResultTys, substTyVar ) +import GHC.Core.Type ( piResultTys ) import GHC.Core.Predicate import GHC.Core.Multiplicity import GHC.Tc.Types.Origin @@ -68,7 +67,6 @@ import GHC.Data.Maybe import GHC.Types.Basic import GHC.Data.Bag import GHC.Data.BooleanFormula -import GHC.Utils.Misc import Control.Monad import Data.List ( mapAccumL, partition ) @@ -189,16 +187,10 @@ tcClassSigs clas sigs def_methods ************************************************************************ -} --- | Maps class names to the type variables that scope over their bodies. --- See @Note [Scoped tyvars in a TcTyCon]@ in "GHC.Core.TyCon". -type ClassScopedTVEnv = NameEnv [(Name, TyVar)] - -tcClassDecl2 :: ClassScopedTVEnv -- Class scoped type variables - -> LTyClDecl GhcRn -- The class declaration +tcClassDecl2 :: LTyClDecl GhcRn -- The class declaration -> TcM (LHsBinds GhcTc) -tcClassDecl2 class_scoped_tv_env - (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs, +tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs, tcdMeths = default_binds})) = recoverM (return emptyLHsBinds) $ setSrcSpan (getLocA class_name) $ @@ -212,32 +204,26 @@ tcClassDecl2 class_scoped_tv_env -- dm1 = \d -> case ds d of (a,b,c) -> a -- And since ds is big, it doesn't get inlined, so we don't get good -- default methods. Better to make separate AbsBinds for each + + ; skol_info <- mkSkolemInfo (TyConSkol ClassFlavour (getName class_name)) + ; tc_lvl <- getTcLevel ; let (tyvars, _, _, op_items) = classBigSig clas prag_fn = mkPragEnv sigs default_binds sig_fn = mkHsSigFun sigs - (skol_subst, clas_tyvars) = tcSuperSkolTyVars tyvars + (_skol_subst, clas_tyvars) = tcSuperSkolTyVars tc_lvl skol_info tyvars + -- This make skolemTcTyVars, but does not clone, + -- so we can put them in scope with tcExtendTyVarEnv pred = mkClassPred clas (mkTyVarTys clas_tyvars) - scoped_tyvars = - case lookupNameEnv class_scoped_tv_env (unLoc class_name) of - Just tvs -> tvs - Nothing -> pprPanic "tcClassDecl2: Class name not in tcg_class_scoped_tvs_env" - (ppr class_name) - -- The substitution returned by tcSuperSkolTyVars maps each type - -- variable to a TyVarTy, so it is safe to call getTyVar below. - scoped_clas_tyvars = - mapSnd ( getTyVar ("tcClassDecl2: Super-skolem substitution maps " - ++ "type variable to non-type variable") - . substTyVar skol_subst ) scoped_tyvars ; this_dict <- newEvVar pred ; let tc_item = tcDefMeth clas clas_tyvars this_dict default_binds sig_fn prag_fn - ; dm_binds <- tcExtendNameTyVarEnv scoped_clas_tyvars $ + ; dm_binds <- tcExtendTyVarEnv clas_tyvars $ mapM tc_item op_items ; return (unionManyBags dm_binds) } -tcClassDecl2 _ d = pprPanic "tcClassDecl2" (ppr d) +tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d) tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn -> HsSigFun -> TcPragEnv -> ClassOpItem diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index ff44f1864e..65a2887049 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -26,7 +26,7 @@ import GHC.Tc.Errors.Types import GHC.Tc.Gen.Bind import GHC.Tc.TyCl import GHC.Tc.TyCl.Utils ( addTyConsToGblEnv ) -import GHC.Tc.TyCl.Class ( tcClassDecl2, ClassScopedTVEnv, tcATDefault, +import GHC.Tc.TyCl.Class ( tcClassDecl2, tcATDefault, HsSigFun, mkHsSigFun, badMethodErr, findMethodBind, instantiateMethod ) import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities ) @@ -492,8 +492,8 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds do { dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty ; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty -- NB: tcHsClsInstType does checkValidInstance - - ; (subst, skol_tvs) <- tcInstSkolTyVars tyvars + ; skol_info <- mkSkolemInfo InstSkol + ; (subst, skol_tvs) <- tcInstSkolTyVars skol_info tyvars ; let tv_skol_prs = [ (tyVarName tv, skol_tv) | (tv, skol_tv) <- tyvars `zip` skol_tvs ] -- Map from the skolemized Names to the original Names. @@ -691,8 +691,9 @@ tcDataFamInstDecl mb_clsinfo tv_skol_env ; gadt_syntax <- dataDeclChecks fam_name new_or_data hs_ctxt hs_cons -- Do /not/ check that the number of patterns = tyConArity fam_tc -- See [Arity of data families] in GHC.Core.FamInstEnv - ; (qtvs, pats, res_kind, stupid_theta) - <- tcDataFamInstHeader mb_clsinfo fam_tc outer_bndrs fixity + ; skol_info <- mkSkolemInfo FamInstSkol + ; (qtvs, pats, tc_res_kind, stupid_theta) + <- tcDataFamInstHeader mb_clsinfo skol_info fam_tc outer_bndrs fixity hs_ctxt hs_pats m_ksig new_or_data -- Eta-reduce the axiom if possible @@ -702,7 +703,7 @@ tcDataFamInstDecl mb_clsinfo tv_skol_env post_eta_qtvs = filterOut (`elem` eta_tvs) qtvs full_tcbs = mkTyConBindersPreferAnon post_eta_qtvs - (tyCoVarsOfType (mkSpecForAllTys eta_tvs res_kind)) + (tyCoVarsOfType (mkSpecForAllTys eta_tvs tc_res_kind)) ++ eta_tcbs -- Put the eta-removed tyvars at the end -- Remember, qtvs is in arbitrary order, except kind vars are @@ -718,14 +719,39 @@ tcDataFamInstDecl mb_clsinfo tv_skol_env -- we did it before the "extra" tvs from etaExpandAlgTyCon -- would always be eta-reduced -- - ; (extra_tcbs, final_res_kind) <- etaExpandAlgTyCon full_tcbs res_kind + ; let flav = newOrDataToFlavour new_or_data + ; (extra_tcbs, tc_res_kind) <- etaExpandAlgTyCon flav skol_info full_tcbs tc_res_kind -- Check the result kind; it may come from a user-written signature. -- See Note [Datatype return kinds] in GHC.Tc.TyCl point 4(a) - ; let extra_pats = map (mkTyVarTy . binderVar) extra_tcbs - all_pats = pats `chkAppend` extra_pats - orig_res_ty = mkTyConApp fam_tc all_pats - ty_binders = full_tcbs `chkAppend` extra_tcbs + ; let extra_pats = map (mkTyVarTy . binderVar) extra_tcbs + all_pats = pats `chkAppend` extra_pats + orig_res_ty = mkTyConApp fam_tc all_pats + tc_ty_binders = full_tcbs `chkAppend` extra_tcbs + + ; traceTc "tcDataFamInstDecl 1" $ + vcat [ text "Fam tycon:" <+> ppr fam_tc + , text "Pats:" <+> ppr pats + , text "visibilities:" <+> ppr (tcbVisibilities fam_tc pats) + , text "all_pats:" <+> ppr all_pats + , text "tc_ty_binders" <+> ppr tc_ty_binders + , text "fam_tc_binders:" <+> ppr (tyConBinders fam_tc) + , text "tc_res_kind:" <+> ppr tc_res_kind + , text "eta_pats" <+> ppr eta_pats + , text "eta_tcbs" <+> ppr eta_tcbs ] + + -- Zonk the patterns etc into the Type world + ; ze <- mkEmptyZonkEnv NoFlexi + ; (ze, ty_binders) <- zonkTyVarBindersX ze tc_ty_binders + ; res_kind <- zonkTcTypeToTypeX ze tc_res_kind + ; all_pats <- zonkTcTypesToTypesX ze all_pats + ; eta_pats <- zonkTcTypesToTypesX ze eta_pats + ; stupid_theta <- zonkTcTypesToTypesX ze stupid_theta + ; let zonked_post_eta_qtvs = map (lookupTyVarX ze) post_eta_qtvs + zonked_eta_tvs = map (lookupTyVarX ze) eta_tvs + -- All these qtvs are in ty_binders, and hence will be in + -- the ZonkEnv, ze. We need the zonked (TyVar) versions to + -- put in the CoAxiom that we are about to build. ; traceTc "tcDataFamInstDecl" $ vcat [ text "Fam tycon:" <+> ppr fam_tc @@ -735,16 +761,14 @@ tcDataFamInstDecl mb_clsinfo tv_skol_env , text "ty_binders" <+> ppr ty_binders , text "fam_tc_binders:" <+> ppr (tyConBinders fam_tc) , text "res_kind:" <+> ppr res_kind - , text "final_res_kind:" <+> ppr final_res_kind , text "eta_pats" <+> ppr eta_pats , text "eta_tcbs" <+> ppr eta_tcbs ] - ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) -> - do { data_cons <- tcExtendTyVarEnv qtvs $ + do { data_cons <- tcExtendTyVarEnv (binderVars tc_ty_binders) $ -- For H98 decls, the tyvars scope -- over the data constructors tcConDecls new_or_data (DDataInstance orig_res_ty) - rec_rep_tc ty_binders final_res_kind + rec_rep_tc tc_ty_binders tc_res_kind hs_cons ; rep_tc_name <- newFamInstTyConName lfam_name pats @@ -752,20 +776,21 @@ tcDataFamInstDecl mb_clsinfo tv_skol_env ; tc_rhs <- case new_or_data of DataType -> return $ mkLevPolyDataTyConRhs - (isFixedRuntimeRepKind final_res_kind) + (isFixedRuntimeRepKind res_kind) data_cons NewType -> assert (not (null data_cons)) $ mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons) - ; let ax_rhs = mkTyConApp rep_tc (mkTyVarTys post_eta_qtvs) + ; let ax_rhs = mkTyConApp rep_tc (mkTyVarTys zonked_post_eta_qtvs) axiom = mkSingleCoAxiom Representational axiom_name - post_eta_qtvs eta_tvs [] fam_tc eta_pats ax_rhs + zonked_post_eta_qtvs zonked_eta_tvs + [] fam_tc eta_pats ax_rhs parent = DataFamInstTyCon axiom fam_tc all_pats -- NB: Use the full ty_binders from the pats. See bullet toward -- the end of Note [Data type families] in GHC.Core.TyCon rep_tc = mkAlgTyCon rep_tc_name - ty_binders final_res_kind + ty_binders res_kind (map (const Nominal) ty_binders) (fmap unLoc cType) stupid_theta tc_rhs parent @@ -862,21 +887,23 @@ TyVarEnv will simply be empty, and there is nothing to worry about. ----------------------- tcDataFamInstHeader - :: AssocInstInfo -> TyCon -> HsOuterFamEqnTyVarBndrs GhcRn + :: AssocInstInfo -> SkolemInfo -> TyCon -> HsOuterFamEqnTyVarBndrs GhcRn -> LexicalFixity -> Maybe (LHsContext GhcRn) -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn) -> NewOrData - -> TcM ([TyVar], [Type], Kind, ThetaType) + -> TcM ([TcTyVar], [TcType], TcKind, TcThetaType) + -- All skolem TcTyVars, all zonked so it's clear what the free vars are + -- The "header" of a data family instance is the part other than -- the data constructors themselves -- e.g. data instance D [a] :: * -> * where ... -- Here the "header" is the bit before the "where" -tcDataFamInstHeader mb_clsinfo fam_tc outer_bndrs fixity +tcDataFamInstHeader mb_clsinfo skol_info fam_tc hs_outer_bndrs fixity hs_ctxt hs_pats m_ksig new_or_data = do { traceTc "tcDataFamInstHeader {" (ppr fam_tc <+> ppr hs_pats) - ; (tclvl, wanted, (scoped_tvs, (stupid_theta, lhs_ty, master_res_kind, instance_res_kind))) + ; (tclvl, wanted, (outer_bndrs, (stupid_theta, lhs_ty, master_res_kind, instance_res_kind))) <- pushLevelAndSolveEqualitiesX "tcDataFamInstHeader" $ - bindOuterFamEqnTKBndrs outer_bndrs $ + bindOuterFamEqnTKBndrs skol_info hs_outer_bndrs $ -- Binds skolem TcTyVars do { stupid_theta <- tcHsContext hs_ctxt ; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc hs_pats ; (lhs_applied_ty, lhs_applied_kind) @@ -901,12 +928,16 @@ tcDataFamInstHeader mb_clsinfo fam_tc outer_bndrs fixity ; _ <- unifyKind (Just . HsTypeRnThing $ unLoc hs_lhs) lhs_applied_kind res_kind ; traceTc "tcDataFamInstHeader" $ - vcat [ ppr fam_tc, ppr m_ksig, ppr lhs_applied_kind, ppr res_kind ] + vcat [ ppr fam_tc, ppr m_ksig, ppr lhs_applied_kind, ppr res_kind, ppr m_ksig] ; return ( stupid_theta , lhs_applied_ty , lhs_applied_kind , res_kind ) } + ; outer_bndrs <- scopedSortOuter outer_bndrs + ; let outer_tvs = outerTyVars outer_bndrs + ; checkFamTelescope tclvl hs_outer_bndrs outer_tvs + -- This code (and the stuff immediately above) is very similar -- to that in tcTyFamInstEqnGuts. Maybe we should abstract the -- common code; but for the moment I concluded that it's @@ -914,34 +945,30 @@ tcDataFamInstHeader mb_clsinfo fam_tc outer_bndrs fixity -- check there too! -- See GHC.Tc.TyCl Note [Generalising in tcFamTyPatsGuts] - ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs) - ; qtvs <- quantifyTyVars TryNotToDefaultNonStandardTyVars dvs - ; reportUnsolvedEqualities FamInstSkol qtvs tclvl wanted - - -- Zonk the patterns etc into the Type world - ; ze <- mkEmptyZonkEnv NoFlexi - ; (ze, qtvs) <- zonkTyBndrsX ze qtvs - ; lhs_ty <- zonkTcTypeToTypeX ze lhs_ty - ; stupid_theta <- zonkTcTypesToTypesX ze stupid_theta - ; master_res_kind <- zonkTcTypeToTypeX ze master_res_kind - ; instance_res_kind <- zonkTcTypeToTypeX ze instance_res_kind - - -- We check that res_kind is OK with checkDataKindSig in - -- tcDataFamInstDecl, after eta-expansion. We need to check that - -- it's ok because res_kind can come from a user-written kind signature. - -- See Note [Datatype return kinds], point (4a) - + ; dvs <- candidateQTyVarsWithBinders outer_tvs lhs_ty + ; qtvs <- quantifyTyVars skol_info TryNotToDefaultNonStandardTyVars dvs + ; let final_tvs = scopedSort (qtvs ++ outer_tvs) + -- This scopedSort is important: the qtvs may be /interleaved/ with + -- the outer_tvs. See Note [Generalising in tcTyFamInstEqnGuts] + ; reportUnsolvedEqualities skol_info final_tvs tclvl wanted + + ; final_tvs <- zonkTcTyVarsToTcTyVars final_tvs + ; lhs_ty <- zonkTcType lhs_ty + ; master_res_kind <- zonkTcType master_res_kind + ; instance_res_kind <- zonkTcType instance_res_kind + ; stupid_theta <- zonkTcTypes stupid_theta + + -- Check that res_kind is OK with checkDataKindSig. We need to + -- check that it's ok because res_kind can come from a user-written + -- kind signature. See Note [Datatype return kinds], point (4a) ; checkDataKindSig (DataInstanceSort new_or_data) master_res_kind ; checkDataKindSig (DataInstanceSort new_or_data) instance_res_kind - -- Check that type patterns match the class instance head - -- The call to splitTyConApp_maybe here is just an inlining of - -- the body of unravelFamInstPats. - ; pats <- case splitTyConApp_maybe lhs_ty of - Just (_, pats) -> pure pats - Nothing -> pprPanic "tcDataFamInstHeader" (ppr lhs_ty) + -- Split up the LHS type to get the type patterns + -- For the scopedSort see Note [Generalising in tcTyFamInstEqnGuts] + ; let pats = unravelFamInstPats lhs_ty - ; return (qtvs, pats, master_res_kind, stupid_theta) } + ; return (final_tvs, pats, master_res_kind, stupid_theta) } where fam_name = tyConName fam_tc data_ctxt = DataKindCtxt fam_name @@ -960,11 +987,9 @@ tcDataFamInstHeader mb_clsinfo fam_tc outer_bndrs fixity -- See Note [Result kind signature for a data family instance] tc_kind_sig (Just hs_kind) = do { sig_kind <- tcLHsKindSig data_ctxt hs_kind - ; lvl <- getTcLevel - ; let (tvs, inner_kind) = tcSplitForAllInvisTyVars sig_kind - ; (subst, _tvs') <- tcInstSkolTyVarsAt lvl False emptyTCvSubst tvs - -- Perhaps surprisingly, we don't need the skolemised tvs themselves - ; return (substTy subst inner_kind) } + ; (_tvs', inner_kind') <- tcSkolemiseInvisibleBndrs (SigTypeSkol data_ctxt) sig_kind + -- Perhaps surprisingly, we don't need the skolemised tvs themselves + ; return inner_kind' } {- Note [Result kind signature for a data family instance] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1166,17 +1191,17 @@ takes a slightly different approach. * * ********************************************************************* -} -tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn] -> ClassScopedTVEnv +tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn] -> TcM (LHsBinds GhcTc) -- (a) From each class declaration, -- generate any default-method bindings -- (b) From each instance decl -- generate the dfun binding -tcInstDecls2 tycl_decls inst_decls class_scoped_tv_env +tcInstDecls2 tycl_decls inst_decls = do { -- (a) Default methods from class decls let class_decls = filter (isClassDecl . unLoc) tycl_decls - ; dm_binds_s <- mapM (tcClassDecl2 class_scoped_tv_env) class_decls + ; dm_binds_s <- mapM tcClassDecl2 class_decls ; let dm_binds = unionManyBags dm_binds_s -- (b) instance declarations @@ -1211,7 +1236,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) setSrcSpan loc $ addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ do { -- Instantiate the instance decl with skolem constants - ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType dfun_id + ; skol_info <- mkSkolemInfo InstSkol + ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType skol_info dfun_id ; dfun_ev_vars <- newEvVars dfun_theta -- We instantiate the dfun_id with superSkolems. -- See Note [Subtle interaction of recursion and overlap] diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index 3aba359f5b..26ffe9116e 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -393,13 +393,18 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details ; checkTc (all (isManyDataConTy . scaledMult) arg_tys) $ TcRnLinearPatSyn sig_body_ty + ; skol_info <- mkSkolemInfo (SigSkol (PatSynCtxt name) pat_ty []) + -- The type here is a bit bogus, but we do not print + -- the type for PatSynCtxt, so it doesn't matter + -- See Note [Skolem info for pattern synonyms] in "GHC.Tc.Types.Origin" + -- Skolemise the quantified type variables. This is necessary -- in order to check the actual pattern type against the -- expected type. Even though the tyvars in the type are -- already skolems, this step changes their TcLevels, -- avoiding level-check errors when unifying. - ; (skol_subst0, skol_univ_bndrs) <- skolemiseTvBndrsX emptyTCvSubst univ_bndrs - ; (skol_subst, skol_ex_bndrs) <- skolemiseTvBndrsX skol_subst0 ex_bndrs + ; (skol_subst0, skol_univ_bndrs) <- skolemiseTvBndrsX skol_info emptyTCvSubst univ_bndrs + ; (skol_subst, skol_ex_bndrs) <- skolemiseTvBndrsX skol_info skol_subst0 ex_bndrs ; let skol_univ_tvs = binderVars skol_univ_bndrs skol_ex_tvs = binderVars skol_ex_bndrs skol_req_theta = substTheta skol_subst0 req_theta @@ -436,11 +441,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details skol_arg_tys ; return (ex_tvs', prov_dicts, args') } - ; let skol_info = SigSkol (PatSynCtxt name) pat_ty [] - -- The type here is a bit bogus, but we do not print - -- the type for PatSynCtxt, so it doesn't matter - -- See Note [Skolem info for pattern synonyms] in "GHC.Tc.Types.Origin" - ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_univ_tvs + ; (implics, ev_binds) <- buildImplicationFor tclvl (getSkolemInfo skol_info) skol_univ_tvs req_dicts wanted -- Solve the constraints now, because we are about to make a PatSyn, @@ -480,15 +481,15 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details -- See Note [Pattern synonyms and higher rank types] ; return (mkLHsWrap wrap $ nlHsVar arg_id) } -skolemiseTvBndrsX :: TCvSubst -> [VarBndr TyVar flag] +skolemiseTvBndrsX :: SkolemInfo -> TCvSubst -> [VarBndr TyVar flag] -> TcM (TCvSubst, [VarBndr TcTyVar flag]) -- Make new TcTyVars, all skolems with levels, but do not clone -- The level is one level deeper than the current level -- See Note [Skolemising when checking a pattern synonym] -skolemiseTvBndrsX orig_subst tvs +skolemiseTvBndrsX skol_info orig_subst tvs = do { tc_lvl <- getTcLevel ; let pushed_lvl = pushTcLevel tc_lvl - details = SkolemTv pushed_lvl False + details = SkolemTv skol_info pushed_lvl False mk_skol_tv_x :: TCvSubst -> VarBndr TyVar flag -> (TCvSubst, VarBndr TcTyVar flag) diff --git a/compiler/GHC/Tc/Types/Constraint.hs b/compiler/GHC/Tc/Types/Constraint.hs index 955874b13f..ffe14b3d62 100644 --- a/compiler/GHC/Tc/Types/Constraint.hs +++ b/compiler/GHC/Tc/Types/Constraint.hs @@ -51,7 +51,7 @@ module GHC.Tc.Types.Constraint ( Implication(..), implicationPrototype, checkTelescopeSkol, ImplicStatus(..), isInsolubleStatus, isSolvedStatus, UserGiven, getUserGivensFromImplics, - HasGivenEqs(..), + HasGivenEqs(..), checkImplicationInvariants, SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth, bumpSubGoalDepth, subGoalDepthExceeded, CtLoc(..), ctLocSpan, ctLocEnv, ctLocLevel, ctLocOrigin, @@ -90,6 +90,7 @@ import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Class import GHC.Core.TyCon +import GHC.Types.Name import GHC.Types.Var import GHC.Tc.Utils.TcType @@ -99,7 +100,6 @@ import GHC.Tc.Types.Origin import GHC.Core import GHC.Core.TyCo.Ppr -import GHC.Types.Name.Occurrence import GHC.Utils.FV import GHC.Types.Var.Set import GHC.Driver.Session @@ -110,9 +110,12 @@ import GHC.Types.SrcLoc import GHC.Data.Bag import GHC.Utils.Misc import GHC.Utils.Panic +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Trace -import Control.Monad ( msum ) +import Control.Monad ( msum, when ) import qualified Data.Semigroup ( (<>) ) +import Data.Maybe( mapMaybe ) -- these are for CheckTyEqResult import Data.Word ( Word8 ) @@ -1315,9 +1318,13 @@ data Implication ic_tclvl :: TcLevel, -- TcLevel of unification variables -- allocated /inside/ this implication - ic_skols :: [TcTyVar], -- Introduced skolems - ic_info :: SkolemInfo, -- See Note [Skolems in an implication] - -- See Note [Shadowing in a constraint] + ic_info :: SkolemInfoAnon, -- See Note [Skolems in an implication] + -- See Note [Shadowing in a constraint] + + ic_skols :: [TcTyVar], -- Introduced skolems; always skolem TcTyVars + -- Their level numbers should be precisely ic_tclvl + -- Their SkolemInfo should be precisely ic_info (almost) + -- See Note [Implication invariants] ic_given :: [EvVar], -- Given evidence variables -- (order does not matter) @@ -1470,7 +1477,7 @@ instance Outputable ImplicStatus where ppr (IC_Solved { ics_dead = dead }) = text "Solved" <+> (braces (text "Dead givens =" <+> ppr dead)) -checkTelescopeSkol :: SkolemInfo -> Bool +checkTelescopeSkol :: SkolemInfoAnon -> Bool -- See Note [Checking telescopes] checkTelescopeSkol (ForAllSkol {}) = True checkTelescopeSkol _ = False @@ -1633,11 +1640,139 @@ never see it. ************************************************************************ * * - Pretty printing + Invariant checking (debug only) * * ************************************************************************ + +Note [Implication invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The skolems of an implication have the following invariants, which are checked +by checkImplicationInvariants: + +a) They are all SkolemTv TcTyVars; no TyVars, no unification variables +b) Their TcLevel matches the ic_lvl for the implication +c) Their SkolemInfo matches the implication. + +Actually (c) is not quite true. Consider + data T a = forall b. MkT a b + +In tcConDecl for MkT we'll create an implication with ic_info of +DataConSkol; but the type variable 'a' will have a SkolemInfo of +TyConSkol. So we allow the tyvar to have a SkolemInfo of TyConFlav if +the implication SkolemInfo is DataConSkol. -} +checkImplicationInvariants, check_implic :: (HasCallStack, Applicative m) => Implication -> m () +{-# INLINE checkImplicationInvariants #-} +-- Nothing => OK, Just doc => doc gives info +checkImplicationInvariants implic = when debugIsOn (check_implic implic) + +check_implic implic@(Implic { ic_tclvl = lvl + , ic_info = skol_info + , ic_skols = skols }) + | null bads = pure () + | otherwise = massertPpr False (vcat [ text "checkImplicationInvariants failure" + , nest 2 (vcat bads) + , ppr implic ]) + where + bads = mapMaybe check skols + + check :: TcTyVar -> Maybe SDoc + check tv | not (isTcTyVar tv) + = pprTrace "checkImplicationInvariants: not TcTyVar" (ppr tv) Nothing + -- Happens in 'deriving' code so I am punting for now + -- Just (ppr tv <+> text "is not a TcTyVar") + | otherwise + = check_details tv (tcTyVarDetails tv) + + check_details :: TcTyVar -> TcTyVarDetails -> Maybe SDoc + check_details tv (SkolemTv tv_skol_info tv_lvl _) + | not (tv_lvl == lvl) + = Just (vcat [ ppr tv <+> text "has level" <+> ppr tv_lvl + , text "ic_lvl" <+> ppr lvl ]) + | not (skol_info `checkSkolInfoAnon` skol_info_anon) + = Just (vcat [ ppr tv <+> text "has skol info" <+> ppr skol_info_anon + , text "ic_info" <+> ppr skol_info ]) + | otherwise + = Nothing + where + skol_info_anon = getSkolemInfo tv_skol_info + check_details tv details + = Just (ppr tv <+> text "is not a SkolemTv" <+> ppr details) + +checkSkolInfoAnon :: SkolemInfoAnon -- From the implication + -> SkolemInfoAnon -- From the type variable + -> Bool -- True <=> ok +-- Used only for debug-checking; checkImplicationInvariants +-- So it doesn't matter much if its's incomplete +checkSkolInfoAnon sk1 sk2 = go sk1 sk2 + where + go (SigSkol c1 t1 s1) (SigSkol c2 t2 s2) = c1==c2 && t1 `tcEqType` t2 && s1==s2 + go (SigTypeSkol cx1) (SigTypeSkol cx2) = cx1==cx2 + + go (ForAllSkol _) (ForAllSkol _) = True + + go (IPSkol ips1) (IPSkol ips2) = ips1 == ips2 + go (DerivSkol pred1) (DerivSkol pred2) = pred1 `tcEqType` pred2 + go (TyConSkol f1 n1) (TyConSkol f2 n2) = f1==f2 && n1==n2 + go (DataConSkol n1) (DataConSkol n2) = n1==n2 + go InstSkol InstSkol = True + go FamInstSkol FamInstSkol = True + go BracketSkol BracketSkol = True + go (RuleSkol n1) (RuleSkol n2) = n1==n2 + go (PatSkol c1 _) (PatSkol c2 _) = getName c1 == getName c2 + -- Too tedious to compare the HsMatchContexts + go (InferSkol ids1) (InferSkol ids2) = equalLength ids1 ids2 && + and (zipWith eq_pr ids1 ids2) + go (UnifyForAllSkol t1) (UnifyForAllSkol t2) = t1 `tcEqType` t2 + go ReifySkol ReifySkol = True + go QuantCtxtSkol QuantCtxtSkol = True + go RuntimeUnkSkol RuntimeUnkSkol = True + go ArrowReboundIfSkol ArrowReboundIfSkol = True + go (UnkSkol _) (UnkSkol _) = True + + -------- Three slightly strange special cases -------- + go (DataConSkol _) (TyConSkol f _) = h98_data_decl f + -- In the H98 declaration data T a = forall b. MkT a b + -- in tcConDecl for MkT we'll have a SkolemInfo in the implication of + -- DataConSkol, but the type variable 'a' will have a SkolemInfo of TyConSkol + + go (DataConSkol _) FamInstSkol = True + -- In data/newtype instance T a = MkT (a -> a), + -- in tcConDecl for MkT we'll have a SkolemInfo in the implication of + -- DataConSkol, but 'a' will have SkolemInfo of FamInstSkol + + go FamInstSkol InstSkol = True + -- In instance C (T a) where { type F (T a) b = ... } + -- we have 'a' with SkolemInfo InstSkol, but we make an implication wi + -- SkolemInfo of FamInstSkol. Very like the ConDecl/TyConSkol case + + go (ForAllSkol _) _ = True + -- Telescope tests: we need a ForAllSkol to force the telescope + -- test, but the skolems might come from (say) a family instance decl + -- type instance forall a. F [a] = a->a + + go (SigTypeSkol DerivClauseCtxt) (TyConSkol f _) = h98_data_decl f + -- e.g. newtype T a = MkT ... deriving blah + -- We use the skolems from T (TyConSkol) when typechecking + -- the deriving clauses (SigTypeSkol DerivClauseCtxt) + + go _ _ = False + + eq_pr :: (Name,TcType) -> (Name,TcType) -> Bool + eq_pr (i1,_) (i2,_) = i1==i2 -- Types may be differently zonked + + h98_data_decl DataTypeFlavour = True + h98_data_decl NewtypeFlavour = True + h98_data_decl _ = False + + +{- ********************************************************************* +* * + Pretty printing +* * +********************************************************************* -} + pprEvVars :: [EvVar] -> SDoc -- Print with their types pprEvVars ev_vars = vcat (map pprEvVarWithType ev_vars) @@ -2195,7 +2330,7 @@ mkKindLoc s1 s2 loc = setCtLocOrigin (toKindLoc loc) toKindLoc :: CtLoc -> CtLoc toKindLoc loc = loc { ctl_t_or_k = Just KindLevel } -mkGivenLoc :: TcLevel -> SkolemInfo -> TcLclEnv -> CtLoc +mkGivenLoc :: TcLevel -> SkolemInfoAnon -> TcLclEnv -> CtLoc mkGivenLoc tclvl skol_info env = CtLoc { ctl_origin = GivenOrigin skol_info , ctl_env = setLclEnvTcLevel env tclvl diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs index 00f1ca10a0..bfaa1a0675 100644 --- a/compiler/GHC/Tc/Types/Origin.hs +++ b/compiler/GHC/Tc/Types/Origin.hs @@ -15,7 +15,8 @@ module GHC.Tc.Types.Origin ( redundantConstraintsSpan, -- SkolemInfo - SkolemInfo(..), pprSigSkolInfo, pprSkolInfo, + SkolemInfo(..), SkolemInfoAnon(..), mkSkolemInfo, getSkolemInfo, pprSigSkolInfo, pprSkolInfo, + unkSkol, unkSkolAnon, -- CtOrigin CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin, @@ -38,7 +39,6 @@ module GHC.Tc.Types.Origin ( ) where import GHC.Prelude -import GHC.Utils.Misc (HasCallStack) import GHC.Tc.Utils.TcType @@ -62,7 +62,10 @@ import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Trace +import GHC.Stack +import GHC.Utils.Monad +import GHC.Types.Unique +import GHC.Types.Unique.Supply {- ********************************************************************* * * @@ -97,7 +100,7 @@ data UserTypeCtxt | PatSigCtxt -- Type sig in pattern -- eg f (x::t) = ... -- or (x::t, y) = e - | RuleSigCtxt Name -- LHS of a RULE forall + | RuleSigCtxt FastString Name -- LHS of a RULE forall -- RULE "foo" forall (x :: a -> a). f (Just x) = ... | ForSigCtxt Name -- Foreign import or export signature | DefaultDeclCtxt -- Types in a default declaration @@ -124,6 +127,7 @@ data UserTypeCtxt | DataKindCtxt Name -- The kind of a data/newtype (instance) | TySynKindCtxt Name -- The kind of the RHS of a type synonym | TyFamResKindCtxt Name -- The result kind of a type family + deriving( Eq ) -- Just for checkSkolInfoAnon -- | Report Redundant Constraints. data ReportRedundantConstraints @@ -132,6 +136,7 @@ data ReportRedundantConstraints -- is the SrcSpan for the constraints -- E.g. f :: (Eq a, Ord b) => blah -- The span is for the (Eq a, Ord b) + deriving( Eq ) -- Just for checkSkolInfoAnon reportRedundantConstraints :: ReportRedundantConstraints -> Bool reportRedundantConstraints NoRRC = False @@ -158,7 +163,7 @@ redundantConstraintsSpan _ = noSrcSpan pprUserTypeCtxt :: UserTypeCtxt -> SDoc pprUserTypeCtxt (FunSigCtxt n _) = text "the type signature for" <+> quotes (ppr n) pprUserTypeCtxt (InfSigCtxt n) = text "the inferred type for" <+> quotes (ppr n) -pprUserTypeCtxt (RuleSigCtxt n) = text "the type signature for" <+> quotes (ppr n) +pprUserTypeCtxt (RuleSigCtxt _ n) = text "the type signature for" <+> quotes (ppr n) pprUserTypeCtxt (ExprSigCtxt _) = text "an expression type signature" pprUserTypeCtxt KindSigCtxt = text "a kind signature" pprUserTypeCtxt (StandaloneKindSigCtxt n) = text "a standalone kind signature for" <+> quotes (ppr n) @@ -198,10 +203,31 @@ isSigMaybe _ = Nothing ************************************************************************ -} --- SkolemInfo gives the origin of *given* constraints --- a) type variables are skolemised --- b) an implication constraint is generated +-- | 'SkolemInfo' stores the origin of a skolem type variable, +-- so that we can display this information to the user in case of a type error. +-- +-- The 'Unique' field allows us to report all skolem type variables bound in the +-- same place in a single report. data SkolemInfo + = SkolemInfo + Unique -- ^ used to common up skolem variables bound at the same location (only used in pprSkols) + SkolemInfoAnon -- ^ the information about the origin of the skolem type variable + +instance Uniquable SkolemInfo where + getUnique (SkolemInfo u _) = u + +-- | 'SkolemInfoAnon' stores the origin of a skolem type variable (e.g. bound by +-- a user-written forall, the header of a data declaration, a deriving clause, ...). +-- +-- This information is displayed when reporting an error message, such as +-- +-- @"Couldn't match 'k' with 'l'"@ +-- +-- This allows us to explain where the type variable came from. +-- +-- When several skolem type variables are bound at once, prefer using 'SkolemInfo', +-- which stores a 'Unique' which allows these type variables to be reported +data SkolemInfoAnon = SigSkol -- A skolem that is created by instantiating -- a programmer-supplied type signature -- Location of the binding site is on the TyVar @@ -259,12 +285,41 @@ data SkolemInfo | RuntimeUnkSkol -- Runtime skolem from the GHCi debugger #14628 - | UnkSkol -- Unhelpful info (until I improve it) + | ArrowReboundIfSkol -- Bound by the expected type of the rebound arrow ifThenElse command. + + | UnkSkol CallStack + + +-- | Use this when you can't specify a helpful origin for +-- some skolem type variable. +-- +-- We're hoping to be able to get rid of this entirely, but for the moment +-- it's still needed. +unkSkol :: HasCallStack => SkolemInfo +unkSkol = SkolemInfo (mkUniqueGrimily 0) unkSkolAnon + +unkSkolAnon :: HasCallStack => SkolemInfoAnon +unkSkolAnon = UnkSkol callStack + +-- | Wrap up the origin of a skolem type variable with a new 'Unique', +-- so that we can common up skolem type variables whose 'SkolemInfo' +-- shares a certain 'Unique'. +mkSkolemInfo :: MonadIO m => SkolemInfoAnon -> m SkolemInfo +mkSkolemInfo sk_anon = do + u <- liftIO $! uniqFromMask 's' + return (SkolemInfo u sk_anon) + +getSkolemInfo :: SkolemInfo -> SkolemInfoAnon +getSkolemInfo (SkolemInfo _ skol_anon) = skol_anon + instance Outputable SkolemInfo where + ppr (SkolemInfo _ sk_info ) = ppr sk_info + +instance Outputable SkolemInfoAnon where ppr = pprSkolInfo -pprSkolInfo :: SkolemInfo -> SDoc +pprSkolInfo :: SkolemInfoAnon -> SDoc -- Complete the sentence "is a rigid type variable bound by..." pprSkolInfo (SigSkol cx ty _) = pprSigSkolInfo cx ty pprSkolInfo (SigTypeSkol cx) = pprUserTypeCtxt cx @@ -281,18 +336,20 @@ pprSkolInfo (PatSkol cl mc) = sep [ pprPatSkolInfo cl pprSkolInfo (InferSkol ids) = hang (text "the inferred type" <> plural ids <+> text "of") 2 (vcat [ ppr name <+> dcolon <+> ppr ty | (name,ty) <- ids ]) -pprSkolInfo (UnifyForAllSkol ty) = text "the type" <+> ppr ty +pprSkolInfo (UnifyForAllSkol ty) = text "the type" <+> ppr ty pprSkolInfo (TyConSkol flav name) = text "the" <+> ppr flav <+> text "declaration for" <+> quotes (ppr name) -pprSkolInfo (DataConSkol name)= text "the data constructor" <+> quotes (ppr name) -pprSkolInfo ReifySkol = text "the type being reified" +pprSkolInfo (DataConSkol name) = text "the type signature for" <+> quotes (ppr name) +pprSkolInfo ReifySkol = text "the type being reified" pprSkolInfo (QuantCtxtSkol {}) = text "a quantified context" pprSkolInfo RuntimeUnkSkol = text "Unknown type from GHCi runtime" +pprSkolInfo ArrowReboundIfSkol = text "the expected type of a rebound if-then-else command" --- UnkSkol +-- unkSkol -- For type variables the others are dealt with by pprSkolTvBinding. -- For Insts, these cases should not happen -pprSkolInfo UnkSkol = warnPprTrace True "pprSkolInfo: UnkSkol" empty $ text "UnkSkol" +pprSkolInfo (UnkSkol cs) = text "UnkSkol (please report this as a bug)" $$ prettyCallStackDoc cs + pprSigSkolInfo :: UserTypeCtxt -> TcType -> SDoc -- The type is already tidied @@ -391,7 +448,7 @@ instance Outputable TyVarBndrs where data CtOrigin = -- | A given constraint from a user-written type signature. The -- 'SkolemInfo' inside gives more information. - GivenOrigin SkolemInfo + GivenOrigin SkolemInfoAnon -- The following are other origins for given constraints that cannot produce -- new skolems -- hence no SkolemInfo. @@ -422,7 +479,7 @@ data CtOrigin -- Note [Use only the best local instance], both in GHC.Tc.Solver.Interact. | OtherSCOrigin ScDepth -- ^ The number of superclass selections necessary to -- get this constraint - SkolemInfo -- ^ Where the sub-class constraint arose from + SkolemInfoAnon -- ^ Where the sub-class constraint arose from -- (used only for printing) -- All the others are for *wanted* constraints diff --git a/compiler/GHC/Tc/Types/Origin.hs-boot b/compiler/GHC/Tc/Types/Origin.hs-boot new file mode 100644 index 0000000000..1110cc0967 --- /dev/null +++ b/compiler/GHC/Tc/Types/Origin.hs-boot @@ -0,0 +1,8 @@ +module GHC.Tc.Types.Origin where + +import GHC.Stack ( HasCallStack ) + +data SkolemInfoAnon +data SkolemInfo + +unkSkol :: HasCallStack => SkolemInfo diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index 659fc8a474..20b81f8b3c 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -229,14 +229,14 @@ check_inst sig_inst = do mapM_ tcLookupImported_maybe (nameSetElemsStable (orphNamesOfClsInst sig_inst)) -- Based off of 'simplifyDeriv' let ty = idType (instanceDFunId sig_inst) - skol_info = InstSkol -- Based off of tcSplitDFunTy (tvs, theta, pred) = case tcSplitForAllInvisTyVars ty of { (tvs, rho) -> case splitFunTys rho of { (theta, pred) -> (tvs, theta, pred) }} origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst - (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize + skol_info <- mkSkolemInfo InstSkol + (skol_subst, tvs_skols) <- tcInstSkolTyVars skol_info tvs -- Skolemize (tclvl,cts) <- pushTcLevelM $ do wanted <- newWanted origin (Just TypeLevel) @@ -253,7 +253,7 @@ check_inst sig_inst = do return $ wanted : givens unsolved <- simplifyWantedsTcM cts - (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved + (implic, _) <- buildImplicationFor tclvl (getSkolemInfo skol_info) tvs_skols [] unsolved reportAllUnsolved (mkImplicWC implic) -- | For a module @modname@ of type 'HscSource', determine the list diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs index 90c8b9b529..7c270e39bd 100644 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -536,6 +536,7 @@ tcExtendKindEnv extra_env thing_inside -- Scoped type and kind variables tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r tcExtendTyVarEnv tvs thing_inside + -- MP: This silently coerces TyVar to TcTyVar. = tcExtendNameTyVarEnv (mkTyVarNamePairs tvs) thing_inside tcExtendNameTyVarEnv :: [(Name,TcTyVar)] -> TcM r -> TcM r @@ -745,7 +746,7 @@ tcInitTidyEnv = do { let (env', occ') = tidyOccName env (nameOccName name) name' = tidyNameOcc name occ' tyvar1 = setTyVarName tyvar name' - ; tyvar2 <- zonkTcTyVarToTyVar tyvar1 + ; tyvar2 <- zonkTcTyVarToTcTyVar tyvar1 -- Be sure to zonk here! Tidying applies to zonked -- types, so if we don't zonk we may create an -- ill-kinded type (#14175) diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs index dace3d08f6..4193514665 100644 --- a/compiler/GHC/Tc/Utils/Instantiate.hs +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -19,7 +19,8 @@ module GHC.Tc.Utils.Instantiate ( newWanted, newWanteds, tcInstType, tcInstTypeBndrs, - tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt, + tcSkolemiseInvisibleBndrs, + tcInstSkolTyVars, tcInstSkolTyVarsX, tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX, freshenTyVarBndrs, freshenCoVarBndrsX, @@ -168,13 +169,14 @@ In general, -} -topSkolemise :: TcSigmaType +topSkolemise :: SkolemInfo + -> TcSigmaType -> TcM ( HsWrapper , [(Name,TyVar)] -- All skolemised variables , [EvVar] -- All "given"s , TcRhoType ) -- See Note [Skolemisation] -topSkolemise ty +topSkolemise skolem_info ty = go init_subst idHsWrapper [] [] ty where init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)) @@ -183,7 +185,7 @@ topSkolemise ty go subst wrap tv_prs ev_vars ty | (tvs, theta, inner_ty) <- tcSplitSigmaTy ty , not (null tvs && null theta) - = do { (subst', tvs1) <- tcInstSkolTyVarsX subst tvs + = do { (subst', tvs1) <- tcInstSkolTyVarsX skolem_info subst tvs ; ev_vars1 <- newEvVars (substTheta subst' theta) ; go subst' (wrap <.> mkWpTyLams tvs1 <.> mkWpLams ev_vars1) @@ -496,69 +498,98 @@ tcInstTypeBndrs id = do { (subst', tv') <- newMetaTyVarTyVarX subst tv ; return (subst', Bndr tv' spec) } -tcSkolDFunType :: DFunId -> TcM ([TcTyVar], TcThetaType, TcType) +-------------------------- +tcSkolDFunType :: SkolemInfo -> DFunId -> TcM ([TcTyVar], TcThetaType, TcType) -- Instantiate a type signature with skolem constants. -- This freshens the names, but no need to do so -tcSkolDFunType dfun - = do { (tv_prs, theta, tau) <- tcInstType tcInstSuperSkolTyVars dfun +tcSkolDFunType skol_info dfun + = do { (tv_prs, theta, tau) <- tcInstType (tcInstSuperSkolTyVars skol_info) dfun ; return (map snd tv_prs, theta, tau) } -tcSuperSkolTyVars :: [TyVar] -> (TCvSubst, [TcTyVar]) +tcSuperSkolTyVars :: TcLevel -> SkolemInfo -> [TyVar] -> (TCvSubst, [TcTyVar]) -- Make skolem constants, but do *not* give them new names, as above --- Moreover, make them "super skolems"; see comments with superSkolemTv --- see Note [Kind substitution when instantiating] +-- As always, allocate them one level in +-- Moreover, make them "super skolems"; see GHC.Core.InstEnv +-- Note [Binding when looking up instances] +-- See Note [Kind substitution when instantiating] -- Precondition: tyvars should be ordered by scoping -tcSuperSkolTyVars = mapAccumL tcSuperSkolTyVar emptyTCvSubst - -tcSuperSkolTyVar :: TCvSubst -> TyVar -> (TCvSubst, TcTyVar) -tcSuperSkolTyVar subst tv - = (extendTvSubstWithClone subst tv new_tv, new_tv) +tcSuperSkolTyVars tc_lvl skol_info = mapAccumL do_one emptyTCvSubst where - kind = substTyUnchecked subst (tyVarKind tv) - new_tv = mkTcTyVar (tyVarName tv) kind superSkolemTv + details = SkolemTv skol_info (pushTcLevel tc_lvl) + True -- The "super" bit + do_one subst tv = (extendTvSubstWithClone subst tv new_tv, new_tv) + where + kind = substTyUnchecked subst (tyVarKind tv) + new_tv = mkTcTyVar (tyVarName tv) kind details -- | Given a list of @['TyVar']@, skolemize the type variables, -- returning a substitution mapping the original tyvars to the -- skolems, and the list of newly bound skolems. -tcInstSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) +tcInstSkolTyVars :: SkolemInfo -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- See Note [Skolemising type variables] -tcInstSkolTyVars = tcInstSkolTyVarsX emptyTCvSubst +tcInstSkolTyVars skol_info = tcInstSkolTyVarsX skol_info emptyTCvSubst -tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) +tcInstSkolTyVarsX :: SkolemInfo -> TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- See Note [Skolemising type variables] -tcInstSkolTyVarsX = tcInstSkolTyVarsPushLevel False +tcInstSkolTyVarsX skol_info = tcInstSkolTyVarsPushLevel skol_info False -tcInstSuperSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) +tcInstSuperSkolTyVars :: SkolemInfo -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- See Note [Skolemising type variables] -- This version freshens the names and creates "super skolems"; -- see comments around superSkolemTv. -tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTCvSubst +tcInstSuperSkolTyVars skol_info = tcInstSuperSkolTyVarsX skol_info emptyTCvSubst -tcInstSuperSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) +tcInstSuperSkolTyVarsX :: SkolemInfo -> TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- See Note [Skolemising type variables] -- This version freshens the names and creates "super skolems"; -- see comments around superSkolemTv. -tcInstSuperSkolTyVarsX subst = tcInstSkolTyVarsPushLevel True subst +tcInstSuperSkolTyVarsX skol_info subst = tcInstSkolTyVarsPushLevel skol_info True subst -tcInstSkolTyVarsPushLevel :: Bool -- True <=> make "super skolem" +tcInstSkolTyVarsPushLevel :: SkolemInfo -> Bool -- True <=> make "super skolem" -> TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- Skolemise one level deeper, hence pushTcLevel -- See Note [Skolemising type variables] -tcInstSkolTyVarsPushLevel overlappable subst tvs +tcInstSkolTyVarsPushLevel skol_info overlappable subst tvs = do { tc_lvl <- getTcLevel -- Do not retain the whole TcLclEnv ; let !pushed_lvl = pushTcLevel tc_lvl - ; tcInstSkolTyVarsAt pushed_lvl overlappable subst tvs } + ; tcInstSkolTyVarsAt skol_info pushed_lvl overlappable subst tvs } -tcInstSkolTyVarsAt :: TcLevel -> Bool +tcInstSkolTyVarsAt :: SkolemInfo -> TcLevel -> Bool -> TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) -tcInstSkolTyVarsAt lvl overlappable subst tvs +tcInstSkolTyVarsAt skol_info lvl overlappable subst tvs = freshenTyCoVarsX new_skol_tv subst tvs where - details = SkolemTv lvl overlappable - new_skol_tv name kind = mkTcTyVar name kind details + sk_details = SkolemTv skol_info lvl overlappable + new_skol_tv name kind = mkTcTyVar name kind sk_details + +tcSkolemiseInvisibleBndrs :: SkolemInfoAnon -> Type -> TcM ([TcTyVar], TcType) +-- Skolemise the outer invisible binders of a type +-- Do /not/ freshen them, because their scope is broader than +-- just this type. It's a bit dubious, but used in very limited ways. +tcSkolemiseInvisibleBndrs skol_info ty + = do { let (tvs, body_ty) = tcSplitForAllInvisTyVars ty + ; lvl <- getTcLevel + ; skol_info <- mkSkolemInfo skol_info + ; let details = SkolemTv skol_info lvl False + mk_skol_tv name kind = return (mkTcTyVar name kind details) -- No freshening + ; (subst, tvs') <- instantiateTyVarsX mk_skol_tv emptyTCvSubst tvs + ; return (tvs', substTy subst body_ty) } + +instantiateTyVarsX :: (Name -> Kind -> TcM TcTyVar) + -> TCvSubst -> [TyVar] + -> TcM (TCvSubst, [TcTyVar]) +-- Instantiate each type variable in turn with the specified function +instantiateTyVarsX mk_tv subst tvs + = case tvs of + [] -> return (subst, []) + (tv:tvs) -> do { let kind1 = substTyUnchecked subst (tyVarKind tv) + ; tv' <- mk_tv (tyVarName tv) kind1 + ; let subst1 = extendTCvSubstWithClone subst tv tv' + ; (subst', tvs') <- instantiateTyVarsX mk_tv subst1 tvs + ; return (subst', tv':tvs') } ------------------ freshenTyVarBndrs :: [TyVar] -> TcM (TCvSubst, [TyVar]) @@ -580,25 +611,21 @@ freshenTyCoVars mk_tcv = freshenTyCoVarsX mk_tcv emptyTCvSubst freshenTyCoVarsX :: (Name -> Kind -> TyCoVar) -> TCvSubst -> [TyCoVar] -> TcM (TCvSubst, [TyCoVar]) -freshenTyCoVarsX mk_tcv = mapAccumLM (freshenTyCoVarX mk_tcv) - -freshenTyCoVarX :: (Name -> Kind -> TyCoVar) - -> TCvSubst -> TyCoVar -> TcM (TCvSubst, TyCoVar) -- This a complete freshening operation: -- the skolems have a fresh unique, and a location from the monad -- See Note [Skolemising type variables] -freshenTyCoVarX mk_tcv subst tycovar - = do { loc <- getSrcSpanM - ; uniq <- newUnique - ; let old_name = tyVarName tycovar - -- Force so we don't retain reference to the old name and id - -- See (#19619) for more discussion - !old_occ_name = getOccName old_name - new_name = mkInternalName uniq old_occ_name loc - new_kind = substTyUnchecked subst (tyVarKind tycovar) - new_tcv = mk_tcv new_name new_kind - subst1 = extendTCvSubstWithClone subst tycovar new_tcv - ; return (subst1, new_tcv) } +freshenTyCoVarsX mk_tcv + = instantiateTyVarsX freshen_tcv + where + freshen_tcv :: Name -> Kind -> TcM TcTyVar + freshen_tcv name kind + = do { loc <- getSrcSpanM + ; uniq <- newUnique + ; let !occ_name = getOccName name + -- Force so we don't retain reference to the old + -- name and id. See (#19619) for more discussion + new_name = mkInternalName uniq occ_name loc + ; return (mk_tcv new_name kind) } {- Note [Skolemising type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs index 2c26915503..3a0fdca51a 100644 --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -3,6 +3,7 @@ {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# LANGUAGE LambdaCase #-} {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -67,27 +68,29 @@ module GHC.Tc.Utils.TcMType ( -------------------------------- -- Zonking and tidying zonkTidyTcType, zonkTidyTcTypes, zonkTidyOrigin, zonkTidyOrigins, - tidyEvVar, tidyCt, tidyHole, tidySkolemInfo, + tidyEvVar, tidyCt, tidyHole, zonkTcTyVar, zonkTcTyVars, - zonkTcTyVarToTyVar, zonkInvisTVBinder, + zonkTcTyVarToTcTyVar, zonkTcTyVarsToTcTyVars, + zonkInvisTVBinder, zonkTyCoVarsAndFV, zonkTcTypeAndFV, zonkDTyCoVarSetAndFV, zonkTyCoVarsAndFVList, zonkTcType, zonkTcTypes, zonkCo, - zonkTyCoVarKind, zonkTyCoVarKindBinder, + zonkTyCoVarKind, zonkEvVar, zonkWC, zonkImplication, zonkSimples, zonkId, zonkCoVar, - zonkCt, zonkSkolemInfo, + zonkCt, zonkSkolemInfo, zonkSkolemInfoAnon, --------------------------------- -- Promotion, defaulting, skolemisation defaultTyVar, promoteMetaTyVarTo, promoteTyVarSet, quantifyTyVars, isQuantifiableTv, - skolemiseUnboundMetaTyVar, zonkAndSkolemise, skolemiseQuantifiedTyVar, + zonkAndSkolemise, skolemiseQuantifiedTyVar, doNotQuantifyTyVars, candidateQTyVarsOfType, candidateQTyVarsOfKind, candidateQTyVarsOfTypes, candidateQTyVarsOfKinds, + candidateQTyVarsWithBinders, CandidatesQTvs(..), delCandidates, candidateKindVars, partitionCandidates, @@ -108,6 +111,7 @@ import GHC.Tc.Types.Evidence import {-# SOURCE #-} GHC.Tc.Utils.Unify( unifyType {- , unifyKind -} ) import GHC.Tc.Utils.TcType import GHC.Tc.Errors.Types +import GHC.Tc.Errors.Ppr import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr @@ -126,7 +130,6 @@ import GHC.Types.Var.Set import GHC.Builtin.Types import GHC.Types.Error import GHC.Types.Var.Env -import GHC.Types.Name.Env import GHC.Types.Unique.Set import GHC.Types.Basic ( TypeOrKind(..) , NonStandardDefaultingStrategy(..) @@ -848,10 +851,10 @@ newNamedAnonMetaTyVar tyvar_name meta_info kind ; return tyvar } -- makes a new skolem tv -newSkolemTyVar :: Name -> Kind -> TcM TcTyVar -newSkolemTyVar name kind +newSkolemTyVar :: SkolemInfo -> Name -> Kind -> TcM TcTyVar +newSkolemTyVar skol_info name kind = do { lvl <- getTcLevel - ; return (mkTcTyVar name kind (SkolemTv lvl False)) } + ; return (mkTcTyVar name kind (SkolemTv skol_info lvl False)) } newTyVarTyVar :: Name -> Kind -> TcM TcTyVar -- See Note [TyVarTv] @@ -940,7 +943,10 @@ readMetaTyVar tyvar = assertPpr (isMetaTyVar tyvar) (ppr tyvar) $ isFilledMetaTyVar_maybe :: TcTyVar -> TcM (Maybe Type) isFilledMetaTyVar_maybe tv - | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv +-- TODO: This should be an assertion that tv is definitely a TcTyVar but it fails +-- at the moment (Jan 22) + | isTcTyVar tv + , MetaTv { mtv_ref = ref } <- tcTyVarDetails tv = do { cts <- readTcRef ref ; case cts of Indirect ty -> return (Just ty) @@ -1357,6 +1363,12 @@ candidateVars (DV { dv_kvs = dep_kv_set, dv_tvs = nondep_tkv_set }) candidateKindVars :: CandidatesQTvs -> TyVarSet candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs) +delCandidates :: CandidatesQTvs -> [Var] -> CandidatesQTvs +delCandidates (DV { dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) vars + = DV { dv_kvs = kvs `delDVarSetList` vars + , dv_tvs = tvs `delDVarSetList` vars + , dv_cvs = cvs `delVarSetList` vars } + partitionCandidates :: CandidatesQTvs -> (TyVar -> Bool) -> (TyVarSet, CandidatesQTvs) -- The selected TyVars are returned as a non-deterministic TyVarSet partitionCandidates dvs@(DV { dv_kvs = kvs, dv_tvs = tvs }) pred @@ -1366,6 +1378,17 @@ partitionCandidates dvs@(DV { dv_kvs = kvs, dv_tvs = tvs }) pred (extracted_tvs, rest_tvs) = partitionDVarSet pred tvs extracted = dVarSetToVarSet extracted_kvs `unionVarSet` dVarSetToVarSet extracted_tvs +candidateQTyVarsWithBinders :: [TyVar] -> Type -> TcM CandidatesQTvs +-- (candidateQTyVarsWithBinders tvs ty) returns the candidateQTyVars +-- of (forall tvs. ty), but do not treat 'tvs' as bound for the purpose +-- of Note [Naughty quantification candidates]. Why? +-- Because we are going to scoped-sort the quantified variables +-- in among the tvs +candidateQTyVarsWithBinders bound_tvs ty + = do { kvs <- candidateQTyVarsOfKinds (map tyVarKind bound_tvs) + ; all_tvs <- collect_cand_qtvs ty False emptyVarSet kvs ty + ; return (all_tvs `delCandidates` bound_tvs) } + -- | Gathers free variables to use as quantification candidates (in -- 'quantifyTyVars'). This might output the same var -- in both sets, if it's used in both a type and a kind. @@ -1397,12 +1420,6 @@ candidateQTyVarsOfKinds :: [TcKind] -- Not necessarily zonked candidateQTyVarsOfKinds tys = foldM (\acc ty -> collect_cand_qtvs ty True emptyVarSet acc ty) mempty tys -delCandidates :: CandidatesQTvs -> [Var] -> CandidatesQTvs -delCandidates (DV { dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) vars - = DV { dv_kvs = kvs `delDVarSetList` vars - , dv_tvs = tvs `delDVarSetList` vars - , dv_cvs = cvs `delVarSetList` vars } - collect_cand_qtvs :: TcType -- original type that we started recurring into; for errors -> Bool -- True <=> consider every fv in Type to be dependent @@ -1485,6 +1502,11 @@ collect_cand_qtvs orig_ty is_dep bound dvs ty -> return dv -- this variable is from an outer context; skip -- See Note [Use level numbers for quantification] + | case tcTyVarDetails tv of + SkolemTv _ lvl _ -> lvl > pushTcLevel cur_lvl + _ -> False + -> return dv -- Skip inner skolems; ToDo: explain + | intersectsVarSet bound tv_kind_vars -- the tyvar must not be from an outer context, but we have -- already checked for this. @@ -1701,7 +1723,8 @@ For more information about deterministic sets see Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. -} -quantifyTyVars :: NonStandardDefaultingStrategy +quantifyTyVars :: SkolemInfo + -> NonStandardDefaultingStrategy -> CandidatesQTvs -- See Note [Dependent type variables] -- Already zonked -> TcM [TcTyVar] @@ -1712,7 +1735,7 @@ quantifyTyVars :: NonStandardDefaultingStrategy -- invariants on CandidateQTvs, we do not have to filter out variables -- free in the environment here. Just quantify unconditionally, subject -- to the restrictions in Note [quantifyTyVars]. -quantifyTyVars ns_strat dvs +quantifyTyVars skol_info ns_strat dvs -- short-circuit common case | isEmptyCandidates dvs = do { traceTc "quantifyTyVars has nothing to quantify" empty @@ -1744,12 +1767,14 @@ quantifyTyVars ns_strat dvs = return Nothing -- this can happen for a covar that's associated with -- a coercion hole. Test case: typecheck/should_compile/T2494 - | not (isTcTyVar tkv) - = return (Just tkv) -- For associated types in a class with a standalone - -- kind signature, we have the class variables in - -- scope, and they are TyVars not TcTyVars +-- Omit: no TyVars now +-- | not (isTcTyVar tkv) +-- = return (Just tkv) -- For associated types in a class with a standalone +-- -- kind signature, we have the class variables in +-- -- scope, and they are TyVars not TcTyVars + | otherwise - = Just <$> skolemiseQuantifiedTyVar tkv + = Just <$> skolemiseQuantifiedTyVar skol_info tkv isQuantifiableTv :: TcLevel -- Level of the context, outside the quantification -> TcTyVar @@ -1760,25 +1785,25 @@ isQuantifiableTv outer_tclvl tcv | otherwise = False -zonkAndSkolemise :: TcTyCoVar -> TcM TcTyCoVar +zonkAndSkolemise :: SkolemInfo -> TcTyCoVar -> TcM TcTyCoVar -- A tyvar binder is never a unification variable (TauTv), -- rather it is always a skolem. It *might* be a TyVarTv. -- (Because non-CUSK type declarations use TyVarTvs.) -- Regardless, it may have a kind that has not yet been zonked, -- and may include kind unification variables. -zonkAndSkolemise tyvar +zonkAndSkolemise skol_info tyvar | isTyVarTyVar tyvar -- We want to preserve the binding location of the original TyVarTv. -- This is important for error messages. If we don't do this, then -- we get bad locations in, e.g., typecheck/should_fail/T2688 - = do { zonked_tyvar <- zonkTcTyVarToTyVar tyvar - ; skolemiseQuantifiedTyVar zonked_tyvar } + = do { zonked_tyvar <- zonkTcTyVarToTcTyVar tyvar + ; skolemiseQuantifiedTyVar skol_info zonked_tyvar } | otherwise = assertPpr (isImmutableTyVar tyvar || isCoVar tyvar) (pprTyVar tyvar) $ zonkTyCoVarKind tyvar -skolemiseQuantifiedTyVar :: TcTyVar -> TcM TcTyVar +skolemiseQuantifiedTyVar :: SkolemInfo -> TcTyVar -> TcM TcTyVar -- The quantified type variables often include meta type variables -- we want to freeze them into ordinary type variables -- The meta tyvar is updated to point to the new skolem TyVar. Now any @@ -1790,14 +1815,14 @@ skolemiseQuantifiedTyVar :: TcTyVar -> TcM TcTyVar -- This function is called on both kind and type variables, -- but kind variables *only* if PolyKinds is on. -skolemiseQuantifiedTyVar tv +skolemiseQuantifiedTyVar skol_info tv = case tcTyVarDetails tv of SkolemTv {} -> do { kind <- zonkTcType (tyVarKind tv) ; return (setTyVarKind tv kind) } -- It might be a skolem type variable, -- for example from a user type signature - MetaTv {} -> skolemiseUnboundMetaTyVar tv + MetaTv {} -> skolemiseUnboundMetaTyVar skol_info tv _other -> pprPanic "skolemiseQuantifiedTyVar" (ppr tv) -- RuntimeUnk @@ -1909,32 +1934,42 @@ defaultTyVars ns_strat dvs where (dep_kvs, nondep_tvs) = candidateVars dvs -skolemiseUnboundMetaTyVar :: TcTyVar -> TcM TyVar +skolemiseUnboundMetaTyVar :: SkolemInfo -> TcTyVar -> TcM TyVar -- We have a Meta tyvar with a ref-cell inside it -- Skolemise it, so that we are totally out of Meta-tyvar-land -- We create a skolem TcTyVar, not a regular TyVar -- See Note [Zonking to Skolem] -skolemiseUnboundMetaTyVar tv +-- +-- Its level should be one greater than the ambient level, which will typically +-- be the same as the level on the meta-tyvar. But not invariably; for example +-- f :: (forall a b. SameKind a b) -> Int +-- The skolems 'a' and 'b' are bound by tcTKTelescope, at level 2; and they each +-- have a level-2 kind unification variable, since it might get unified with another +-- of the level-2 skolems e.g. 'k' in this version +-- f :: (forall k (a :: k) b. SameKind a b) -> Int +-- So when we quantify the kind vars at the top level of the signature, the ambient +-- level is 1, but we will quantify over kappa[2]. + +skolemiseUnboundMetaTyVar skol_info tv = assertPpr (isMetaTyVar tv) (ppr tv) $ - do { when debugIsOn (check_empty tv) - ; here <- getSrcSpanM -- Get the location from "here" - -- ie where we are generalising - ; kind <- zonkTcType (tyVarKind tv) - ; let tv_name = tyVarName tv + do { check_empty tv + ; tc_lvl <- getTcLevel -- Get the location and level from "here" + ; here <- getSrcSpanM -- i.e. where we are generalising + ; kind <- zonkTcType (tyVarKind tv) + ; let tv_name = tyVarName tv -- See Note [Skolemising and identity] final_name | isSystemName tv_name = mkInternalName (nameUnique tv_name) (nameOccName tv_name) here | otherwise = tv_name - final_tv = mkTcTyVar final_name kind details + details = SkolemTv skol_info (pushTcLevel tc_lvl) False + final_tv = mkTcTyVar final_name kind details ; traceTc "Skolemising" (ppr tv <+> text ":=" <+> ppr final_tv) ; writeMetaTyVar tv (mkTyVarTy final_tv) ; return final_tv } - where - details = SkolemTv (metaTyVarTcLevel tv) False check_empty tv -- [Sept 04] Check for non-empty. = when debugIsOn $ -- See note [Silly Type Synonym] do { cts <- readMetaTyVar tv @@ -2319,10 +2354,6 @@ zonkTyCoVarKind :: TyCoVar -> TcM TyCoVar zonkTyCoVarKind tv = do { kind' <- zonkTcType (tyVarKind tv) ; return (setTyVarKind tv kind') } -zonkTyCoVarKindBinder :: (VarBndr TyCoVar fl) -> TcM (VarBndr TyCoVar fl) -zonkTyCoVarKindBinder (Bndr tv fl) = do { kind' <- zonkTcType (tyVarKind tv) - ; return $ Bndr (setTyVarKind tv kind') fl } - {- ************************************************************************ * * @@ -2339,7 +2370,7 @@ zonkImplication implic@(Implic { ic_skols = skols = do { skols' <- mapM zonkTyCoVarKind skols -- Need to zonk their kinds! -- as #7230 showed ; given' <- mapM zonkEvVar given - ; info' <- zonkSkolemInfo info + ; info' <- zonkSkolemInfoAnon info ; wanted' <- zonkWCRec wanted ; return (implic { ic_skols = skols' , ic_given = given' @@ -2422,13 +2453,16 @@ zonkCtEvidence ctev } zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo -zonkSkolemInfo (SigSkol cx ty tv_prs) = do { ty' <- zonkTcType ty +zonkSkolemInfo (SkolemInfo u sk) = SkolemInfo u <$> zonkSkolemInfoAnon sk + +zonkSkolemInfoAnon :: SkolemInfoAnon -> TcM SkolemInfoAnon +zonkSkolemInfoAnon (SigSkol cx ty tv_prs) = do { ty' <- zonkTcType ty ; return (SigSkol cx ty' tv_prs) } -zonkSkolemInfo (InferSkol ntys) = do { ntys' <- mapM do_one ntys +zonkSkolemInfoAnon (InferSkol ntys) = do { ntys' <- mapM do_one ntys ; return (InferSkol ntys') } where do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') } -zonkSkolemInfo skol_info = return skol_info +zonkSkolemInfoAnon skol_info = return skol_info {- %************************************************************************ @@ -2503,17 +2537,20 @@ zonkTcTyVar tv -- Variant that assumes that any result of zonking is still a TyVar. -- Should be used only on skolems and TyVarTvs -zonkTcTyVarToTyVar :: HasDebugCallStack => TcTyVar -> TcM TcTyVar -zonkTcTyVarToTyVar tv +zonkTcTyVarsToTcTyVars :: HasDebugCallStack => [TcTyVar] -> TcM [TcTyVar] +zonkTcTyVarsToTcTyVars = mapM zonkTcTyVarToTcTyVar + +zonkTcTyVarToTcTyVar :: HasDebugCallStack => TcTyVar -> TcM TcTyVar +zonkTcTyVarToTcTyVar tv = do { ty <- zonkTcTyVar tv ; let tv' = case tcGetTyVar_maybe ty of Just tv' -> tv' - Nothing -> pprPanic "zonkTcTyVarToTyVar" + Nothing -> pprPanic "zonkTcTyVarToTcTyVar" (ppr tv $$ ppr ty) ; return tv' } -zonkInvisTVBinder :: VarBndr TcTyVar spec -> TcM (VarBndr TyVar spec) -zonkInvisTVBinder (Bndr tv spec) = do { tv' <- zonkTcTyVarToTyVar tv +zonkInvisTVBinder :: VarBndr TcTyVar spec -> TcM (VarBndr TcTyVar spec) +zonkInvisTVBinder (Bndr tv spec) = do { tv' <- zonkTcTyVarToTcTyVar tv ; return (Bndr tv' spec) } -- zonkId is used *during* typechecking just to zonk the Id's type @@ -2563,12 +2600,12 @@ zonkTidyTcTypes = zonkTidyTcTypes' [] zonkTidyOrigin :: TidyEnv -> CtOrigin -> TcM (TidyEnv, CtOrigin) zonkTidyOrigin env (GivenOrigin skol_info) - = do { skol_info1 <- zonkSkolemInfo skol_info - ; let skol_info2 = tidySkolemInfo env skol_info1 + = do { skol_info1 <- zonkSkolemInfoAnon skol_info + ; let skol_info2 = tidySkolemInfoAnon env skol_info1 ; return (env, GivenOrigin skol_info2) } zonkTidyOrigin env (OtherSCOrigin sc_depth skol_info) - = do { skol_info1 <- zonkSkolemInfo skol_info - ; let skol_info2 = tidySkolemInfo env skol_info1 + = do { skol_info1 <- zonkSkolemInfoAnon skol_info + ; let skol_info2 = tidySkolemInfoAnon env skol_info1 ; return (env, OtherSCOrigin sc_depth skol_info2) } zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual = act , uo_expected = exp }) @@ -2622,43 +2659,6 @@ tidyHole env h@(Hole { hole_ty = ty }) = h { hole_ty = tidyType env ty } tidyEvVar :: TidyEnv -> EvVar -> EvVar tidyEvVar env var = updateIdTypeAndMult (tidyType env) var ----------------- -tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo -tidySkolemInfo env (DerivSkol ty) = DerivSkol (tidyType env ty) -tidySkolemInfo env (SigSkol cx ty tv_prs) = tidySigSkol env cx ty tv_prs -tidySkolemInfo env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids) -tidySkolemInfo env (UnifyForAllSkol ty) = UnifyForAllSkol (tidyType env ty) -tidySkolemInfo _ info = info - -tidySigSkol :: TidyEnv -> UserTypeCtxt - -> TcType -> [(Name,TcTyVar)] -> SkolemInfo --- We need to take special care when tidying SigSkol --- See Note [SigSkol SkolemInfo] in "GHC.Tc.Types.Origin" -tidySigSkol env cx ty tv_prs - = SigSkol cx (tidy_ty env ty) tv_prs' - where - tv_prs' = mapSnd (tidyTyCoVarOcc env) tv_prs - inst_env = mkNameEnv tv_prs' - - tidy_ty env (ForAllTy (Bndr tv vis) ty) - = ForAllTy (Bndr tv' vis) (tidy_ty env' ty) - where - (env', tv') = tidy_tv_bndr env tv - - tidy_ty env ty@(FunTy InvisArg w arg res) -- Look under c => t - = ty { ft_mult = tidy_ty env w, - ft_arg = tidyType env arg, - ft_res = tidy_ty env res } - - tidy_ty env ty = tidyType env ty - - tidy_tv_bndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) - tidy_tv_bndr env@(occ_env, subst) tv - | Just tv' <- lookupNameEnv inst_env (tyVarName tv) - = ((occ_env, extendVarEnv subst tv tv'), tv') - - | otherwise - = tidyVarBndr env tv ------------------------------------------------------------------------- {- @@ -2700,7 +2700,7 @@ naughtyQuantification :: TcType -- original type user wanted to quantify naughtyQuantification orig_ty tv escapees = do { orig_ty1 <- zonkTcType orig_ty -- in case it's not zonked - ; escapees' <- mapM zonkTcTyVarToTyVar $ + ; escapees' <- zonkTcTyVarsToTcTyVars $ nonDetEltsUniqSet escapees -- we'll just be printing, so no harmful non-determinism diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs index a4dfead21b..363ece84b2 100644 --- a/compiler/GHC/Tc/Utils/TcType.hs +++ b/compiler/GHC/Tc/Utils/TcType.hs @@ -25,7 +25,7 @@ module GHC.Tc.Utils.TcType ( TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet, TcKind, TcCoVar, TcTyCoVar, TcTyVarBinder, TcInvisTVBinder, TcReqTVBinder, - TcTyCon, KnotTied, + TcTyCon, MonoTcTyCon, PolyTcTyCon, TcTyConBinder, KnotTied, ExpType(..), InferResult(..), ExpSigmaType, ExpRhoType, mkCheckExpType, @@ -35,11 +35,10 @@ module GHC.Tc.Utils.TcType ( TcLevel(..), topTcLevel, pushTcLevel, isTopTcLevel, strictlyDeeperThan, deeperThanOrSame, sameDepthAs, tcTypeLevel, tcTyVarLevel, maxTcLevel, - promoteSkolem, promoteSkolemX, promoteSkolemsX, -------------------------------- -- MetaDetails - TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv, - MetaDetails(Flexi, Indirect), MetaInfo(..), + TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTvUnk, + MetaDetails(Flexi, Indirect), MetaInfo(..), skolemSkolInfo, isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isTyVarTy, tcIsTcTyVar, isTyVarTyVar, isOverlappableTyVar, isTyConableTyVar, isAmbiguousTyVar, isCycleBreakerTyVar, metaTyVarRef, metaTyVarInfo, @@ -230,10 +229,10 @@ import GHC.Utils.Panic.Plain import GHC.Utils.Error( Validity'(..), Validity ) import qualified GHC.LanguageExtensions as LangExt -import Data.List ( mapAccumL ) --- import Data.Functor.Identity( Identity(..) ) import Data.IORef import Data.List.NonEmpty( NonEmpty(..) ) +import {-# SOURCE #-} GHC.Tc.Types.Origin ( unkSkol, SkolemInfo ) + {- ************************************************************************ @@ -341,7 +340,12 @@ type TcTyCoVar = Var -- Either a TcTyVar or a CoVar type TcTyVarBinder = TyVarBinder type TcInvisTVBinder = InvisTVBinder type TcReqTVBinder = ReqTVBinder -type TcTyCon = TyCon -- these can be the TcTyCon constructor + +-- See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] +type TcTyCon = TyCon +type MonoTcTyCon = TcTyCon +type PolyTcTyCon = TcTyCon +type TcTyConBinder = TyConBinder -- With skolem TcTyVars -- These types do not have boxy type variables in them type TcPredType = PredType @@ -355,6 +359,51 @@ type TcTyCoVarSet = TyCoVarSet type TcDTyVarSet = DTyVarSet type TcDTyCoVarSet = DTyCoVarSet +{- Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See Note [How TcTyCons work] in GHC.Tc.TyCl + +Invariants: + +* TcTyCon: a TyCon built with the TcTyCon constructor + +* TcTyConBinder: a TyConBinder with a TcTyVar inside (not a TyVar) + +* TcTyCons contain TcTyVars + +* MonoTcTyCon: + - Flag tcTyConIsPoly = False + + - tyConScopedTyVars is important; maps a Name to a TyVarTv unification variable + The order is important: Specified then Required variables. E.g. in + data T a (b :: k) = ... + the order will be [k, a, b]. + + NB: There are no Inferred binders in tyConScopedTyVars; 'a' may + also be poly-kinded, but that kind variable will be added by + generaliseTcTyCon, in the passage to a PolyTcTyCon. + + - tyConBinders are irrelevant; we just use tcTyConScopedTyVars + Well not /quite/ irrelevant: its length gives the number of Required binders, + and so allows up to distinguish between the Specified and Required elements of + tyConScopedTyVars. + +* PolyTcTyCon: + - Flag tcTyConIsPoly = True; this is used only to short-cut zonking + + - tyConBinders are still TcTyConBinders, but they are /skolem/ TcTyVars, + with fixed kinds: no unification variables here + + tyConBinders includes the Inferred binders if any + + tyConBinders uses the Names from the original, renamed program. + + - tcTyConScopedTyVars is irrelevant: just use (binderVars tyConBinders) + All the types have been swizzled back to use the original Names + See Note [tyConBinders and lexical scoping] in GHC.Core.TyCon + +-} + {- ********************************************************************* * * ExpType: an "expected type" in the type checker @@ -480,6 +529,7 @@ we would need to enforce the separation. -- See Note [TyVars and TcTyVars] data TcTyVarDetails = SkolemTv -- A skolem + SkolemInfo TcLevel -- Level of the implication that binds it -- See GHC.Tc.Utils.Unify Note [Deeper level on the left] for -- how this level number is used @@ -494,12 +544,8 @@ data TcTyVarDetails , mtv_ref :: IORef MetaDetails , mtv_tclvl :: TcLevel } -- See Note [TcLevel invariants] -vanillaSkolemTv, superSkolemTv :: TcTyVarDetails --- See Note [Binding when looking up instances] in GHC.Core.InstEnv -vanillaSkolemTv = SkolemTv topTcLevel False -- Might be instantiated -superSkolemTv = SkolemTv topTcLevel True -- Treat this as a completely distinct type - -- The choice of level number here is a bit dodgy, but - -- topTcLevel works in the places that vanillaSkolemTv is used +vanillaSkolemTvUnk :: HasCallStack => TcTyVarDetails +vanillaSkolemTvUnk = SkolemTv unkSkol topTcLevel False instance Outputable TcTyVarDetails where ppr = pprTcTyVarDetails @@ -507,8 +553,8 @@ instance Outputable TcTyVarDetails where pprTcTyVarDetails :: TcTyVarDetails -> SDoc -- For debugging pprTcTyVarDetails (RuntimeUnk {}) = text "rt" -pprTcTyVarDetails (SkolemTv lvl True) = text "ssk" <> colon <> ppr lvl -pprTcTyVarDetails (SkolemTv lvl False) = text "sk" <> colon <> ppr lvl +pprTcTyVarDetails (SkolemTv _sk lvl True) = text "ssk" <> colon <> ppr lvl +pprTcTyVarDetails (SkolemTv _sk lvl False) = text "sk" <> colon <> ppr lvl pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_tclvl = tclvl }) = ppr info <> colon <> ppr tclvl @@ -678,7 +724,7 @@ tcTyVarLevel :: TcTyVar -> TcLevel tcTyVarLevel tv = case tcTyVarDetails tv of MetaTv { mtv_tclvl = tv_lvl } -> tv_lvl - SkolemTv tv_lvl _ -> tv_lvl + SkolemTv _ tv_lvl _ -> tv_lvl RuntimeUnk -> topTcLevel @@ -696,32 +742,6 @@ tcTypeLevel ty instance Outputable TcLevel where ppr (TcLevel us) = ppr us -promoteSkolem :: TcLevel -> TcTyVar -> TcTyVar -promoteSkolem tclvl skol - | tclvl < tcTyVarLevel skol - = assert (isTcTyVar skol && isSkolemTyVar skol ) - setTcTyVarDetails skol (SkolemTv tclvl (isOverlappableTyVar skol)) - - | otherwise - = skol - --- | Change the TcLevel in a skolem, extending a substitution -promoteSkolemX :: TcLevel -> TCvSubst -> TcTyVar -> (TCvSubst, TcTyVar) -promoteSkolemX tclvl subst skol - = assert (isTcTyVar skol && isSkolemTyVar skol ) - (new_subst, new_skol) - where - new_skol - | tclvl < tcTyVarLevel skol - = setTcTyVarDetails (updateTyVarKind (substTy subst) skol) - (SkolemTv tclvl (isOverlappableTyVar skol)) - | otherwise - = updateTyVarKind (substTy subst) skol - new_subst = extendTvSubstWithClone subst skol new_skol - -promoteSkolemsX :: TcLevel -> TCvSubst -> [TcTyVar] -> (TCvSubst, [TcTyVar]) -promoteSkolemsX tclvl = mapAccumL (promoteSkolemX tclvl) - {- ********************************************************************* * * Finding type family instances @@ -1034,10 +1054,19 @@ isSkolemTyVar tv MetaTv {} -> False _other -> True +skolemSkolInfo :: TcTyVar -> SkolemInfo +skolemSkolInfo tv + = assert (isSkolemTyVar tv) $ + case tcTyVarDetails tv of + SkolemTv skol_info _ _ -> skol_info + RuntimeUnk -> panic "RuntimeUnk" + MetaTv {} -> panic "skolemSkolInfo" + + isOverlappableTyVar tv | isTyVar tv -- See Note [Coercion variables in free variable lists] = case tcTyVarDetails tv of - SkolemTv _ overlappable -> overlappable + SkolemTv _ _ overlappable -> overlappable _ -> False | otherwise = False diff --git a/compiler/GHC/Tc/Utils/TcType.hs-boot b/compiler/GHC/Tc/Utils/TcType.hs-boot index 2a7a34dc97..08602fa5ac 100644 --- a/compiler/GHC/Tc/Utils/TcType.hs-boot +++ b/compiler/GHC/Tc/Utils/TcType.hs-boot @@ -4,13 +4,15 @@ import GHC.Prelude ( Bool ) import {-# SOURCE #-} GHC.Types.Var ( TcTyVar ) import {-# SOURCE #-} GHC.Core.TyCo.Rep import GHC.Utils.Misc ( HasDebugCallStack ) +import GHC.Stack data MetaDetails data TcTyVarDetails pprTcTyVarDetails :: TcTyVarDetails -> SDoc -vanillaSkolemTv :: TcTyVarDetails +vanillaSkolemTvUnk :: HasCallStack => TcTyVarDetails isMetaTyVar :: TcTyVar -> Bool isTyConableTyVar :: TcTyVar -> Bool tcEqType :: HasDebugCallStack => Type -> Type -> Bool + diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs index aa1a753369..1ff6c044dc 100644 --- a/compiler/GHC/Tc/Utils/Unify.hs +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE RecursiveDo #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -863,12 +864,14 @@ tcSkolemise, tcSkolemiseScoped -- tcSkolemiseScoped and tcSkolemise tcSkolemiseScoped ctxt expected_ty thing_inside - = do { (wrap, tv_prs, given, rho_ty) <- topSkolemise expected_ty - ; let skol_tvs = map snd tv_prs - skol_info = SigSkol ctxt expected_ty tv_prs + = do { + ; rec { (wrap, tv_prs, given, rho_ty) <- topSkolemise skol_info expected_ty + ; let skol_tvs = map snd tv_prs + ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) + } ; (ev_binds, res) - <- checkConstraints skol_info skol_tvs given $ + <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $ tcExtendNameTyVarEnv tv_prs $ thing_inside rho_ty @@ -879,13 +882,15 @@ tcSkolemise ctxt expected_ty thing_inside = do { res <- thing_inside expected_ty ; return (idHsWrapper, res) } | otherwise - = do { (wrap, tv_prs, given, rho_ty) <- topSkolemise expected_ty + = do { + ; rec { (wrap, tv_prs, given, rho_ty) <- topSkolemise skol_info expected_ty - ; let skol_tvs = map snd tv_prs - skol_info = SigSkol ctxt expected_ty tv_prs + ; let skol_tvs = map snd tv_prs + ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) + } ; (ev_binds, result) - <- checkConstraints skol_info skol_tvs given $ + <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $ thing_inside rho_ty ; return (wrap <.> mkWpLet ev_binds, result) } @@ -902,7 +907,7 @@ tcSkolemiseET ctxt (Check ty) thing_inside = tcSkolemise ctxt ty $ \rho_ty -> thing_inside (mkCheckExpType rho_ty) -checkConstraints :: SkolemInfo +checkConstraints :: SkolemInfoAnon -> [TcTyVar] -- Skolems -> [EvVar] -- Given -> TcM result @@ -938,33 +943,39 @@ emitResidualTvConstraint :: SkolemInfo -> [TcTyVar] -> TcLevel -> WantedConstraints -> TcM () emitResidualTvConstraint skol_info skol_tvs tclvl wanted | not (isEmptyWC wanted) || - checkTelescopeSkol skol_info + checkTelescopeSkol skol_info_anon = -- checkTelescopeSkol: in this case, /always/ emit this implication -- even if 'wanted' is empty. We need the implication so that we check -- for a bad telescope. See Note [Skolem escape and forall-types] in -- GHC.Tc.Gen.HsType - do { implic <- buildTvImplication skol_info skol_tvs tclvl wanted + do { implic <- buildTvImplication skol_info_anon skol_tvs tclvl wanted ; emitImplication implic } | otherwise -- Empty 'wanted', emit nothing = return () + where + skol_info_anon = getSkolemInfo skol_info -buildTvImplication :: SkolemInfo -> [TcTyVar] +buildTvImplication :: SkolemInfoAnon -> [TcTyVar] -> TcLevel -> WantedConstraints -> TcM Implication buildTvImplication skol_info skol_tvs tclvl wanted - = do { ev_binds <- newNoTcEvBinds -- Used for equalities only, so all the constraints + = assertPpr (all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs) (ppr skol_tvs) $ + do { ev_binds <- newNoTcEvBinds -- Used for equalities only, so all the constraints -- are solved by filling in coercion holes, not -- by creating a value-level evidence binding ; implic <- newImplication - ; return (implic { ic_tclvl = tclvl - , ic_skols = skol_tvs - , ic_given_eqs = NoGivenEqs - , ic_wanted = wanted - , ic_binds = ev_binds - , ic_info = skol_info }) } + ; let implic' = implic { ic_tclvl = tclvl + , ic_skols = skol_tvs + , ic_given_eqs = NoGivenEqs + , ic_wanted = wanted + , ic_binds = ev_binds + , ic_info = skol_info } + + ; checkImplicationInvariants implic' + ; return implic' } -implicationNeeded :: SkolemInfo -> [TcTyVar] -> [EvVar] -> TcM Bool +implicationNeeded :: SkolemInfoAnon -> [TcTyVar] -> [EvVar] -> TcM Bool -- See Note [When to build an implication] implicationNeeded skol_info skol_tvs given | null skol_tvs @@ -984,7 +995,7 @@ implicationNeeded skol_info skol_tvs given | otherwise -- Non-empty skolems or givens = return True -- Definitely need an implication -alwaysBuildImplication :: SkolemInfo -> Bool +alwaysBuildImplication :: SkolemInfoAnon -> Bool -- See Note [When to build an implication] alwaysBuildImplication _ = False @@ -1001,7 +1012,7 @@ alwaysBuildImplication (FamInstSkol {}) = True alwaysBuildImplication _ = False -} -buildImplicationFor :: TcLevel -> SkolemInfo -> [TcTyVar] +buildImplicationFor :: TcLevel -> SkolemInfoAnon -> [TcTyVar] -> [EvVar] -> WantedConstraints -> TcM (Bag Implication, TcEvBinds) buildImplicationFor tclvl skol_info skol_tvs given wanted @@ -1026,6 +1037,7 @@ buildImplicationFor tclvl skol_info skol_tvs given wanted , ic_wanted = wanted , ic_binds = ev_binds_var , ic_info = skol_info } + ; checkImplicationInvariants implic' ; return (unitBag implic', TcEvBinds ev_binds_var) } diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index cc09edd778..805d6a483d 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -37,7 +37,7 @@ module GHC.Tc.Utils.Zonk ( zonkCoToCo, zonkEvBinds, zonkTcEvBinds, zonkTcMethInfoToMethInfoX, - lookupTyVarOcc + lookupTyVarX ) where import GHC.Prelude @@ -1776,7 +1776,7 @@ change. But in some cases it makes a HUGE difference: see test T9198 and #19668. So yes, it seems worth it. -} -zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType +zonkTyVarOcc :: ZonkEnv -> TcTyVar -> TcM Type zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi , ze_tv_env = tv_env , ze_meta_tv_env = mtv_env_ref }) tv @@ -1791,13 +1791,19 @@ zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi Just ty -> return ty Nothing -> do { mtv_details <- readTcRef ref ; zonk_meta ref mtv_details } } - | otherwise + | otherwise -- This should never really happen; + -- TyVars should not occur in the typechecker = lookup_in_tv_env where lookup_in_tv_env -- Look up in the env just as we do for Ids = case lookupVarEnv tv_env tv of - Nothing -> mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToTypeX env) tv + Nothing -> -- TyVar/SkolemTv/RuntimeUnk that isn't in the ZonkEnv + -- This can happen for RuntimeUnk variables (which + -- should stay as RuntimeUnk), but I think it should + -- not happen for SkolemTv. + mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToTypeX env) tv + Just tv' -> return (mkTyVarTy tv') zonk_meta ref Flexi @@ -1814,9 +1820,11 @@ zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi = do { updTcRef mtv_env_ref (\env -> extendVarEnv env tv ty) ; return ty } -lookupTyVarOcc :: ZonkEnv -> TcTyVar -> Maybe TyVar -lookupTyVarOcc (ZonkEnv { ze_tv_env = tv_env }) tv - = lookupVarEnv tv_env tv +lookupTyVarX :: ZonkEnv -> TcTyVar -> TyVar +lookupTyVarX (ZonkEnv { ze_tv_env = tv_env }) tv + = case lookupVarEnv tv_env tv of + Just tv -> tv + Nothing -> pprPanic "lookupTyVarOcc" (ppr tv $$ ppr tv_env) commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> TcM Type -- Only monadic so we can do tc-tracing diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs index b02271baf1..898a716980 100644 --- a/compiler/GHC/Tc/Validity.hs +++ b/compiler/GHC/Tc/Validity.hs @@ -363,7 +363,7 @@ checkValidType ctxt ty = case ctxt of DefaultDeclCtxt-> MustBeMonoType PatSigCtxt -> rank0 - RuleSigCtxt _ -> rank1 + RuleSigCtxt {} -> rank1 TySynCtxt _ -> rank0 ExprSigCtxt {} -> rank1 diff --git a/compiler/GHC/Types/Unique/Map.hs b/compiler/GHC/Types/Unique/Map.hs index 41765e1c7c..dfbc13fe4f 100644 --- a/compiler/GHC/Types/Unique/Map.hs +++ b/compiler/GHC/Types/Unique/Map.hs @@ -41,6 +41,7 @@ module GHC.Types.Unique.Map ( lookupWithDefaultUniqMap, anyUniqMap, allUniqMap, + nonDetEltsUniqMap -- Non-deterministic functions omitted ) where @@ -204,3 +205,6 @@ anyUniqMap f (UniqMap m) = anyUFM (f . snd) m allUniqMap :: (a -> Bool) -> UniqMap k a -> Bool allUniqMap f (UniqMap m) = allUFM (f . snd) m + +nonDetEltsUniqMap :: UniqMap k a -> [(k, a)] +nonDetEltsUniqMap (UniqMap m) = nonDetEltsUFM m diff --git a/compiler/GHC/Types/Var.hs b/compiler/GHC/Types/Var.hs index a60b7aa141..5ca0d00028 100644 --- a/compiler/GHC/Types/Var.hs +++ b/compiler/GHC/Types/Var.hs @@ -92,14 +92,13 @@ module GHC.Types.Var ( updateTyVarKindM, nonDetCmpVar - - ) where + ) where import GHC.Prelude import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, Kind, Mult ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr( pprKind ) -import {-# SOURCE #-} GHC.Tc.Utils.TcType( TcTyVarDetails, pprTcTyVarDetails, vanillaSkolemTv ) +import {-# SOURCE #-} GHC.Tc.Utils.TcType( TcTyVarDetails, pprTcTyVarDetails, vanillaSkolemTvUnk ) import {-# SOURCE #-} GHC.Types.Id.Info( IdDetails, IdInfo, coVarDetails, isCoVarDetails, vanillaIdInfo, pprIdDetails ) import {-# SOURCE #-} GHC.Builtin.Types ( manyDataConTy ) @@ -767,7 +766,8 @@ mkTcTyVar name kind details tcTyVarDetails :: TyVar -> TcTyVarDetails -- See Note [TcTyVars and TyVars in the typechecker] in GHC.Tc.Utils.TcType tcTyVarDetails (TcTyVar { tc_tv_details = details }) = details -tcTyVarDetails (TyVar {}) = vanillaSkolemTv +-- MP: This should never happen, but it does. Future work is to turn this into a panic. +tcTyVarDetails (TyVar {}) = vanillaSkolemTvUnk tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var <+> dcolon <+> pprKind (tyVarKind var)) setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar diff --git a/compiler/GHC/Utils/Panic.hs b/compiler/GHC/Utils/Panic.hs index 04e94b81d4..398a97524c 100644 --- a/compiler/GHC/Utils/Panic.hs +++ b/compiler/GHC/Utils/Panic.hs @@ -34,6 +34,7 @@ module GHC.Utils.Panic , cmdLineError , cmdLineErrorIO , callStackDoc + , prettyCallStackDoc , Exception.Exception(..) , showException @@ -289,9 +290,12 @@ withSignalHandlers act = do act `MC.finally` mayUninstallHandlers callStackDoc :: HasCallStack => SDoc -callStackDoc = +callStackDoc = prettyCallStackDoc callStack + +prettyCallStackDoc :: CallStack -> SDoc +prettyCallStackDoc cs = hang (text "Call stack:") - 4 (vcat $ map text $ lines (prettyCallStack callStack)) + 4 (vcat $ map text $ lines (prettyCallStack cs)) -- | Panic with an assertion failure, recording the given file and -- line number. Should typically be accessed with the ASSERT family of macros diff --git a/testsuite/tests/dependent/should_compile/T14066a.stderr b/testsuite/tests/dependent/should_compile/T14066a.stderr index 889d51b1cf..3f3c88a3e6 100644 --- a/testsuite/tests/dependent/should_compile/T14066a.stderr +++ b/testsuite/tests/dependent/should_compile/T14066a.stderr @@ -1,5 +1,5 @@ T14066a.hs:14:3: warning: Type family instance equation is overlapped: - forall {c} {d} {x :: c} {y :: d}. + forall {c} {x :: c} {d} {y :: d}. Bar x y = Bool -- Defined at T14066a.hs:14:3 diff --git a/testsuite/tests/dependent/should_fail/BadTelescope2.stderr b/testsuite/tests/dependent/should_fail/BadTelescope2.stderr index 3637dece24..f5aee5a1eb 100644 --- a/testsuite/tests/dependent/should_fail/BadTelescope2.stderr +++ b/testsuite/tests/dependent/should_fail/BadTelescope2.stderr @@ -1,5 +1,5 @@ -BadTelescope2.hs:9:8: error: +BadTelescope2.hs:9:15: error: • These kind and type variables: a k (b :: k) are out of dependency order. Perhaps try this ordering: k (a :: k) (b :: k) diff --git a/testsuite/tests/dependent/should_fail/BadTelescope5.stderr b/testsuite/tests/dependent/should_fail/BadTelescope5.stderr index 02daf9d742..b5e4ce9c3a 100644 --- a/testsuite/tests/dependent/should_fail/BadTelescope5.stderr +++ b/testsuite/tests/dependent/should_fail/BadTelescope5.stderr @@ -2,7 +2,7 @@ BadTelescope5.hs:10:81: error: • Expected kind ‘k’, but ‘d’ has kind ‘Proxy a’ ‘k’ is a rigid type variable bound by - an explicit forall a k (b :: k) (c :: Proxy b) (d :: Proxy a) + the type signature for ‘bar’ at BadTelescope5.hs:10:17 • In the second argument of ‘SameKind’, namely ‘d’ In the type signature: diff --git a/testsuite/tests/dependent/should_fail/T13780a.stderr b/testsuite/tests/dependent/should_fail/T13780a.stderr index 3e3fa61a9b..6cdcf96369 100644 --- a/testsuite/tests/dependent/should_fail/T13780a.stderr +++ b/testsuite/tests/dependent/should_fail/T13780a.stderr @@ -3,7 +3,7 @@ T13780a.hs:9:40: error: • Couldn't match kind ‘a’ with ‘Bool’ Expected kind ‘Foo a’, but ‘MkFoo’ has kind ‘Foo Bool’ ‘a’ is a rigid type variable bound by - the data constructor ‘SMkFoo’ + a family instance declaration at T13780a.hs:9:20-31 • In the second argument of ‘(~)’, namely ‘MkFoo’ In the definition of data constructor ‘SMkFoo’ diff --git a/testsuite/tests/dependent/should_fail/T14066.stderr b/testsuite/tests/dependent/should_fail/T14066.stderr index 240108c296..20c82215ed 100644 --- a/testsuite/tests/dependent/should_fail/T14066.stderr +++ b/testsuite/tests/dependent/should_fail/T14066.stderr @@ -4,7 +4,7 @@ T14066.hs:15:59: error: because kind variable ‘k’ would escape its scope This (rigid, skolem) kind variable is bound by an explicit forall k (b :: k) - at T14066.hs:15:29-59 + at T14066.hs:15:36-45 • In the second argument of ‘SameKind’, namely ‘b’ In the type signature: g :: forall k (b :: k). SameKind a b In the expression: diff --git a/testsuite/tests/dependent/should_fail/T16344a.stderr b/testsuite/tests/dependent/should_fail/T16344a.stderr index 8325bf4169..ab3b991293 100644 --- a/testsuite/tests/dependent/should_fail/T16344a.stderr +++ b/testsuite/tests/dependent/should_fail/T16344a.stderr @@ -2,7 +2,7 @@ T16344a.hs:11:36: error: • Expected a type, but ‘a’ has kind ‘ka’ ‘ka’ is a rigid type variable bound by - the data constructor ‘MkT2’ + the data type declaration for ‘T2’ at T16344a.hs:11:9-10 • In the second argument of ‘T2’, namely ‘a’ In the type ‘(T2 Type a)’ diff --git a/testsuite/tests/dependent/should_fail/T16418.stderr b/testsuite/tests/dependent/should_fail/T16418.stderr index fa2263abd3..a286d77805 100644 --- a/testsuite/tests/dependent/should_fail/T16418.stderr +++ b/testsuite/tests/dependent/should_fail/T16418.stderr @@ -1,5 +1,5 @@ -T16418.hs:9:6: error: +T16418.hs:9:13: error: • These kind and type variables: a k (b :: k) are out of dependency order. Perhaps try this ordering: k (a :: k) (b :: k) diff --git a/testsuite/tests/dependent/should_fail/TypeSkolEscape.stderr b/testsuite/tests/dependent/should_fail/TypeSkolEscape.stderr index d642d6201c..b8ccbdfc9f 100644 --- a/testsuite/tests/dependent/should_fail/TypeSkolEscape.stderr +++ b/testsuite/tests/dependent/should_fail/TypeSkolEscape.stderr @@ -4,6 +4,6 @@ TypeSkolEscape.hs:9:52: error: because kind variable ‘v’ would escape its scope This (rigid, skolem) kind variable is bound by an explicit forall (v :: RuntimeRep) (a :: TYPE v) - at TypeSkolEscape.hs:9:12-52 + at TypeSkolEscape.hs:9:19-49 • In the type ‘forall (v :: RuntimeRep) (a :: TYPE v). a’ In the type declaration for ‘Bad’ diff --git a/testsuite/tests/deriving/should_compile/T14579.stderr b/testsuite/tests/deriving/should_compile/T14579.stderr index 31545c6de7..7ba5c6a2f0 100644 --- a/testsuite/tests/deriving/should_compile/T14579.stderr +++ b/testsuite/tests/deriving/should_compile/T14579.stderr @@ -22,22 +22,18 @@ Derived class instances: instance forall a (x :: Data.Proxy.Proxy a). GHC.Classes.Eq a => GHC.Classes.Eq (T14579.Wat x) where - (GHC.Classes.==) :: - T14579.Wat x[sk:1] -> T14579.Wat x[sk:1] -> GHC.Types.Bool - (GHC.Classes./=) :: - T14579.Wat x[sk:1] -> T14579.Wat x[sk:1] -> GHC.Types.Bool + (GHC.Classes.==) :: T14579.Wat x -> T14579.Wat x -> GHC.Types.Bool + (GHC.Classes./=) :: T14579.Wat x -> T14579.Wat x -> GHC.Types.Bool (GHC.Classes.==) = GHC.Prim.coerce - @(GHC.Maybe.Maybe a[sk:1] - -> GHC.Maybe.Maybe a[sk:1] -> GHC.Types.Bool) - @(T14579.Wat x[sk:1] -> T14579.Wat x[sk:1] -> GHC.Types.Bool) - ((GHC.Classes.==) @(GHC.Maybe.Maybe a[sk:1])) + @(GHC.Maybe.Maybe a -> GHC.Maybe.Maybe a -> GHC.Types.Bool) + @(T14579.Wat x -> T14579.Wat x -> GHC.Types.Bool) + ((GHC.Classes.==) @(GHC.Maybe.Maybe a)) (GHC.Classes./=) = GHC.Prim.coerce - @(GHC.Maybe.Maybe a[sk:1] - -> GHC.Maybe.Maybe a[sk:1] -> GHC.Types.Bool) - @(T14579.Wat x[sk:1] -> T14579.Wat x[sk:1] -> GHC.Types.Bool) - ((GHC.Classes./=) @(GHC.Maybe.Maybe a[sk:1])) + @(GHC.Maybe.Maybe a -> GHC.Maybe.Maybe a -> GHC.Types.Bool) + @(T14579.Wat x -> T14579.Wat x -> GHC.Types.Bool) + ((GHC.Classes./=) @(GHC.Maybe.Maybe a)) Derived type family instances: diff --git a/testsuite/tests/indexed-types/should_compile/T15852.stderr b/testsuite/tests/indexed-types/should_compile/T15852.stderr index 53fd60fd80..eb3d88f323 100644 --- a/testsuite/tests/indexed-types/should_compile/T15852.stderr +++ b/testsuite/tests/indexed-types/should_compile/T15852.stderr @@ -3,10 +3,10 @@ TYPE CONSTRUCTORS roles nominal nominal nominal COERCION AXIOMS axiom T15852.D:R:DFProxyProxy0 :: - forall k1 (j :: k1) k2 (c :: k2). - DF (Proxy c) = T15852.R:DFProxyProxy k1 j k2 c + forall k1 k2 (c :: k1) (j :: k2). + DF (Proxy c) = T15852.R:DFProxyProxy k1 k2 c j FAMILY INSTANCES - data instance forall {k1} {j :: k1} {k2} {c :: k2}. + data instance forall {k1} {k2} {c :: k1} {j :: k2}. DF (Proxy c) -- Defined at T15852.hs:10:15 Dependent modules: [] Dependent packages: [base-4.16.0.0] diff --git a/testsuite/tests/indexed-types/should_fail/T15870.stderr b/testsuite/tests/indexed-types/should_fail/T15870.stderr index 7968dc3dda..198ec75797 100644 --- a/testsuite/tests/indexed-types/should_fail/T15870.stderr +++ b/testsuite/tests/indexed-types/should_fail/T15870.stderr @@ -6,7 +6,7 @@ T15870.hs:32:34: error: a :: k Expected kind ‘Optic a’, but ‘g2’ has kind ‘Optic b’ ‘k’ is a rigid type variable bound by - a family instance declaration + the instance declaration at T15870.hs:(27,1)-(32,35) • In the second argument of ‘Get’, namely ‘g2’ In the type ‘Get a g2’ diff --git a/testsuite/tests/partial-sigs/should_compile/T12033.stderr b/testsuite/tests/partial-sigs/should_compile/T12033.stderr index 780fb9d41b..9f9fdd6a17 100644 --- a/testsuite/tests/partial-sigs/should_compile/T12033.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T12033.stderr @@ -1,15 +1,15 @@ T12033.hs:12:22: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘v -> t’ - Where: ‘t’ is a rigid type variable bound by + Where: ‘v’ is a rigid type variable bound by + the type signature for: + tripleStoreToRuleSet :: forall v. v -> v + at T12033.hs:6:1-30 + ‘t’ is a rigid type variable bound by the inferred types of makeTuple :: v -> t makeExpression :: v -> t at T12033.hs:(11,4)-(13,39) - ‘v’ is a rigid type variable bound by - the type signature for: - tripleStoreToRuleSet :: forall v. v -> v - at T12033.hs:6:1-30 • In the type signature: makeExpression :: _ In an equation for ‘tripleStoreToRuleSet’: tripleStoreToRuleSet getAtom diff --git a/testsuite/tests/partial-sigs/should_fail/T14040a.stderr b/testsuite/tests/partial-sigs/should_fail/T14040a.stderr index 8e2d02e9b3..18f8439a7f 100644 --- a/testsuite/tests/partial-sigs/should_fail/T14040a.stderr +++ b/testsuite/tests/partial-sigs/should_fail/T14040a.stderr @@ -7,7 +7,7 @@ T14040a.hs:26:46: error: This (rigid, skolem) kind variable is bound by an explicit forall (z :: Type) (x :: z) (xs :: WeirdList (WeirdList z)) - at T14040a.hs:(25,19)-(27,41) + at T14040a.hs:25:26-77 • In the second argument of ‘p’, namely ‘xs’ In the type ‘Sing wl -> (forall (y :: Type). p _ WeirdNil) @@ -37,7 +37,7 @@ T14040a.hs:27:27: error: This (rigid, skolem) kind variable is bound by an explicit forall (z :: Type) (x :: z) (xs :: WeirdList (WeirdList z)) - at T14040a.hs:(25,19)-(27,41) + at T14040a.hs:25:26-77 • In the second argument of ‘p’, namely ‘(WeirdCons x xs)’ In the type ‘Sing wl -> (forall (y :: Type). p _ WeirdNil) diff --git a/testsuite/tests/patsyn/should_fail/T15694.stderr b/testsuite/tests/patsyn/should_fail/T15694.stderr index 2c3421321c..e3827b28c1 100644 --- a/testsuite/tests/patsyn/should_fail/T15694.stderr +++ b/testsuite/tests/patsyn/should_fail/T15694.stderr @@ -2,7 +2,6 @@ T15694.hs:23:35: error: • Expected kind ‘k1 -> k0’, but ‘f a1’ has kind ‘ks’ ‘ks’ is a rigid type variable bound by - an explicit forall ks k (f :: k -> ks) (a1 :: k) (ctx :: Ctx ks) - (ks1 :: Type) k1 (a2 :: k1) (ctx1 :: Ctx ks1) a3 + the type signature for ‘ASSO’ at T15694.hs:19:30-31 • In the first argument of ‘(~~)’, namely ‘f a1 a2’ diff --git a/testsuite/tests/polykinds/T11142.stderr b/testsuite/tests/polykinds/T11142.stderr index f96278a5e7..e061d41bce 100644 --- a/testsuite/tests/polykinds/T11142.stderr +++ b/testsuite/tests/polykinds/T11142.stderr @@ -4,7 +4,7 @@ T11142.hs:9:49: error: because kind variable ‘k’ would escape its scope This (rigid, skolem) kind variable is bound by an explicit forall k (a :: k) - at T11142.hs:9:19-49 + at T11142.hs:9:26-35 • In the second argument of ‘SameKind’, namely ‘b’ In the type signature: foo :: forall b. (forall k (a :: k). SameKind a b) -> () diff --git a/testsuite/tests/polykinds/T15787.stderr b/testsuite/tests/polykinds/T15787.stderr index 4ab01d58fc..c2c50af86a 100644 --- a/testsuite/tests/polykinds/T15787.stderr +++ b/testsuite/tests/polykinds/T15787.stderr @@ -2,7 +2,7 @@ T15787.hs:16:14: error: • Expected a type, but ‘k’ has kind ‘ob1’ ‘ob1’ is a rigid type variable bound by - the data constructor ‘Kl’ + the type signature for ‘Kl’ at T15787.hs:16:3-43 • In the type ‘k’ In the definition of data constructor ‘Kl’ diff --git a/testsuite/tests/polykinds/T16221a.stderr b/testsuite/tests/polykinds/T16221a.stderr index 5945369a6c..06fb5e0af1 100644 --- a/testsuite/tests/polykinds/T16221a.stderr +++ b/testsuite/tests/polykinds/T16221a.stderr @@ -1,11 +1,11 @@ T16221a.hs:6:49: error: - • Expected kind ‘k’, but ‘b’ has kind ‘k2’ - ‘k2’ is a rigid type variable bound by + • Expected kind ‘k’, but ‘b’ has kind ‘k1’ + ‘k1’ is a rigid type variable bound by an explicit forall k (b :: k) at T16221a.hs:6:20 ‘k’ is a rigid type variable bound by - the data constructor ‘MkT2’ + the data type declaration for ‘T2’ at T16221a.hs:6:20 • In the second argument of ‘SameKind’, namely ‘b’ In the type ‘(SameKind a b)’ diff --git a/testsuite/tests/polykinds/T16245a.stderr b/testsuite/tests/polykinds/T16245a.stderr index 0023432858..c47e088434 100644 --- a/testsuite/tests/polykinds/T16245a.stderr +++ b/testsuite/tests/polykinds/T16245a.stderr @@ -2,10 +2,10 @@ T16245a.hs:11:66: error: • Expected kind ‘k’, but ‘b’ has kind ‘k1’ ‘k1’ is a rigid type variable bound by - the data constructor ‘MkT’ + the newtype declaration for ‘T’ at T16245a.hs:11:12 ‘k’ is a rigid type variable bound by - the data constructor ‘MkT’ + the newtype declaration for ‘T’ at T16245a.hs:11:1-67 • In the second argument of ‘SameKind’, namely ‘b’ In the type ‘(forall (b :: k). SameKind a b)’ diff --git a/testsuite/tests/polykinds/T16247.stderr b/testsuite/tests/polykinds/T16247.stderr index 34a1319996..dc637bee4a 100644 --- a/testsuite/tests/polykinds/T16247.stderr +++ b/testsuite/tests/polykinds/T16247.stderr @@ -1,5 +1,5 @@ -T16247.hs:9:13: error: +T16247.hs:9:20: error: • These kind and type variables: a k (b :: k) are out of dependency order. Perhaps try this ordering: k (a :: k) (b :: k) diff --git a/testsuite/tests/polykinds/T16247a.stderr b/testsuite/tests/polykinds/T16247a.stderr index ce75878f38..0205a74429 100644 --- a/testsuite/tests/polykinds/T16247a.stderr +++ b/testsuite/tests/polykinds/T16247a.stderr @@ -1,5 +1,5 @@ -T16247a.hs:21:21: error: +T16247a.hs:21:28: error: • These kind and type variables: p k are out of dependency order. Perhaps try this ordering: k (p :: k) diff --git a/testsuite/tests/polykinds/T16762.stderr b/testsuite/tests/polykinds/T16762.stderr index 6335fa4c50..6793e5220e 100644 --- a/testsuite/tests/polykinds/T16762.stderr +++ b/testsuite/tests/polykinds/T16762.stderr @@ -1,5 +1,5 @@ -T16762.hs:11:3: error: +T16762.hs:11:17: error: • These kind and type variables: a kx (b :: kx) are out of dependency order. Perhaps try this ordering: kx (a :: kx) (b :: kx) diff --git a/testsuite/tests/polykinds/T16762c.stderr b/testsuite/tests/polykinds/T16762c.stderr index 5be6fbb462..aa813f345b 100644 --- a/testsuite/tests/polykinds/T16762c.stderr +++ b/testsuite/tests/polykinds/T16762c.stderr @@ -1,5 +1,5 @@ -T16762c.hs:10:10: error: +T16762c.hs:10:17: error: • These kind and type variables: a k (b :: k) are out of dependency order. Perhaps try this ordering: k (a :: k) (b :: k) diff --git a/testsuite/tests/polykinds/T16902.stderr b/testsuite/tests/polykinds/T16902.stderr index 69022b3a1a..2472fdcb34 100644 --- a/testsuite/tests/polykinds/T16902.stderr +++ b/testsuite/tests/polykinds/T16902.stderr @@ -2,7 +2,7 @@ T16902.hs:12:10: error: • Expected a type, but found something with kind ‘a’ ‘a’ is a rigid type variable bound by - the data constructor ‘MkF’ + the type signature for ‘MkF’ at T16902.hs:12:3-12 • In the type ‘F a’ In the definition of data constructor ‘MkF’ diff --git a/testsuite/tests/polykinds/T17963.stderr b/testsuite/tests/polykinds/T17963.stderr index aa0e4d0d3e..94f730cb30 100644 --- a/testsuite/tests/polykinds/T17963.stderr +++ b/testsuite/tests/polykinds/T17963.stderr @@ -6,7 +6,7 @@ T17963.hs:15:23: error: ob :: TYPE rep ‘rep’ is a rigid type variable bound by the class declaration for ‘Category'’ - at T17963.hs:13:27-29 + at T17963.hs:14:18-35 • In the first argument of ‘cat’, namely ‘a’ In the type signature: id' :: forall a. cat a a In the class declaration for ‘Category'’ diff --git a/testsuite/tests/polykinds/T18451a.stderr b/testsuite/tests/polykinds/T18451a.stderr index fbfd3ce288..b7ad0ee898 100644 --- a/testsuite/tests/polykinds/T18451a.stderr +++ b/testsuite/tests/polykinds/T18451a.stderr @@ -1,5 +1,5 @@ -T18451a.hs:10:8: error: +T18451a.hs:10:15: error: • These kind and type variables: a b (c :: Const Type b) are out of dependency order. Perhaps try this ordering: (b :: k) (a :: Const (*) b) (c :: Const (*) b) diff --git a/testsuite/tests/polykinds/T18451b.stderr b/testsuite/tests/polykinds/T18451b.stderr index d12d9b382a..458d39105e 100644 --- a/testsuite/tests/polykinds/T18451b.stderr +++ b/testsuite/tests/polykinds/T18451b.stderr @@ -1,5 +1,5 @@ -T18451b.hs:10:8: error: +T18451b.hs:10:15: error: • These kind and type variables: a b (c :: Const Type b) are out of dependency order. Perhaps try this ordering: (b :: k) (a :: Const (*) b) (c :: Const (*) b) diff --git a/testsuite/tests/polykinds/TyVarTvKinds3.stderr b/testsuite/tests/polykinds/TyVarTvKinds3.stderr index 872fe96684..a267c3dc82 100644 --- a/testsuite/tests/polykinds/TyVarTvKinds3.stderr +++ b/testsuite/tests/polykinds/TyVarTvKinds3.stderr @@ -2,10 +2,10 @@ TyVarTvKinds3.hs:9:62: error: • Expected kind ‘k1’, but ‘b’ has kind ‘k2’ ‘k2’ is a rigid type variable bound by - an explicit forall k1 k2 (a :: k1) (b :: k2) + the type signature for ‘MkBad’ at TyVarTvKinds3.hs:9:22-23 ‘k1’ is a rigid type variable bound by - an explicit forall k1 k2 (a :: k1) (b :: k2) + the type signature for ‘MkBad’ at TyVarTvKinds3.hs:9:19-20 • In the second argument of ‘SameKind’, namely ‘b’ In the first argument of ‘Bad’, namely ‘(SameKind a b)’ diff --git a/testsuite/tests/saks/should_compile/saks023.stdout b/testsuite/tests/saks/should_compile/saks023.stdout index 051268aa78..c779a9c938 100644 --- a/testsuite/tests/saks/should_compile/saks023.stdout +++ b/testsuite/tests/saks/should_compile/saks023.stdout @@ -1 +1 @@ -T :: forall x -> Type +T :: forall a -> Type diff --git a/testsuite/tests/saks/should_compile/saks034.stdout b/testsuite/tests/saks/should_compile/saks034.stdout index 9877dc5d39..48ccab7e25 100644 --- a/testsuite/tests/saks/should_compile/saks034.stdout +++ b/testsuite/tests/saks/should_compile/saks034.stdout @@ -1,2 +1,2 @@ -C :: j -> Constraint -T :: forall j -> j -> Type +C :: k -> Constraint +T :: forall k -> k -> Type diff --git a/testsuite/tests/saks/should_compile/saks035.stdout b/testsuite/tests/saks/should_compile/saks035.stdout index e52a24b69a..37328e26a0 100644 --- a/testsuite/tests/saks/should_compile/saks035.stdout +++ b/testsuite/tests/saks/should_compile/saks035.stdout @@ -1,2 +1,2 @@ -C :: forall {k} (i :: k). Proxy i -> Constraint +C :: forall {k} (z :: k). Proxy z -> Constraint F :: k -> Type diff --git a/testsuite/tests/saks/should_fail/T16758.stderr b/testsuite/tests/saks/should_fail/T16758.stderr index f74241a706..066a4f106a 100644 --- a/testsuite/tests/saks/should_fail/T16758.stderr +++ b/testsuite/tests/saks/should_fail/T16758.stderr @@ -3,6 +3,6 @@ T16758.hs:14:8: error: • Couldn't match expected kind ‘Int’ with actual kind ‘a’ ‘a’ is a rigid type variable bound by the class declaration for ‘C’ - at T16758.hs:12:19 + at T16758.hs:13:9 • In the type signature: f :: C a => a -> Int In the class declaration for ‘C’ diff --git a/testsuite/tests/saks/should_fail/T20916.hs b/testsuite/tests/saks/should_fail/T20916.hs new file mode 100644 index 0000000000..f62aa4caab --- /dev/null +++ b/testsuite/tests/saks/should_fail/T20916.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE CUSKs, EmptyDataDecls, PolyKinds, KindSignatures, StandaloneKindSignatures #-} + +module T20916 where + +import Data.Kind + +type T3 :: k -> k -> Type +data T3 (a :: p) (b :: q) = MkT +-- Should fail because p and q are bound the same kind variable diff --git a/testsuite/tests/saks/should_fail/T20916.stderr b/testsuite/tests/saks/should_fail/T20916.stderr new file mode 100644 index 0000000000..aeef4ca438 --- /dev/null +++ b/testsuite/tests/saks/should_fail/T20916.stderr @@ -0,0 +1,4 @@ + +T20916.hs:8:10: error: + • Different names for the same type variable: ‘p’ and ‘q’ + • In the data type declaration for ‘T3’ diff --git a/testsuite/tests/saks/should_fail/all.T b/testsuite/tests/saks/should_fail/all.T index 7e2194a21f..98345aa2ca 100644 --- a/testsuite/tests/saks/should_fail/all.T +++ b/testsuite/tests/saks/should_fail/all.T @@ -24,6 +24,7 @@ test('saks_fail022', normal, compile_fail, ['']) test('saks_fail023', normal, compile_fail, ['']) test('saks_fail024', normal, compile_fail, ['']) test('saks_fail025', normal, compile_fail, ['']) +test('saks_fail026', normal, compile_fail, ['']) test('T16722', normal, compile_fail, ['']) test('T16727a', normal, compile_fail, ['']) test('T16727b', normal, compile_fail, ['']) @@ -33,3 +34,4 @@ test('T16756b', normal, compile_fail, ['']) test('T16758', normal, compile_fail, ['']) test('T18863a', normal, compile_fail, ['']) test('T18863b', normal, compile_fail, ['']) +test('T20916', normal, compile_fail, ['']) diff --git a/testsuite/tests/saks/should_fail/saks_fail009.hs b/testsuite/tests/saks/should_fail/saks_fail009.hs index 317c0e7644..21394ada56 100644 --- a/testsuite/tests/saks/should_fail/saks_fail009.hs +++ b/testsuite/tests/saks/should_fail/saks_fail009.hs @@ -5,5 +5,5 @@ module SAKS_Fail009 where import Data.Kind (Type) -type T :: forall k -> k -> Type +type T :: forall j -> j -> Type data T (k :: Type -> Type) (a :: k) diff --git a/testsuite/tests/saks/should_fail/saks_fail009.stderr b/testsuite/tests/saks/should_fail/saks_fail009.stderr index 8ce43f6d5d..22b66b421b 100644 --- a/testsuite/tests/saks/should_fail/saks_fail009.stderr +++ b/testsuite/tests/saks/should_fail/saks_fail009.stderr @@ -1,4 +1,5 @@ saks_fail009.hs:9:1: error: - • Expected kind ‘* -> *’, but ‘k’ has kind ‘*’ + • Expecting one more argument to ‘k’ + Expected a type, but ‘k’ has kind ‘* -> *’ • In the data type declaration for ‘T’ diff --git a/testsuite/tests/saks/should_fail/saks_fail019.hs b/testsuite/tests/saks/should_fail/saks_fail019.hs index 51cdd54ca2..ddd20d099c 100644 --- a/testsuite/tests/saks/should_fail/saks_fail019.hs +++ b/testsuite/tests/saks/should_fail/saks_fail019.hs @@ -6,6 +6,6 @@ module SAKS_Fail019 where import Data.Kind (Type) type T :: Type -> Type -> Type -data T a :: a -> Type +data T x :: x -> Type -- Should not panic with: - -- GHC internal error: ‘a’ is not in scope during type checking, but it passed the renamer + -- GHC internal error: ‘x’ is not in scope during type checking, but it passed the renamer diff --git a/testsuite/tests/saks/should_fail/saks_fail019.stderr b/testsuite/tests/saks/should_fail/saks_fail019.stderr index b34a7e1905..a824ab118c 100644 --- a/testsuite/tests/saks/should_fail/saks_fail019.stderr +++ b/testsuite/tests/saks/should_fail/saks_fail019.stderr @@ -1,9 +1,9 @@ saks_fail019.hs:9:1: error: - • Couldn't match kind ‘a’ with ‘*’ - Expected: a -> * + • Couldn't match kind ‘x’ with ‘*’ + Expected: x -> * Actual: * -> * - ‘a’ is a rigid type variable bound by + ‘x’ is a rigid type variable bound by the data type declaration for ‘T’ at saks_fail019.hs:9:8 • In the data type declaration for ‘T’ diff --git a/testsuite/tests/saks/should_fail/saks_fail021.stderr b/testsuite/tests/saks/should_fail/saks_fail021.stderr index 6128aff165..fa20ccc826 100644 --- a/testsuite/tests/saks/should_fail/saks_fail021.stderr +++ b/testsuite/tests/saks/should_fail/saks_fail021.stderr @@ -1,4 +1,4 @@ saks_fail021.hs:10:1: error: - • Expected kind ‘k’, but ‘a’ has kind ‘*’ + • Expected a type, but ‘a’ has kind ‘k’ • In the class declaration for ‘C’ diff --git a/testsuite/tests/saks/should_fail/saks_fail022.stderr b/testsuite/tests/saks/should_fail/saks_fail022.stderr index e0cc222344..0591eced95 100644 --- a/testsuite/tests/saks/should_fail/saks_fail022.stderr +++ b/testsuite/tests/saks/should_fail/saks_fail022.stderr @@ -1,4 +1,4 @@ saks_fail022.hs:10:1: error: - • Expected kind ‘k’, but ‘a’ has kind ‘(x, y)’ + • Expected kind ‘(x, y)’, but ‘a’ has kind ‘k’ • In the class declaration for ‘C’ diff --git a/testsuite/tests/saks/should_fail/saks_fail023.stderr b/testsuite/tests/saks/should_fail/saks_fail023.stderr index 3af24c7abb..36144f6d9d 100644 --- a/testsuite/tests/saks/should_fail/saks_fail023.stderr +++ b/testsuite/tests/saks/should_fail/saks_fail023.stderr @@ -1,4 +1,4 @@ saks_fail023.hs:10:1: error: - • Expected kind ‘k’, but ‘a’ has kind ‘*’ + • Expected a type, but ‘a’ has kind ‘k’ • In the class declaration for ‘C’ diff --git a/testsuite/tests/saks/should_fail/saks_fail026.hs b/testsuite/tests/saks/should_fail/saks_fail026.hs new file mode 100644 index 0000000000..1d47a06d6e --- /dev/null +++ b/testsuite/tests/saks/should_fail/saks_fail026.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeFamilies #-} + +module SAKS_Fail026 where + +import Data.Kind (Type) + +type F3 :: forall kx. kx -> Type +type family F3 (b :: Type) where diff --git a/testsuite/tests/saks/should_fail/saks_fail026.stderr b/testsuite/tests/saks/should_fail/saks_fail026.stderr new file mode 100644 index 0000000000..ceeeaa01c7 --- /dev/null +++ b/testsuite/tests/saks/should_fail/saks_fail026.stderr @@ -0,0 +1,7 @@ + +saks_fail026.hs:8:1: error: + • Expected kind ‘kx’, but ‘b’ has kind ‘*’ + ‘kx’ is a rigid type variable bound by + the type family declaration for ‘F3’ + at saks_fail026.hs:7:19-20 + • In the type family declaration for ‘F3’ diff --git a/testsuite/tests/th/T10946.stderr b/testsuite/tests/th/T10946.stderr new file mode 100644 index 0000000000..a5b6ebe16c --- /dev/null +++ b/testsuite/tests/th/T10946.stderr @@ -0,0 +1,14 @@ + +T10946.hs:8:13: error: + • Found hole: _ :: a + Where: ‘a’ is a rigid type variable bound by + the type signature for: + m :: forall a. a -> a + at T10946.hs:7:1-11 + • In the Template Haskell quotation [|| _ ||] + In the expression: [|| _ ||] + In the Template Haskell splice $$([|| _ ||]) + • Relevant bindings include + x :: a (bound at T10946.hs:8:3) + m :: a -> a (bound at T10946.hs:8:1) + Valid hole fits include x :: a (bound at T10946.hs:8:3) diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 2f304ddc55..1e9ece046a 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -340,7 +340,7 @@ test('T10828a', normal, compile_fail, ['-v0']) test('T10828b', normal, compile_fail, ['-v0']) test('T10891', normal, compile, ['-v0']) test('T10945', normal, compile_fail, ['-v0']) -test('T10946', expect_broken(10946), compile, ['-v0']) +test('T10946', normal, compile_fail, ['-v0']) test('T10734', normal, compile_and_run, ['-v0']) test('T10819', [], multimod_compile, ['T10819.hs', '-v0 ' + config.ghc_th_way_flags]) diff --git a/testsuite/tests/typecheck/no_skolem_info/KcConDeclSkolem.hs b/testsuite/tests/typecheck/no_skolem_info/KcConDeclSkolem.hs new file mode 100644 index 0000000000..f8f1fbb130 --- /dev/null +++ b/testsuite/tests/typecheck/no_skolem_info/KcConDeclSkolem.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE GADTs, DataKinds, PolyKinds #-} + +module KcConDeclSkolem where + +import Data.Kind +import Data.Proxy + +data G a where + D :: Proxy (a :: k) -> Proxy (b :: k) -> G (a b) diff --git a/testsuite/tests/typecheck/no_skolem_info/KcConDeclSkolem.stderr b/testsuite/tests/typecheck/no_skolem_info/KcConDeclSkolem.stderr new file mode 100644 index 0000000000..ca5e590e72 --- /dev/null +++ b/testsuite/tests/typecheck/no_skolem_info/KcConDeclSkolem.stderr @@ -0,0 +1,6 @@ + +KcConDeclSkolem.hs:9:15: error: + • Expected kind ‘k’, but ‘a’ has kind ‘k -> k0’ + • In the first argument of ‘Proxy’, namely ‘(a :: k)’ + In the type ‘Proxy (a :: k)’ + In the definition of data constructor ‘D’ diff --git a/testsuite/tests/typecheck/no_skolem_info/KcConDeclSkolem2.hs b/testsuite/tests/typecheck/no_skolem_info/KcConDeclSkolem2.hs new file mode 100644 index 0000000000..cb0c7ddf79 --- /dev/null +++ b/testsuite/tests/typecheck/no_skolem_info/KcConDeclSkolem2.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE GADTs, DataKinds, PolyKinds #-} + +module KcConDeclSkolem2 where + +import Data.Kind +import Data.Proxy + +data D a = MkD (a a) diff --git a/testsuite/tests/typecheck/no_skolem_info/KcConDeclSkolem2.stderr b/testsuite/tests/typecheck/no_skolem_info/KcConDeclSkolem2.stderr new file mode 100644 index 0000000000..b9d4d6d95f --- /dev/null +++ b/testsuite/tests/typecheck/no_skolem_info/KcConDeclSkolem2.stderr @@ -0,0 +1,6 @@ + +KcConDeclSkolem2.hs:8:19: error: + • Expected kind ‘k0’, but ‘a’ has kind ‘k0 -> *’ + • In the first argument of ‘a’, namely ‘a’ + In the type ‘(a a)’ + In the definition of data constructor ‘MkD’ diff --git a/testsuite/tests/typecheck/no_skolem_info/T10946_sk.stderr b/testsuite/tests/typecheck/no_skolem_info/T10946_sk.stderr new file mode 100644 index 0000000000..d9ddf33946 --- /dev/null +++ b/testsuite/tests/typecheck/no_skolem_info/T10946_sk.stderr @@ -0,0 +1,14 @@ + +T10946_sk.hs:6:13: error: + • Found hole: _ :: a + Where: ‘a’ is a rigid type variable bound by + the type signature for: + m :: forall a. a -> a + at T10946_sk.hs:5:1-11 + • In the Template Haskell quotation [|| _ ||] + In the expression: [|| _ ||] + In the Template Haskell splice $$([|| _ ||]) + • Relevant bindings include + x :: a (bound at T10946_sk.hs:6:3) + m :: a -> a (bound at T10946_sk.hs:6:1) + Valid hole fits include x :: a (bound at T10946_sk.hs:6:3) diff --git a/testsuite/tests/typecheck/no_skolem_info/T13499.hs b/testsuite/tests/typecheck/no_skolem_info/T13499.hs new file mode 100644 index 0000000000..50d02f6e95 --- /dev/null +++ b/testsuite/tests/typecheck/no_skolem_info/T13499.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE StaticPointers #-} + +import Data.Typeable (Typeable) +import GHC.StaticPtr (StaticPtr) + +f :: Typeable a => StaticPtr (a -> a) +f = static (\a -> _) + +main :: IO () +main = return () diff --git a/testsuite/tests/typecheck/no_skolem_info/T13499.stderr b/testsuite/tests/typecheck/no_skolem_info/T13499.stderr new file mode 100644 index 0000000000..dbf5ba521b --- /dev/null +++ b/testsuite/tests/typecheck/no_skolem_info/T13499.stderr @@ -0,0 +1,14 @@ + +T13499.hs:7:19: error: + • Found hole: _ :: a + Where: ‘a’ is a rigid type variable bound by + the type signature for: + f :: forall a. Typeable a => StaticPtr (a -> a) + at T13499.hs:6:1-37 + • In the body of a static form: (\ a -> _) + In the expression: static (\ a -> _) + In an equation for ‘f’: f = static (\ a -> _) + • Relevant bindings include + a :: a (bound at T13499.hs:7:14) + f :: StaticPtr (a -> a) (bound at T13499.hs:7:1) + Valid hole fits include a :: a (bound at T13499.hs:7:14) diff --git a/testsuite/tests/typecheck/no_skolem_info/T14040.hs b/testsuite/tests/typecheck/no_skolem_info/T14040.hs new file mode 100644 index 0000000000..202c4600b2 --- /dev/null +++ b/testsuite/tests/typecheck/no_skolem_info/T14040.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +module T14040 where + +import Data.Kind + +data family Sing (a :: k) + +data WeirdList :: Type -> Type where + WeirdNil :: WeirdList a + WeirdCons :: a -> WeirdList (WeirdList a) -> WeirdList a + +data instance Sing (z :: WeirdList a) where + SWeirdNil :: Sing WeirdNil + SWeirdCons :: Sing w -> Sing wws -> Sing (WeirdCons w wws) + +elimWeirdList :: forall (a :: Type) (wl :: WeirdList a) + (p :: forall (x :: Type). x -> WeirdList x -> Type). + Sing wl + -> (forall (y :: Type). p _ WeirdNil) + -> (forall (z :: Type) (x :: z) (xs :: WeirdList (WeirdList z)). + Sing x -> Sing xs -> p _ xs + -> p _ (WeirdCons x xs)) + -> p _ wl +elimWeirdList SWeirdNil pWeirdNil _ = pWeirdNil +elimWeirdList (SWeirdCons (x :: Sing (x :: z)) + (xs :: Sing (xs :: WeirdList (WeirdList z)))) + pWeirdNil pWeirdCons + = pWeirdCons @z @x @xs x xs + (elimWeirdList @(WeirdList z) @xs @p xs pWeirdNil pWeirdCons) diff --git a/testsuite/tests/typecheck/no_skolem_info/T14040.stderr b/testsuite/tests/typecheck/no_skolem_info/T14040.stderr new file mode 100644 index 0000000000..fb4cc3f897 --- /dev/null +++ b/testsuite/tests/typecheck/no_skolem_info/T14040.stderr @@ -0,0 +1,60 @@ + +T14040.hs:26:46: error: + • Couldn't match kind ‘k1’ with ‘WeirdList z’ + Expected kind ‘WeirdList k1’, + but ‘xs’ has kind ‘WeirdList (WeirdList z)’ + • because kind variable ‘z’ would escape its scope + This (rigid, skolem) kind variable is bound by + an explicit forall (z :: Type) (x :: z) + (xs :: WeirdList (WeirdList z)) + at T14040.hs:25:26-77 + • In the second argument of ‘p’, namely ‘xs’ + In the type ‘Sing wl + -> (forall (y :: Type). p _ WeirdNil) + -> (forall (z :: Type) (x :: z) (xs :: WeirdList (WeirdList z)). + Sing x -> Sing xs -> p _ xs -> p _ (WeirdCons x xs)) + -> p _ wl’ + In the type signature: + elimWeirdList :: forall (a :: Type) + (wl :: WeirdList a) + (p :: forall (x :: Type). x -> WeirdList x -> Type). Sing wl + -> (forall (y :: Type). + p _ WeirdNil) + -> (forall (z :: Type) + (x :: z) + (xs :: WeirdList (WeirdList z)). + Sing x + -> Sing xs + -> p _ xs + -> p _ (WeirdCons x xs)) + -> p _ wl + +T14040.hs:27:27: error: + • Couldn't match kind ‘k0’ with ‘z’ + Expected kind ‘WeirdList k0’, + but ‘WeirdCons x xs’ has kind ‘WeirdList z’ + • because kind variable ‘z’ would escape its scope + This (rigid, skolem) kind variable is bound by + an explicit forall (z :: Type) (x :: z) + (xs :: WeirdList (WeirdList z)) + at T14040.hs:25:26-77 + • In the second argument of ‘p’, namely ‘(WeirdCons x xs)’ + In the type ‘Sing wl + -> (forall (y :: Type). p _ WeirdNil) + -> (forall (z :: Type) (x :: z) (xs :: WeirdList (WeirdList z)). + Sing x -> Sing xs -> p _ xs -> p _ (WeirdCons x xs)) + -> p _ wl’ + In the type signature: + elimWeirdList :: forall (a :: Type) + (wl :: WeirdList a) + (p :: forall (x :: Type). x -> WeirdList x -> Type). Sing wl + -> (forall (y :: Type). + p _ WeirdNil) + -> (forall (z :: Type) + (x :: z) + (xs :: WeirdList (WeirdList z)). + Sing x + -> Sing xs + -> p _ xs + -> p _ (WeirdCons x xs)) + -> p _ wl diff --git a/testsuite/tests/typecheck/no_skolem_info/T14040A.hs b/testsuite/tests/typecheck/no_skolem_info/T14040A.hs new file mode 100644 index 0000000000..183a894398 --- /dev/null +++ b/testsuite/tests/typecheck/no_skolem_info/T14040A.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeInType #-} +module Bug where + +import Data.Kind +import Data.Proxy + +newtype S (f :: k1 -> k2) + = MkS (forall t. Proxy t -> Proxy (f t)) + +foo :: forall (a :: Type) + (f :: forall (x :: a). Proxy x -> Type). + S f -> () +foo (MkS (sF :: _)) = () diff --git a/testsuite/tests/typecheck/no_skolem_info/T14040A.stderr b/testsuite/tests/typecheck/no_skolem_info/T14040A.stderr new file mode 100644 index 0000000000..fca04623b0 --- /dev/null +++ b/testsuite/tests/typecheck/no_skolem_info/T14040A.stderr @@ -0,0 +1,11 @@ + +T14040A.hs:12:8: error: + • Cannot generalise type; skolem ‘a’ would escape its scope + if I tried to quantify (x0 :: a) in this type: + forall a (f :: forall (x :: a). Proxy @{a} x -> *). + S @(Proxy @{a} x0) @(*) (f @x0) -> () + (Indeed, I sometimes struggle even printing this correctly, + due to its ill-scoped nature.) + • In the type signature: + foo :: forall (a :: Type) + (f :: forall (x :: a). Proxy x -> Type). S f -> () diff --git a/testsuite/tests/typecheck/no_skolem_info/T19482.stderr b/testsuite/tests/typecheck/no_skolem_info/T19482.stderr new file mode 100644 index 0000000000..0c4b35f505 --- /dev/null +++ b/testsuite/tests/typecheck/no_skolem_info/T19482.stderr @@ -0,0 +1,9 @@ + +T19482.hs:11:25: error: + • Expected kind ‘[r]’, but ‘s’ has kind ‘r’ + ‘r’ is a rigid type variable bound by + the instance declaration + at T19482.hs:10:10-35 + • In the type ‘s’ + In the expression: testF @r @s + In an equation for ‘bugList’: bugList = testF @r @s diff --git a/testsuite/tests/typecheck/no_skolem_info/T19752.stderr b/testsuite/tests/typecheck/no_skolem_info/T19752.stderr new file mode 100644 index 0000000000..9f0bc741da --- /dev/null +++ b/testsuite/tests/typecheck/no_skolem_info/T19752.stderr @@ -0,0 +1,22 @@ + +T19752.hs:12:10: error: + • Could not deduce (F b0 ~ a) + from the context: F b ~ a + bound by the type signature for: + f :: forall b. (F b ~ a) => a + at T19752.hs:12:10-23 + Expected: forall b. (F b ~ a) => a + Actual: forall b. (F b ~ a) => a + ‘a’ is a rigid type variable bound by + the type signature for: + g :: forall a. a + at T19752.hs:9:1-16 + • In the ambiguity check for ‘f’ + To defer the ambiguity check to use sites, enable AllowAmbiguousTypes + In the type signature: f :: (F b ~ a) => a + In an equation for ‘g’: + g = f + where + f :: (F b ~ a) => a + f = undefined + • Relevant bindings include g :: a (bound at T19752.hs:10:1) diff --git a/testsuite/tests/typecheck/no_skolem_info/T19760.stderr b/testsuite/tests/typecheck/no_skolem_info/T19760.stderr new file mode 100644 index 0000000000..cb5f7e2d16 --- /dev/null +++ b/testsuite/tests/typecheck/no_skolem_info/T19760.stderr @@ -0,0 +1,19 @@ + +T19760.hs:11:41: error: + • Couldn't match kind ‘a'’ with ‘a’ + Expected kind ‘Maybe a’, but ‘m'’ has kind ‘Maybe a'’ + ‘a'’ is a rigid type variable bound by + the type signature for ‘go’ + at T19760.hs:11:18-19 + ‘a’ is a rigid type variable bound by + the type signature for: + f :: forall a (p :: Maybe a -> *) (m :: Maybe a). p m + at T19760.hs:8:1-56 + • In the first argument of ‘p’, namely ‘m'’ + In the type signature: go :: forall a' (m' :: Maybe a'). p m' + In an equation for ‘f’: + f = go + where + go :: forall a' (m' :: Maybe a'). p m' + go = undefined + • Relevant bindings include f :: p m (bound at T19760.hs:9:1) diff --git a/testsuite/tests/typecheck/no_skolem_info/T20063.stderr b/testsuite/tests/typecheck/no_skolem_info/T20063.stderr new file mode 100644 index 0000000000..bb3b2c04b6 --- /dev/null +++ b/testsuite/tests/typecheck/no_skolem_info/T20063.stderr @@ -0,0 +1,27 @@ + +T20063.hs:25:21: error: + • Could not deduce (ctx4 ~ (ctx0 :*& l0)) + from the context: (ctx1 ~ 'Extend ctx7, ctx2 ~ 'Extend ctx8) + bound by a pattern with constructor: + U :: forall {k} (ctx1 :: Context) (ctx2 :: Context) (l :: k). + Rn ctx1 ctx2 -> Rn (ctx1 :*& l) (ctx2 :*& l), + in an equation for ‘rnRename’ + at T20063.hs:25:11-13 + Expected: Idx ctx4 + Actual: Idx (ctx0 :*& l0) + ‘ctx4’ is a rigid type variable bound by + the type signature for: + rnRename :: forall (ctx1 :: Context) (ctx2 :: Context) + (ctx3 :: Context) (ctx4 :: Context). + Rn ctx1 ctx2 -> Idx ctx3 -> Idx ctx4 + at T20063.hs:24:1-48 + • In the expression: T _ + In an equation for ‘rnRename’: rnRename (U _) _ = T _ + • Relevant bindings include + rnRename :: Rn ctx1 ctx2 -> Idx ctx3 -> Idx ctx4 + (bound at T20063.hs:25:1) + +T20063.hs:26:17: error: + • The constructor ‘T’ should have 1 argument, but has been given none + • In the pattern: T + In an equation for ‘rnRename’: rnRename _ T = undefined diff --git a/testsuite/tests/typecheck/no_skolem_info/T20232.hs b/testsuite/tests/typecheck/no_skolem_info/T20232.hs new file mode 100644 index 0000000000..b9268ebbfb --- /dev/null +++ b/testsuite/tests/typecheck/no_skolem_info/T20232.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE LinearTypes #-} +module T20232 where + +data C a = forall p. C (a %p -> a) + +f :: C a -> a %1 -> a +f b x = case b of C h -> h x diff --git a/testsuite/tests/typecheck/no_skolem_info/T20232.stderr b/testsuite/tests/typecheck/no_skolem_info/T20232.stderr new file mode 100644 index 0000000000..047db6bd96 --- /dev/null +++ b/testsuite/tests/typecheck/no_skolem_info/T20232.stderr @@ -0,0 +1,9 @@ + +T20232.hs:7:5: error: + • Couldn't match type ‘p’ with ‘'One’ + arising from multiplicity of ‘x’ + ‘p’ is a rigid type variable bound by + a pattern with constructor: C :: forall a. (a -> a) -> C a, + in a case alternative + at T20232.hs:7:19-21 + • In an equation for ‘f’: f b x = case b of C h -> h x diff --git a/testsuite/tests/typecheck/no_skolem_info/T20680.hs b/testsuite/tests/typecheck/no_skolem_info/T20680.hs new file mode 100644 index 0000000000..c7f5c6838a --- /dev/null +++ b/testsuite/tests/typecheck/no_skolem_info/T20680.hs @@ -0,0 +1,26 @@ +{-# language + DerivingStrategies + , DerivingVia + , GeneralisedNewtypeDeriving + , StandaloneDeriving +#-} + +module T20690 (main) where + +import GHC.Exts (TYPE) +import GHC.Generics (Rec1) +import Data.Kind (Type) + +main :: IO () +main = pure () + +class FunctorL (f :: Type -> TYPE r) where + fmapL :: (a -> b) -> (f a -> f b) + +newtype Base1 f a = Base1 { getBase1 :: f a } + deriving newtype (Functor) + +instance Functor f => FunctorL (Base1 f) where + fmapL = fmap + +deriving via (Base1 (Rec1 f)) instance FunctorL (Rec1 f) diff --git a/testsuite/tests/typecheck/no_skolem_info/T20680.stderr b/testsuite/tests/typecheck/no_skolem_info/T20680.stderr new file mode 100644 index 0000000000..c6a2d42bd4 --- /dev/null +++ b/testsuite/tests/typecheck/no_skolem_info/T20680.stderr @@ -0,0 +1,9 @@ + +T20680.hs:26:50: error: + • Couldn't match kind ‘k’ with ‘*’ + Expected kind ‘* -> *’, but ‘Rec1 f’ has kind ‘k -> *’ + ‘k’ is a rigid type variable bound by + the deriving clause for ‘Base1 (Rec1 f)’ + at T20680.hs:26:14-29 + • In the first argument of ‘FunctorL’, namely ‘(Rec1 f)’ + In the stand-alone deriving instance for ‘FunctorL (Rec1 f)’ diff --git a/testsuite/tests/typecheck/no_skolem_info/T20969.hs b/testsuite/tests/typecheck/no_skolem_info/T20969.hs new file mode 100644 index 0000000000..0746187b80 --- /dev/null +++ b/testsuite/tests/typecheck/no_skolem_info/T20969.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} +module T20969 where + +import Data.Sequence.Internal +import qualified Language.Haskell.TH.Syntax as TH + +import T20969A + +glumber :: forall a. Num a => a -> Seq a +glumber x = $$(sequenceCode (fromList [TH.liftTyped _ :: TH.Code TH.Q a, [||x||]])) + diff --git a/testsuite/tests/typecheck/no_skolem_info/T20969.stderr b/testsuite/tests/typecheck/no_skolem_info/T20969.stderr new file mode 100644 index 0000000000..2a5646b354 --- /dev/null +++ b/testsuite/tests/typecheck/no_skolem_info/T20969.stderr @@ -0,0 +1,23 @@ + +T20969.hs:10:40: error: + • No instance for (TH.Lift a) arising from a use of ‘TH.liftTyped’ + • In the expression: TH.liftTyped _ :: TH.Code TH.Q a + In the first argument of ‘fromList’, namely + ‘[TH.liftTyped _ :: TH.Code TH.Q a, [|| x ||]]’ + In the first argument of ‘sequenceCode’, namely + ‘(fromList [TH.liftTyped _ :: TH.Code TH.Q a, [|| x ||]])’ + +T20969.hs:10:53: error: + • Found hole: _ :: a + Where: ‘a’ is a rigid type variable bound by + the type signature for: + glumber :: forall a. Num a => a -> Seq a + at T20969.hs:9:1-40 + • In the first argument of ‘TH.liftTyped’, namely ‘_’ + In the expression: TH.liftTyped _ :: TH.Code TH.Q a + In the first argument of ‘fromList’, namely + ‘[TH.liftTyped _ :: TH.Code TH.Q a, [|| x ||]]’ + • Relevant bindings include + x :: a (bound at T20969.hs:10:9) + glumber :: a -> Seq a (bound at T20969.hs:10:1) + Valid hole fits include x :: a (bound at T20969.hs:10:9) diff --git a/testsuite/tests/typecheck/no_skolem_info/T20969A.hs b/testsuite/tests/typecheck/no_skolem_info/T20969A.hs new file mode 100644 index 0000000000..bd660c41be --- /dev/null +++ b/testsuite/tests/typecheck/no_skolem_info/T20969A.hs @@ -0,0 +1,32 @@ +{-# language TemplateHaskellQuotes #-} +module T20969A where +import Data.Sequence.Internal +import qualified Language.Haskell.TH.Syntax as TH + +class Functor t => SequenceCode t where + traverseCode :: TH.Quote m => (a -> TH.Code m b) -> t a -> TH.Code m (t b) + traverseCode f = sequenceCode . fmap f + sequenceCode :: TH.Quote m => t (TH.Code m a) -> TH.Code m (t a) + sequenceCode = traverseCode id + +instance SequenceCode Seq where + sequenceCode (Seq t) = [|| Seq $$(traverseCode sequenceCode t) ||] + +instance SequenceCode Elem where + sequenceCode (Elem t) = [|| Elem $$t ||] + +instance SequenceCode FingerTree where + sequenceCode (Deep s pr m sf) = + [|| Deep s $$(sequenceCode pr) $$(traverseCode sequenceCode m) $$(sequenceCode sf) ||] + sequenceCode (Single a) = [|| Single $$a ||] + sequenceCode EmptyT = [|| EmptyT ||] + +instance SequenceCode Digit where + sequenceCode (One a) = [|| One $$a ||] + sequenceCode (Two a b) = [|| Two $$a $$b ||] + sequenceCode (Three a b c) = [|| Three $$a $$b $$c ||] + sequenceCode (Four a b c d) = [|| Four $$a $$b $$c $$d ||] + +instance SequenceCode Node where + sequenceCode (Node2 s x y) = [|| Node2 s $$x $$y ||] + sequenceCode (Node3 s x y z) = [|| Node3 s $$x $$y $$z ||] diff --git a/testsuite/tests/typecheck/no_skolem_info/all.T b/testsuite/tests/typecheck/no_skolem_info/all.T index 80b4db6a1b..5c5defc90e 100644 --- a/testsuite/tests/typecheck/no_skolem_info/all.T +++ b/testsuite/tests/typecheck/no_skolem_info/all.T @@ -1,5 +1,13 @@ -test('T19752', [expect_broken(19752), grep_errmsg('of unknown origin')], compile_fail, ['']) -test('T20063', [expect_broken(20063), grep_errmsg('of unknown origin')], compile_fail, ['']) -test('T19760', [expect_broken(19760), grep_errmsg('of unknown origin')], compile_fail, ['']) -test('T19482', [expect_broken(19482), grep_errmsg('of unknown origin')], compile_fail, ['']) -test('T10946_sk', [expect_broken(10946), grep_errmsg('of unknown origin')], compile_fail, ['']) +test('T19752', normal, compile_fail, ['']) +test('T20063', normal, compile_fail, ['']) +test('T19760', normal, compile_fail, ['']) +test('T19482', normal, compile_fail, ['']) +test('T10946_sk', normal, compile_fail, ['']) +test('T20680', normal, compile_fail, ['']) +test('KcConDeclSkolem', normal, compile_fail, ['']) +test('KcConDeclSkolem2', normal, compile_fail, ['']) +test('T20232', normal, compile_fail, ['']) +test('T20969', normal, multimod_compile_fail, ['T20969', '-v0']) +test('T14040A', normal, compile_fail, ['']) +test('T14040', normal, compile_fail, ['']) +test('T13499', normal, compile_fail, ['']) diff --git a/testsuite/tests/typecheck/should_compile/T20732.hs b/testsuite/tests/typecheck/should_compile/T20732.hs new file mode 100644 index 0000000000..8f4d126607 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T20732.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PolyKinds, GADTs #-} + +module T20732 where + +data T (a :: k1) k2 (x :: k2) = MkT (S a k2 x) +data S (b :: k3) k4 (y :: k4) = MkS (T b k4 y) diff --git a/testsuite/tests/typecheck/should_compile/T9834.stderr b/testsuite/tests/typecheck/should_compile/T9834.stderr index 2c410de0f2..6ad8956ecc 100644 --- a/testsuite/tests/typecheck/should_compile/T9834.stderr +++ b/testsuite/tests/typecheck/should_compile/T9834.stderr @@ -33,7 +33,9 @@ T9834.hs:23:23: warning: [-Wdeferred-type-errors (in -Wdefault)] ‘a’ is a rigid type variable bound by the type signature for: afix :: forall a. - (forall (q :: * -> *). Applicative q => Comp p q a -> Comp p q a) + (forall (q1 :: * -> *). + Applicative q1 => + Comp p q1 a -> Comp p q1 a) -> p a at T9834.hs:22:11-74 • In the first argument of ‘wrapIdComp’, namely ‘f’ diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index b77d78e882..ef13910c41 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -809,3 +809,4 @@ test('T20873b', [extra_files(['T20873b_aux.hs'])], multimod_compile, ['T20873b', test('StaticPtrTypeFamily', normal, compile, ['']) test('T20946', normal, compile, ['']) test('T20996', normal, compile, ['']) +test('T20732', normal, compile, ['']) diff --git a/testsuite/tests/typecheck/should_fail/T14904a.stderr b/testsuite/tests/typecheck/should_fail/T14904a.stderr index 0de9206867..089e7bedeb 100644 --- a/testsuite/tests/typecheck/should_fail/T14904a.stderr +++ b/testsuite/tests/typecheck/should_fail/T14904a.stderr @@ -1,9 +1,9 @@ T14904a.hs:10:6: error: - • Expected kind ‘forall (a :: k). g a’, but ‘f’ has kind ‘k1’ - Cannot equate type variable ‘k1’ - with a kind involving polytypes: forall (a :: k). g a - ‘k1’ is a rigid type variable bound by + • Expected kind ‘forall (a :: k1). g a’, but ‘f’ has kind ‘k’ + Cannot equate type variable ‘k’ + with a kind involving polytypes: forall (a :: k1). g a + ‘k’ is a rigid type variable bound by a family instance declaration at T14904a.hs:10:3-30 • In the first argument of ‘F’, namely ‘(f :: forall a. g a)’ diff --git a/testsuite/tests/typecheck/should_fail/T15629.stderr b/testsuite/tests/typecheck/should_fail/T15629.stderr index c1d751bee2..aabc868844 100644 --- a/testsuite/tests/typecheck/should_fail/T15629.stderr +++ b/testsuite/tests/typecheck/should_fail/T15629.stderr @@ -6,21 +6,21 @@ T15629.hs:26:31: error: (F x ab) (F x z) -> *’ ‘z’ is a rigid type variable bound by - an explicit forall z ab + the type signature for ‘g’ at T15629.hs:26:17 ‘ab’ is a rigid type variable bound by - an explicit forall z ab + the type signature for ‘g’ at T15629.hs:26:19-20 • In the first argument of ‘Proxy’, namely ‘((Comp (F1Sym :: x ~> F x z) F2Sym) :: F x ab ~> F x ab)’ In the type signature: - g :: forall z ab. - Proxy ((Comp (F1Sym :: x ~> F x z) F2Sym) :: F x ab ~> F x ab) + g :: forall z ab. Proxy ((Comp (F1Sym :: x + ~> F x z) F2Sym) :: F x ab ~> F x ab) In an equation for ‘f’: f _ = () where g :: - forall z ab. - Proxy ((Comp (F1Sym :: x ~> F x z) F2Sym) :: F x ab ~> F x ab) + forall z ab. Proxy ((Comp (F1Sym :: x ~> F x z) F2Sym) :: F x ab + ~> F x ab) g = sg Proxy Proxy diff --git a/testsuite/tests/typecheck/should_fail/T15799.stderr b/testsuite/tests/typecheck/should_fail/T15799.stderr index 161cfe026a..af44e0a8ed 100644 --- a/testsuite/tests/typecheck/should_fail/T15799.stderr +++ b/testsuite/tests/typecheck/should_fail/T15799.stderr @@ -1,9 +1,5 @@ T15799.hs:46:62: error: - Expected a constraint, but ‘UnOp b <= a’ has kind ‘*’ - -T15799.hs:46:67: error: • Couldn't match kind ‘TypeLits.Natural’ with ‘Op Nat’ - Expected kind ‘Op (Op Nat)’, but ‘b’ has kind ‘Op Nat’ - • In the first argument of ‘UnOp’, namely ‘b’ - In the first argument of ‘(<=)’, namely ‘UnOp b’ + Expected kind ‘Op Nat’, but ‘UnOp b’ has kind ‘Nat’ + • In the first argument of ‘(<=)’, namely ‘UnOp b’ diff --git a/testsuite/tests/typecheck/should_fail/UnliftedNewtypesUnassociatedFamilyFail.stderr b/testsuite/tests/typecheck/should_fail/UnliftedNewtypesUnassociatedFamilyFail.stderr index df7865f8d4..86f65024af 100644 --- a/testsuite/tests/typecheck/should_fail/UnliftedNewtypesUnassociatedFamilyFail.stderr +++ b/testsuite/tests/typecheck/should_fail/UnliftedNewtypesUnassociatedFamilyFail.stderr @@ -3,7 +3,7 @@ UnliftedNewtypesUnassociatedFamilyFail.hs:21:30: error: • Couldn't match kind ‘t’ with ‘'IntRep’ Expected a type, but ‘Int#’ has kind ‘TYPE 'IntRep’ ‘t’ is a rigid type variable bound by - the data constructor ‘MkDF1a’ + a family instance declaration at UnliftedNewtypesUnassociatedFamilyFail.hs:21:1-33 • In the type ‘Int#’ In the definition of data constructor ‘MkDF1a’ @@ -13,7 +13,7 @@ UnliftedNewtypesUnassociatedFamilyFail.hs:22:30: error: • Couldn't match kind ‘t’ with ‘'WordRep’ Expected a type, but ‘Word#’ has kind ‘TYPE 'WordRep’ ‘t’ is a rigid type variable bound by - the data constructor ‘MkDF2a’ + a family instance declaration at UnliftedNewtypesUnassociatedFamilyFail.hs:22:1-34 • In the type ‘Word#’ In the definition of data constructor ‘MkDF2a’ @@ -25,7 +25,7 @@ UnliftedNewtypesUnassociatedFamilyFail.hs:23:30: error: but ‘(# Int#, Word# #)’ has kind ‘TYPE ('TupleRep '[ 'IntRep, 'WordRep])’ ‘t’ is a rigid type variable bound by - the data constructor ‘MkDF3a’ + a family instance declaration at UnliftedNewtypesUnassociatedFamilyFail.hs:23:1-46 • In the type ‘(# Int#, Word# #)’ In the definition of data constructor ‘MkDF3a’ |