diff options
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’ |