Commit 80dfcee6 authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by Marge Bot

Be more careful when naming TyCon binders

This patch fixes two rather gnarly test cases:
  * Trac #16342 (mutual recursion)
    See Note [Tricky scoping in generaliseTcTyCon]

  * Trac #16221 (shadowing)
    See Note [Unification variables need fresh Names]

The main changes are:

* Substantial reworking of TcTyClsDecls.generaliseTcTyCon
  This is the big change, and involves the rather tricky
  function TcHsSyn.zonkRecTyVarBndrs.

  See Note [Inferring kinds for type declarations] and
  Note [Tricky scoping in generaliseTcTyCon] for the details.

* bindExplicitTKBndrs_Tv and bindImplicitTKBndrs_Tv both now
  allocate /freshly-named/ unification variables. Indeed, more
  generally, unification variables are always fresh; see
  Note [Unification variables need fresh Names] in TcMType

* Clarify the role of tcTyConScopedTyVars.
  See Note [Scoped tyvars in a TcTyCon] in TyCon

As usual, this dragged in some more refactoring:

* Renamed TcMType.zonkTyCoVarBndr to zonkAndSkolemise

* I renamed checkValidTelescope to checkTyConTelescope;
  it's only used on TyCons, and indeed takes a TyCon as argument.

* I folded the slightly-mysterious reportFloatingKvs into
  checkTyConTelescope. (Previously all its calls immediately
  followed a call to checkTyConTelescope.)  It makes much more
  sense there.

* I inlined some called-once functions to simplify
  checkValidTyFamEqn. It's less spaghetti-like now.

* This patch also fixes Trac #16251.  I'm not quite sure why #16251
  went wrong in the first place, nor how this patch fixes it, but
  hey, it's good, and life is short.
parent e6ce1743
Pipeline #3105 passed with stages
in 317 minutes and 17 seconds
......@@ -208,7 +208,7 @@ get_scoped_tvs (dL->L _ signature)
| HsIB { hsib_ext = implicit_vars
, hsib_body = hs_ty } <- sig
, (explicit_vars, _) <- splitLHsForAllTy hs_ty
= implicit_vars ++ map hsLTyVarName explicit_vars
= implicit_vars ++ hsLTyVarNames explicit_vars
get_scoped_tvs_from_sig (XHsImplicitBndrs _)
= panic "get_scoped_tvs_from_sig"
......@@ -1037,7 +1037,7 @@ addHsTyVarBinds :: [LHsTyVarBndr GhcRn] -- the binders to be added
-> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) -- action in the ext env
-> DsM (Core (TH.Q a))
addHsTyVarBinds exp_tvs thing_inside
= do { fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs)
= do { fresh_exp_names <- mkGenSyms (hsLTyVarNames exp_tvs)
; term <- addBinds fresh_exp_names $
do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr
(exp_tvs `zip` fresh_exp_names)
......
......@@ -53,7 +53,7 @@ module HsTypes (
isHsKindedTyVar, hsTvbAllKinded, isLHsForAllTy,
hsScopedTvs, hsWcScopedTvs, dropWildCards,
hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames,
hsLTyVarName, hsLTyVarLocName, hsExplicitLTyVarNames,
hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsExplicitLTyVarNames,
splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe,
splitLHsPatSynTy,
splitLHsForAllTy, splitLHsForAllTyInvis,
......@@ -949,7 +949,7 @@ hsWcScopedTvs sig_ty
, hsib_body = sig_ty2 } <- sig_ty1
= case sig_ty2 of
L _ (HsForAllTy { hst_bndrs = tvs }) -> vars ++ nwcs ++
map hsLTyVarName tvs
hsLTyVarNames tvs
-- include kind variables only if the type is headed by forall
-- (this is consistent with GHC 7 behaviour)
_ -> nwcs
......@@ -962,7 +962,7 @@ hsScopedTvs sig_ty
| HsIB { hsib_ext = vars
, hsib_body = sig_ty2 } <- sig_ty
, L _ (HsForAllTy { hst_bndrs = tvs }) <- sig_ty2
= vars ++ map hsLTyVarName tvs
= vars ++ hsLTyVarNames tvs
| otherwise
= []
......@@ -988,6 +988,9 @@ hsTyVarName (XTyVarBndr{}) = panic "hsTyVarName"
hsLTyVarName :: LHsTyVarBndr pass -> IdP pass
hsLTyVarName = hsTyVarName . unLoc
hsLTyVarNames :: [LHsTyVarBndr pass] -> [IdP pass]
hsLTyVarNames = map hsLTyVarName
hsExplicitLTyVarNames :: LHsQTyVars pass -> [IdP pass]
-- Explicit variables only
hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs)
......@@ -996,7 +999,7 @@ hsAllLTyVarNames :: LHsQTyVars GhcRn -> [Name]
-- All variables
hsAllLTyVarNames (HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = kvs }
, hsq_explicit = tvs })
= kvs ++ map hsLTyVarName tvs
= kvs ++ hsLTyVarNames tvs
hsAllLTyVarNames (XLHsQTyVars _) = panic "hsAllLTyVarNames"
hsLTyVarLocName :: LHsTyVarBndr pass -> Located (IdP pass)
......@@ -1255,7 +1258,7 @@ splitLHsInstDeclTy :: LHsSigType GhcRn
splitLHsInstDeclTy (HsIB { hsib_ext = itkvs
, hsib_body = inst_ty })
| (tvs, cxt, body_ty) <- splitLHsSigmaTyInvis inst_ty
= (itkvs ++ map hsLTyVarName tvs, cxt, body_ty)
= (itkvs ++ hsLTyVarNames tvs, cxt, body_ty)
-- Return implicitly bound type and kind vars
-- For an instance decl, all of them are in scope
splitLHsInstDeclTy (XHsImplicitBndrs _) = panic "splitLHsInstDeclTy"
......
......@@ -776,8 +776,7 @@ rnFamInstEqn doc mb_cls rhs_kvars
inst_tvs = case mb_cls of
Nothing -> []
Just (_, inst_tvs) -> inst_tvs
all_nms = all_imp_var_names
++ map hsLTyVarName bndrs'
all_nms = all_imp_var_names ++ hsLTyVarNames bndrs'
; warnUnusedTypePatterns all_nms nms_used
; return ((bndrs', pats', payload'), rhs_fvs `plusFV` pat_fvs) }
......@@ -1809,7 +1808,7 @@ rnLDerivStrategy doc mds thing_inside
let HsIB { hsib_ext = via_imp_tvs
, hsib_body = via_body } = via_ty'
(via_exp_tv_bndrs, _, _) = splitLHsSigmaTy via_body
via_exp_tvs = map hsLTyVarName via_exp_tv_bndrs
via_exp_tvs = hsLTyVarNames via_exp_tv_bndrs
via_tvs = via_imp_tvs ++ via_exp_tvs
(thing, fvs2) <- extendTyVarEnvFVRn via_tvs $
thing_inside via_tvs (ppr via_ty')
......
......@@ -34,7 +34,7 @@ module TcHsSyn (
zonkTopBndrs,
ZonkEnv, ZonkFlexi(..), emptyZonkEnv, mkEmptyZonkEnv, initZonkEnv,
zonkTyVarBinders, zonkTyVarBindersX, zonkTyVarBinderX,
zonkTyBndrs, zonkTyBndrsX,
zonkTyBndrs, zonkTyBndrsX, zonkRecTyVarBndrs,
zonkTcTypeToType, zonkTcTypeToTypeX,
zonkTcTypesToTypes, zonkTcTypesToTypesX,
zonkTyVarOcc,
......@@ -278,7 +278,11 @@ data ZonkFlexi -- See Note [Un-unified unification variables]
| RuntimeUnkFlexi -- Used in the GHCi debugger
instance Outputable ZonkEnv where
ppr (ZonkEnv { ze_id_env = var_env}) = pprUFM var_env (vcat . map ppr)
ppr (ZonkEnv { ze_tv_env = tv_env
, ze_id_env = id_env })
= text "ZE" <+> braces (vcat
[ text "ze_tv_env =" <+> ppr tv_env
, text "ze_id_env =" <+> ppr id_env ])
-- The EvBinds have to already be zonked, but that's usually the case.
emptyZonkEnv :: TcM ZonkEnv
......@@ -292,9 +296,9 @@ mkEmptyZonkEnv flexi
, ze_id_env = emptyVarEnv
, ze_meta_tv_env = mtv_env_ref }) }
initZonkEnv :: (ZonkEnv -> a -> TcM b) -> a -> TcM b
initZonkEnv do_it x = do { ze <- mkEmptyZonkEnv DefaultFlexi
; do_it ze x }
initZonkEnv :: (ZonkEnv -> TcM b) -> TcM b
initZonkEnv thing_inside = do { ze <- mkEmptyZonkEnv DefaultFlexi
; thing_inside ze }
-- | Extend the knot-tied environment.
extendIdZonkEnvRec :: ZonkEnv -> [Var] -> ZonkEnv
......@@ -324,6 +328,12 @@ extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv
extendTyZonkEnv1 ze@(ZonkEnv { ze_tv_env = ty_env }) tv
= ze { ze_tv_env = extendVarEnv ty_env tv tv }
extendTyZonkEnvN :: ZonkEnv -> [(Name,TyVar)] -> ZonkEnv
extendTyZonkEnvN ze@(ZonkEnv { ze_tv_env = ty_env }) pairs
= ze { ze_tv_env = foldl add ty_env pairs }
where
add env (name, tv) = extendVarEnv_Directly env (getUnique name) tv
setZonkType :: ZonkEnv -> ZonkFlexi -> ZonkEnv
setZonkType ze flexi = ze { ze_flexi = flexi }
......@@ -374,7 +384,7 @@ zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
zonkTopBndrs :: [TcId] -> TcM [Id]
zonkTopBndrs ids = initZonkEnv zonkIdBndrs ids
zonkTopBndrs ids = initZonkEnv $ \ ze -> zonkIdBndrs ze ids
zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTcId -> TcM (FieldOcc GhcTc)
zonkFieldOcc env (FieldOcc sel lbl)
......@@ -419,7 +429,7 @@ zonkCoreBndrsX :: ZonkEnv -> [Var] -> TcM (ZonkEnv, [Var])
zonkCoreBndrsX = mapAccumLM zonkCoreBndrX
zonkTyBndrs :: [TcTyVar] -> TcM (ZonkEnv, [TyVar])
zonkTyBndrs = initZonkEnv zonkTyBndrsX
zonkTyBndrs tvs = initZonkEnv $ \ze -> zonkTyBndrsX ze tvs
zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TyVar])
zonkTyBndrsX = mapAccumLM zonkTyBndrX
......@@ -436,7 +446,7 @@ zonkTyBndrX env tv
zonkTyVarBinders :: [VarBndr TcTyVar vis]
-> TcM (ZonkEnv, [VarBndr TyVar vis])
zonkTyVarBinders = initZonkEnv zonkTyVarBindersX
zonkTyVarBinders tvbs = initZonkEnv $ \ ze -> zonkTyVarBindersX ze tvbs
zonkTyVarBindersX :: ZonkEnv -> [VarBndr TcTyVar vis]
-> TcM (ZonkEnv, [VarBndr TyVar vis])
......@@ -449,11 +459,27 @@ zonkTyVarBinderX env (Bndr tv vis)
= do { (env', tv') <- zonkTyBndrX env tv
; return (env', Bndr tv' vis) }
zonkRecTyVarBndrs :: [Name] -> [TcTyVar] -> TcM (ZonkEnv, [TyVar])
-- This rather specialised function is used in exactly one place.
-- See Note [Tricky scoping in generaliseTcTyCon] in TcTyClsDecls.
zonkRecTyVarBndrs names tc_tvs
= initZonkEnv $ \ ze ->
fixM $ \ ~(_, rec_new_tvs) ->
do { let ze' = extendTyZonkEnvN ze $
zipWithLazy (\ tc_tv new_tv -> (getName tc_tv, new_tv))
tc_tvs rec_new_tvs
; new_tvs <- zipWithM (zonk_one ze') names tc_tvs
; return (ze', new_tvs) }
where
zonk_one ze name tc_tv
= do { ki <- zonkTcTypeToTypeX ze (tyVarKind tc_tv)
; return (mkTyVar name ki) }
zonkTopExpr :: HsExpr GhcTcId -> TcM (HsExpr GhcTc)
zonkTopExpr e = initZonkEnv zonkExpr e
zonkTopExpr e = initZonkEnv $ \ ze -> zonkExpr ze e
zonkTopLExpr :: LHsExpr GhcTcId -> TcM (LHsExpr GhcTc)
zonkTopLExpr e = initZonkEnv zonkLExpr e
zonkTopLExpr e = initZonkEnv $ \ ze -> zonkLExpr ze e
zonkTopDecls :: Bag EvBind
-> LHsBinds GhcTcId
......@@ -466,7 +492,7 @@ zonkTopDecls :: Bag EvBind
[LTcSpecPrag],
[LRuleDecl GhcTc])
zonkTopDecls ev_binds binds rules imp_specs fords
= do { (env1, ev_binds') <- initZonkEnv zonkEvBinds ev_binds
= do { (env1, ev_binds') <- initZonkEnv $ \ ze -> zonkEvBinds ze ev_binds
; (env2, binds') <- zonkRecMonoBinds env1 binds
-- Top level is implicitly recursive
; rules' <- zonkRules env2 rules
......@@ -1744,9 +1770,9 @@ Solution: (see Trac #15552 for other variants)
* The map is of course stateful, held in a TcRef. (That is unlike
the treatment of lexically-scoped variables in ze_tv_env and
ze_id_env.
ze_id_env.)
Is the extra work worth it. Some non-sytematic perf measurements
Is the extra work worth it? Some non-sytematic perf measurements
suggest that compiler allocation is reduced overall (by 0.5% or so)
but compile time really doesn't change.
-}
......@@ -1865,13 +1891,13 @@ zonkTcTyConToTyCon tc
-- Confused by zonking? See Note [What is zonking?] in TcMType.
zonkTcTypeToType :: TcType -> TcM Type
zonkTcTypeToType = initZonkEnv zonkTcTypeToTypeX
zonkTcTypeToType ty = initZonkEnv $ \ ze -> zonkTcTypeToTypeX ze ty
zonkTcTypeToTypeX :: ZonkEnv -> TcType -> TcM Type
zonkTcTypeToTypeX = mapType zonk_tycomapper
zonkTcTypesToTypes :: [TcType] -> TcM [Type]
zonkTcTypesToTypes = initZonkEnv zonkTcTypesToTypesX
zonkTcTypesToTypes tys = initZonkEnv $ \ ze -> zonkTcTypesToTypesX ze tys
zonkTcTypesToTypesX :: ZonkEnv -> [TcType] -> TcM [Type]
zonkTcTypesToTypesX env tys = mapM (zonkTcTypeToTypeX env) tys
......
......@@ -190,8 +190,8 @@ tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty)
kcHsSigType :: [Located Name] -> LHsSigType GhcRn -> TcM ()
kcHsSigType names (HsIB { hsib_body = hs_ty
, hsib_ext = sig_vars })
= addSigCtxt (funsSigCtxt names) hs_ty $
discardResult $
= discardResult $
addSigCtxt (funsSigCtxt names) hs_ty $
bindImplicitTKBndrs_Skol sig_vars $
tc_lhs_type typeLevelMode hs_ty liftedTypeKind
......@@ -238,7 +238,6 @@ tc_hs_sig_type skol_info hs_sig_type ctxt_kind
solveLocalEqualitiesX "tc_hs_sig_type" $
bindImplicitTKBndrs_Skol sig_vars $
do { kind <- newExpectedKind ctxt_kind
; tc_lhs_type typeLevelMode hs_ty kind }
-- Any remaining variables (unsolved in the solveLocalEqualities)
-- should be in the global tyvars, and therefore won't be quantified
......@@ -1864,15 +1863,12 @@ kcLHsQTyVars_Cusk name flav
++ map (mkRequiredTyConBinder mentioned_kv_set) tc_tvs
all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)
tycon = mkTcTyCon name
final_tc_binders
res_kind
all_tv_prs
tycon = mkTcTyCon name final_tc_binders res_kind all_tv_prs
True {- it is generalised -} flav
-- If the ordering from
-- Note [Required, Specified, and Inferred for types] in TcTyClsDecls
-- doesn't work, we catch it here, before an error cascade
; checkValidTelescope tycon
; checkTyConTelescope tycon
; traceTc "kcLHsQTyVars: cusk" $
vcat [ text "name" <+> ppr name
......@@ -1921,8 +1917,13 @@ kcLHsQTyVars_NonCusk name flav
-- Also, note that tc_binders has the tyvars from only the
-- user-written tyvarbinders. See S1 in Note [How TcTyCons work]
-- in TcTyClsDecls
tycon = mkTcTyCon name tc_binders res_kind
(mkTyVarNamePairs (scoped_kvs ++ tc_tvs))
all_tv_prs = (kv_ns `zip` scoped_kvs) ++
(hsLTyVarNames hs_tvs `zip` tc_tvs)
-- NB: bindIplicitTKBndrs_Q_Tv makes /freshly-named/ unification
-- variables, hence the need to zip here. Ditto bindExplicit..
-- See TcMType Note [Unification variables need fresh Names]
tycon = mkTcTyCon name tc_binders res_kind all_tv_prs
False -- not yet generalised
flav
......@@ -2046,32 +2047,24 @@ expectedKindInCtxt _ = OpenKind
bindImplicitTKBndrs_Skol, bindImplicitTKBndrs_Tv,
bindImplicitTKBndrs_Q_Skol, bindImplicitTKBndrs_Q_Tv
:: [Name]
-> TcM a
-> TcM ([TcTyVar], a)
:: [Name] -> TcM a -> TcM ([TcTyVar], a)
bindImplicitTKBndrs_Skol = bindImplicitTKBndrsX newFlexiKindedSkolemTyVar
bindImplicitTKBndrs_Tv = bindImplicitTKBndrsX newFlexiKindedTyVarTyVar
bindImplicitTKBndrs_Q_Skol = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedSkolemTyVar)
bindImplicitTKBndrs_Q_Tv = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedTyVarTyVar)
bindImplicitTKBndrsX :: (Name -> TcM TcTyVar) -- new_tv function
bindImplicitTKBndrsX
:: (Name -> TcM TcTyVar) -- new_tv function
-> [Name]
-> TcM a
-> TcM ([TcTyVar], a) -- these tyvars are dependency-ordered
-- * Guarantees to call solveLocalEqualities to unify
-- all constraints from thing_inside.
--
-- * Returned TcTyVars have the supplied HsTyVarBndrs,
-- but may be in different order to the original [Name]
-- (because of sorting to respect dependency)
--
-- * Returned TcTyVars have zonked kinds
-- See Note [Keeping scoped variables in order: Implicit]
-> TcM ([TcTyVar], a) -- Returned [TcTyVar] are in 1-1 correspondence
-- with the passed in [Name]
bindImplicitTKBndrsX new_tv tv_names thing_inside
= do { tkvs <- mapM new_tv tv_names
; result <- tcExtendTyVarEnv tkvs thing_inside
; traceTc "bindImplicitTKBndrs" (ppr tv_names $$ ppr tkvs)
; return (tkvs, result) }
; res <- tcExtendNameTyVarEnv (tv_names `zip` tkvs)
thing_inside
; return (tkvs, res) }
newImplicitTyVarQ :: (Name -> TcM TcTyVar) -> Name -> TcM TcTyVar
-- Behave like new_tv, except that if the tyvar is in scope, use it
......@@ -2091,6 +2084,7 @@ newFlexiKindedSkolemTyVar = newFlexiKindedTyVar newSkolemTyVar
newFlexiKindedTyVarTyVar :: Name -> TcM TyVar
newFlexiKindedTyVarTyVar = newFlexiKindedTyVar newTyVarTyVar
-- See Note [Unification variables need fresh Names] in TcMType
--------------------------------------
-- Explicit binders
......@@ -2119,7 +2113,8 @@ bindExplicitTKBndrsX
:: (HsTyVarBndr GhcRn -> TcM TcTyVar)
-> [LHsTyVarBndr GhcRn]
-> TcM a
-> TcM ([TcTyVar], a)
-> TcM ([TcTyVar], a) -- Returned [TcTyVar] are in 1-1 correspondence
-- with the passed-in [LHsTyVarBndr]
bindExplicitTKBndrsX tc_tv hs_tvs thing_inside
= do { traceTc "bindExplicTKBndrs" (ppr hs_tvs)
; go hs_tvs }
......@@ -2128,7 +2123,13 @@ bindExplicitTKBndrsX tc_tv hs_tvs thing_inside
; return ([], res) }
go (L _ hs_tv : hs_tvs)
= do { tv <- tc_tv hs_tv
; (tvs, res) <- tcExtendTyVarEnv [tv] (go hs_tvs)
-- Extend the environment as we go, in case a binder
-- is mentioned in the kind of a later binder
-- e.g. forall k (a::k). blah
-- NB: tv's Name may differ from hs_tv's
-- See TcMType Note [Unification variables need fresh Names]
; (tvs,res) <- tcExtendNameTyVarEnv [(hsTyVarName hs_tv, tv)] $
go hs_tvs
; return (tv:tvs, res) }
-----------------
......@@ -2192,7 +2193,7 @@ bindTyClTyVars tycon_name thing_inside
; let scoped_prs = tcTyConScopedTyVars tycon
res_kind = tyConResKind tycon
binders = tyConBinders tycon
; traceTc "bindTyClTyVars" (ppr tycon_name <+> ppr binders)
; traceTc "bindTyClTyVars" (ppr tycon_name <+> ppr binders $$ ppr scoped_prs)
; tcExtendNameTyVarEnv scoped_prs $
thing_inside binders res_kind }
......@@ -2215,8 +2216,8 @@ kcLookupTcTyCon nm
zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar]
zonkAndScopedSort spec_tkvs
= do { spec_tkvs <- mapM zonkTcTyCoVarBndr spec_tkvs
-- Use zonkTcTyCoVarBndr because a skol_tv might be a TyVarTv
= do { spec_tkvs <- mapM zonkAndSkolemise spec_tkvs
-- Use zonkAndSkolemise because a skol_tv might be a TyVarTv
-- Do a stable topological sort, following
-- Note [Ordering of implicit variables] in RnTypes
......@@ -2503,7 +2504,7 @@ tcHsPartialSigType ctxt sig_ty
-- in partial type signatures that bind scoped type variables, as
-- we bring the wrong name into scope in the function body.
-- Test case: partial-sigs/should_compile/LocalDefinitionBug
; let tv_names = map tyVarName (implicit_tvs ++ explicit_tvs)
; let tv_names = implicit_hs_tvs ++ hsLTyVarNames explicit_hs_tvs
-- Spit out the wildcards (including the extra-constraints one)
-- as "hole" constraints, so that they'll be reported if necessary
......@@ -2520,7 +2521,7 @@ tcHsPartialSigType ctxt sig_ty
-- we need to promote the TyVarTvs so we don't violate the TcLevel
-- invariant
; implicit_tvs <- zonkAndScopedSort implicit_tvs
; explicit_tvs <- mapM zonkTcTyCoVarBndr explicit_tvs
; explicit_tvs <- mapM zonkAndSkolemise explicit_tvs
; theta <- mapM zonkTcType theta
; tau <- zonkTcType tau
......@@ -2605,17 +2606,17 @@ tcHsPatSigType :: UserTypeCtxt
-- See Note [Recipe for checking a signature]
tcHsPatSigType ctxt sig_ty
| HsWC { hswc_ext = sig_wcs, hswc_body = ib_ty } <- sig_ty
, HsIB { hsib_ext = sig_vars
, HsIB { hsib_ext = sig_ns
, hsib_body = hs_ty } <- ib_ty
= addSigCtxt ctxt hs_ty $
do { sig_tkvs <- mapM new_implicit_tv sig_vars
do { sig_tkv_prs <- mapM new_implicit_tv sig_ns
; (wcs, sig_ty)
<- solveLocalEqualities "tcHsPatSigType" $
-- Always solve local equalities if possible,
-- else casts get in the way of deep skolemisation
-- (Trac #16033)
tcWildCardBinders sig_wcs $ \ wcs ->
tcExtendTyVarEnv sig_tkvs $
tcExtendNameTyVarEnv sig_tkv_prs $
do { sig_ty <- tcHsOpenType hs_ty
; return (wcs, sig_ty) }
......@@ -2629,19 +2630,17 @@ tcHsPatSigType ctxt sig_ty
; sig_ty <- zonkPromoteType sig_ty
; checkValidType ctxt sig_ty
; let tv_pairs = mkTyVarNamePairs sig_tkvs
; traceTc "tcHsPatSigType" (ppr sig_vars)
; return (wcs, tv_pairs, sig_ty) }
; traceTc "tcHsPatSigType" (ppr sig_tkv_prs)
; return (wcs, sig_tkv_prs, sig_ty) }
where
new_implicit_tv name = do { kind <- newMetaKindVar
; new_tv name kind }
new_tv = case ctxt of
RuleSigCtxt {} -> newSkolemTyVar
_ -> newTauTyVar
new_implicit_tv name
= do { kind <- newMetaKindVar
; tv <- case ctxt of
RuleSigCtxt {} -> newSkolemTyVar name kind
_ -> newPatSigTyVar name kind
-- See Note [Pattern signature binders]
-- NB: tv's Name may be fresh (in the case of newPatSigTyVar)
; return (name, tv) }
tcHsPatSigType _ (HsWC _ (XHsImplicitBndrs _)) = panic "tcHsPatSigType"
tcHsPatSigType _ (XHsWildCardBndrs _) = panic "tcHsPatSigType"
......
This diff is collapsed.
......@@ -382,8 +382,8 @@ tcPatSynSig name sig_ty
-- e.g. pattern Zero <- 0# (Trac #12094)
; return (req, prov, body_ty) }
; let ungen_patsyn_ty = build_patsyn_type [] implicit_tvs univ_tvs req
ex_tvs prov body_ty
; let ungen_patsyn_ty = build_patsyn_type [] implicit_tvs univ_tvs
req ex_tvs prov body_ty
-- Kind generalisation
; kvs <- kindGeneralize ungen_patsyn_ty
......
This diff is collapsed.
This diff is collapsed.
......@@ -876,19 +876,37 @@ data TyCon
tyConKind :: Kind, -- ^ Kind of this TyCon
tyConArity :: Arity, -- ^ Arity
-- NB: the TyConArity of a TcTyCon must match
-- the number of Required (positional, user-specified)
-- arguments to the type constructor; see the use
-- of tyConArity in generaliseTcTyCon
tcTyConScopedTyVars :: [(Name,TyVar)],
-- ^ Scoped tyvars over the tycon's body
-- See Note [How TcTyCons work] in TcTyClsDecls
-- Order *does* matter: for TcTyCons with a CUSK,
-- it's the correct dependency order. For TcTyCons
-- without a CUSK, it's the original left-to-right
-- that the user wrote. Nec'y for getting Specified
-- variables in the right order.
-- See Note [Scoped tyvars in a TcTyCon]
tcTyConIsPoly :: Bool, -- ^ Is this TcTyCon already generalized?
tcTyConFlavour :: TyConFlavour
-- ^ What sort of 'TyCon' this represents.
}
{- Note [Scoped tyvars in a TcTyCon]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The tcTyConScopedTyVars field records the lexicial-binding connection
between the original, user-specified Name (i.e. thing in scope) and
the TcTyVar that the Name is bound to.
Order *does* matter; the tcTyConScopedTyvars list consists of
specified_tvs ++ required_tvs
where
* specified ones first
* required_tvs the same as tyConTyVars
* tyConArity = length required_tvs
See also Note [How TcTyCons work] in TcTyClsDecls
-}
-- | Represents right-hand-sides of 'TyCon's for algebraic types
data AlgTyConRhs
......
......@@ -69,7 +69,7 @@ test('T2664a', normal, compile, [''])
test('T2544', normal, compile_fail, [''])
test('T1897b', normal, compile_fail, [''])
test('T5439', normal, compile_fail, [''])
test('T5515', when(compiler_debugged(), expect_broken(16251)), compile_fail, [''])
test('T5515', normal, compile_fail, [''])
  • @simonpj, the description for this commit mentions that it fixes #16221 (closed) and #16342 (closed). But as far as I can tell, this patch doesn't check in any test cases for them. Was this intended?

Please register or sign in to reply
test('T5934', normal, compile_fail, [''])
test('T6123', normal, compile_fail, [''])
test('ExtraTcsUntch', normal, compile_fail, [''])
......
......@@ -7,22 +7,22 @@ tc141.hs:11:12: error:
In a pattern binding: (p :: a, q :: a) = x
tc141.hs:11:31: error:
• Couldn't match expected type ‘a2’ with actual type ‘a
‘a2’ is a rigid type variable bound by
• Couldn't match expected type ‘a1’ with actual type ‘b
‘a1’ is a rigid type variable bound by
an expression type signature:
forall a2. a2
forall a1. a1
at tc141.hs:11:34
a’ is a rigid type variable bound by
the inferred type of f :: (a, a) -> (a1, a)
b’ is a rigid type variable bound by
the inferred type of f :: (b, b) -> (a, b)
at tc141.hs:11:1-37
• In the expression: q :: a
In the expression: (q :: a, p)
In the expression: let (p :: a, q :: a) = x in (q :: a, p)
• Relevant bindings include
p :: a (bound at tc141.hs:11:12)
q :: a (bound at tc141.hs:11:17)
x :: (a, a) (bound at tc141.hs:11:3)
f :: (a, a) -> (a1, a) (bound at tc141.hs:11:1)
p :: b (bound at tc141.hs:11:12)
q :: b (bound at tc141.hs:11:17)
x :: (b, b) (bound at tc141.hs:11:3)
f :: (b, b) -> (a, b) (bound at tc141.hs:11:1)
tc141.hs:13:13: error:
• You cannot bind scoped type variable ‘a’
......
......@@ -3,10 +3,10 @@ T2688.hs:8:14: error:
• Couldn't match expected type ‘v’ with actual type ‘s’
‘s’ is a rigid type variable bound by
the class declaration for ‘VectorSpace’
at T2688.hs:(5,1)-(8,23)
at T2688.hs:5:21
‘v’ is a rigid type variable bound by
the class declaration for ‘VectorSpace’
at T2688.hs:(5,1)-(8,23)
at T2688.hs:5:19
• In the expression: v *^ (1 / s)
In an equation for ‘^/’: v ^/ s = v *^ (1 / s)
• Relevant bindings include
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment