[Git][ghc/ghc][wip/T25647] 3 commits: Refactor HsOuterTyVarBndrs to include implicit variable bindings and update...
Patrick (@soulomoon)
gitlab at gitlab.haskell.org
Sat Mar 8 15:14:52 UTC 2025
Patrick pushed to branch wip/T25647 at Glasgow Haskell Compiler / GHC
Commits:
131c1485 by Patrick at 2025-03-08T02:11:52+08:00
Refactor HsOuterTyVarBndrs to include implicit variable bindings and update related functions for consistency
- - - - -
2e7666eb by Patrick at 2025-03-08T23:06:28+08:00
Enhance HsOuterTyVarBndrs to support implicit variable bindings and update related functions for consistency
- - - - -
653aa8da by Patrick at 2025-03-08T23:14:13+08:00
Add new test case T25647d
- - - - -
16 changed files:
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/Zonk/TcType.hs
- compiler/Language/Haskell/Syntax/Type.hs
- + testsuite/tests/typecheck/should_compile/T25647d.hs
- testsuite/tests/typecheck/should_compile/all.T
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
Changes:
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -594,4 +594,4 @@ deriving instance Data XViaStrategyPs
-- ---------------------------------------------------------------------
deriving instance (Typeable p, Data (Anno (IdGhcP p)), Data (IdGhcP p)) => Data (BooleanFormula (GhcPass p))
----------------------------------------------------------------------
\ No newline at end of file
+---------------------------------------------------------------------
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -312,7 +312,7 @@ dropWildCards sig_ty = hswc_body sig_ty
hsOuterTyVarNames :: HsOuterTyVarBndrs flag GhcRn -> [Name]
hsOuterTyVarNames (HsOuterImplicit{hso_ximplicit = imp_tvs}) = imp_tvs
-hsOuterTyVarNames (HsOuterExplicit{hso_bndrs = bndrs}) = hsLTyVarNames bndrs
+hsOuterTyVarNames (HsOuterExplicit{hso_bndrs = bndrs, hso_ximplicit= imp_tvs}) = hsLTyVarNames bndrs ++ imp_tvs
hsOuterExplicitBndrs :: HsOuterTyVarBndrs flag (GhcPass p)
-> [LHsTyVarBndr flag (NoGhcTc (GhcPass p))]
@@ -325,7 +325,9 @@ mkHsOuterImplicit = HsOuterImplicit{hso_ximplicit = noExtField}
mkHsOuterExplicit :: EpAnnForallInvis -> [LHsTyVarBndr flag GhcPs]
-> HsOuterTyVarBndrs flag GhcPs
mkHsOuterExplicit an bndrs = HsOuterExplicit { hso_xexplicit = an
- , hso_bndrs = bndrs }
+ , hso_bndrs = bndrs
+ , hso_ximplicit = NoExtField
+ }
mkHsImplicitSigType :: LHsType GhcPs -> HsSigType GhcPs
mkHsImplicitSigType body =
@@ -1243,8 +1245,12 @@ instance (OutputableBndrFlag flag p,
GhcPs -> ppr imp_tvs
GhcRn -> ppr imp_tvs
GhcTc -> ppr imp_tvs
- ppr (HsOuterExplicit{hso_bndrs = exp_tvs}) =
+ ppr (HsOuterExplicit{hso_bndrs = exp_tvs, hso_ximplicit=imp_tvs}) =
text "HsOuterExplicit:" <+> ppr exp_tvs
+ <+> case ghcPass @p of
+ GhcPs -> ppr imp_tvs
+ GhcRn -> ppr imp_tvs
+ GhcTc -> ppr imp_tvs
instance OutputableBndrId p
=> Outputable (HsForAllTelescope (GhcPass p)) where
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1224,7 +1224,7 @@ addHsOuterSigTyVarBinds outer_bndrs thing_inside = case outer_bndrs of
HsOuterImplicit{hso_ximplicit = imp_tvs} ->
do th_nil <- coreListM tyVarBndrSpecTyConName []
addSimpleTyVarBinds FreshNamesOnly imp_tvs $ thing_inside th_nil
- HsOuterExplicit{hso_bndrs = exp_bndrs} ->
+ HsOuterExplicit{hso_bndrs = exp_bndrs, hso_ximplicit= imp_tvs} ->
addHsTyVarBinds FreshNamesOnly exp_bndrs thing_inside
-- | If a type implicitly quantifies its outermost type variables, return
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1872,7 +1872,10 @@ instance ToHie (TScoped (LocatedA (HsSigType GhcRn))) where
instance Data flag => ToHie (TVScoped (HsOuterTyVarBndrs flag GhcRn)) where
toHie (TVS tsc sc bndrs) = case bndrs of
HsOuterImplicit xs -> bindingsOnly $ map (C $ TyVarBind sc tsc) xs
- HsOuterExplicit _ xs -> toHie $ tvScopes tsc sc xs
+ HsOuterExplicit _ xs ys -> do
+ implicits <- bindingsOnly (map (C $ TyVarBind sc tsc) ys)
+ explicits <- toHie (tvScopes tsc sc xs);
+ pure $ implicits ++ explicits
toHieForAllTele :: HsForAllTelescope GhcRn -> SrcSpan -> HieM [HieAST Type]
toHieForAllTele (HsForAllVis { hsf_vis_bndrs = bndrs }) loc =
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -818,7 +818,7 @@ mkGadtDecl loc names dcol ty = do
let bndrs_loc = case outer_bndrs of
HsOuterImplicit{} -> getLoc ty
- HsOuterExplicit an _ -> EpAnn (entry an) noAnn emptyComments
+ HsOuterExplicit an _ _ -> EpAnn (entry an) noAnn emptyComments
let l = EpAnn (spanAsAnchor loc) noAnn csa
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -29,7 +29,8 @@ module GHC.Rename.HsType (
checkPrecMatch, checkSectionPrec,
-- Binding related stuff
- bindHsOuterTyVarBndrs, bindHsForAllTelescope,
+ RnBindFam(..),
+ bindHsOuterTyVarBndrs, bindHsOuterTyVarBndrs', bindHsForAllTelescope,
bindLHsTyVarBndr, bindLHsTyVarBndrs, WarnUnusedForalls(..),
rnImplicitTvOccs, bindSigTyVarsFV, bindHsQTyVars,
FreeKiTyVars, filterInScopeM,
@@ -1091,6 +1092,7 @@ an LHsQTyVars can be semantically significant. As a result, we suppress
-Wunused-foralls warnings in exactly one place: in bindHsQTyVars.
-}
+data RnBindFam = BindFam | NotBindFam
bindHsOuterTyVarBndrs :: OutputableBndrFlag flag 'Renamed
=> HsDocContext
-> Maybe assoc
@@ -1099,7 +1101,18 @@ bindHsOuterTyVarBndrs :: OutputableBndrFlag flag 'Renamed
-> HsOuterTyVarBndrs flag GhcPs
-> (HsOuterTyVarBndrs flag GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
-bindHsOuterTyVarBndrs doc mb_cls implicit_vars outer_bndrs thing_inside =
+bindHsOuterTyVarBndrs = bindHsOuterTyVarBndrs' NotBindFam
+
+bindHsOuterTyVarBndrs' :: OutputableBndrFlag flag 'Renamed
+ => RnBindFam
+ -> HsDocContext
+ -> Maybe assoc
+ -- ^ @'Just' _@ => an associated type decl
+ -> FreeKiTyVars
+ -> HsOuterTyVarBndrs flag GhcPs
+ -> (HsOuterTyVarBndrs flag GhcRn -> RnM (a, FreeVars))
+ -> RnM (a, FreeVars)
+bindHsOuterTyVarBndrs' bind_fam doc mb_cls implicit_vars outer_bndrs thing_inside =
case outer_bndrs of
HsOuterImplicit{} ->
rnImplicitTvOccs mb_cls implicit_vars $ \implicit_vars' ->
@@ -1110,9 +1123,15 @@ bindHsOuterTyVarBndrs doc mb_cls implicit_vars outer_bndrs thing_inside =
-- scope here. This is an explicit forall, so we want fresh names, not
-- class variables. Thus: always pass Nothing.
bindLHsTyVarBndrs doc WarnUnusedForalls Nothing exp_bndrs $ \exp_bndrs' -> do
- checkForAllTelescopeWildcardBndrs doc exp_bndrs'
- thing_inside $ HsOuterExplicit { hso_xexplicit = noExtField
- , hso_bndrs = exp_bndrs' }
+ rnImplicitTvOccs mb_cls fam_implicit_vars $ \implicit_vars' -> do
+ checkForAllTelescopeWildcardBndrs doc exp_bndrs'
+ thing_inside $ HsOuterExplicit { hso_xexplicit = noExtField
+ , hso_bndrs = exp_bndrs'
+ , hso_ximplicit = implicit_vars' }
+ where
+ fam_implicit_vars = case bind_fam of
+ BindFam -> filterFreeVarsToBind (mapMaybe hsLTyVarLocName $ hso_bndrs outer_bndrs) implicit_vars
+ NotBindFam -> []
-- See Note [Term variable capture and implicit quantification]
warn_term_var_capture :: LocatedN RdrName -> RnM ()
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -700,7 +700,7 @@ rnFamEqn doc atfi
-- bound by the instance head with filterInScopeM (#19649).
; all_imp_vars <- filterInScopeM $ (pat_kity_vars ++ payload_kvs)
- ; bindHsOuterTyVarBndrs doc mb_cls all_imp_vars outer_bndrs $ \rn_outer_bndrs ->
+ ; bindHsOuterTyVarBndrs' BindFam doc mb_cls all_imp_vars outer_bndrs $ \rn_outer_bndrs ->
do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats
; (payload', rhs_fvs) <- rn_payload doc payload
@@ -717,6 +717,7 @@ rnFamEqn doc atfi
groups :: [NonEmpty (LocatedN RdrName)]
groups = equivClasses cmpLocated pat_kity_vars
+ ; traceRn "rnFamEqn: rn_outer_bndrs: " (ppr outer_bndrs <+> ppr rn_outer_bndrs')
; nms_dups <- mapM (lookupOccRn . unLoc) $
[ tv | (tv :| (_:_)) <- groups ]
-- Add to the used variables
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -44,7 +44,7 @@ module GHC.Tc.Gen.HsType (
etaExpandAlgTyCon,
-- tyvars
- zonkAndScopedSort,
+ zonkAndScopedSort, zonkAndScopedSortFam,
-- Kind-checking types
-- No kind generalisation, no checkValidType
@@ -72,7 +72,7 @@ module GHC.Tc.Gen.HsType (
HoleMode(..),
-- Utils
- tyLitFromLit, tyLitFromOverloadedLit,
+ tyLitFromLit, tyLitFromOverloadedLit, scopedSortOuterFam,
) where
@@ -2264,7 +2264,7 @@ tcAnonWildCardOcc is_extra (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) }
-- see Note [Implementation tweak for wildCards in family instances]
mk_wc_details = case hole_mode of
- HM_FamPat FreeArg -> newTyVarMetaVarDetailsAtLevel
+ HM_FamPat FreeArg -> newTauTvDetailsAtLevel
HM_FamPat ClassArg -> newTauTvDetailsAtLevel
HM_FamPat SigArg -> newTauTvDetailsAtLevel
_ -> newTauTvDetailsAtLevel
@@ -3274,22 +3274,35 @@ tcTKTelescope mode tele thing_inside = case tele of
--------------------------------------
-- HsOuterTyVarBndrs
--------------------------------------
+bindOuterTKBndrsX' :: OutputableBndrFlag flag 'Renamed -- Only to support traceTc
+ =>
+ SkolemMode
+ -> HsOuterTyVarBndrs flag GhcRn
+ -> TcM a
+ -> TcM (HsOuterTyVarBndrs flag GhcTc, a)
+bindOuterTKBndrsX' x = bindOuterTKBndrsX x x
bindOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed -- Only to support traceTc
- => SkolemMode
+ =>
+ SkolemMode -- implicit
+ -> SkolemMode -- explict
-> HsOuterTyVarBndrs flag GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
-bindOuterTKBndrsX skol_mode outer_bndrs thing_inside
+bindOuterTKBndrsX i_skol_mode e_skol_mode outer_bndrs thing_inside
= case outer_bndrs of
HsOuterImplicit{hso_ximplicit = imp_tvs} ->
- do { (imp_tvs', thing) <- bindImplicitTKBndrsX skol_mode imp_tvs thing_inside
+ do { (imp_tvs', thing) <- bindImplicitTKBndrsX i_skol_mode imp_tvs thing_inside
; return ( HsOuterImplicit{hso_ximplicit = imp_tvs'}
, thing) }
- HsOuterExplicit{hso_bndrs = exp_bndrs} ->
- do { (exp_tvs', thing) <- bindExplicitTKBndrsX skol_mode exp_bndrs thing_inside
+ HsOuterExplicit{hso_bndrs = exp_bndrs, hso_ximplicit = imp_tvs} ->
+ do { (exp_tvs', (imp_tvs', thing)) <-
+ bindExplicitTKBndrsX e_skol_mode exp_bndrs
+ $ bindImplicitTKBndrsX i_skol_mode imp_tvs thing_inside
; return ( HsOuterExplicit { hso_xexplicit = exp_tvs'
- , hso_bndrs = exp_bndrs }
+ , hso_bndrs = exp_bndrs
+ , hso_ximplicit = imp_tvs'
+ }
, thing) }
---------------
@@ -3297,30 +3310,44 @@ outerTyVars :: HsOuterTyVarBndrs flag GhcTc -> [TcTyVar]
-- The returned [TcTyVar] is not necessarily in dependency order
-- at least for the HsOuterImplicit case
outerTyVars (HsOuterImplicit { hso_ximplicit = tvs }) = tvs
-outerTyVars (HsOuterExplicit { hso_xexplicit = tvbs }) = binderVars tvbs
+outerTyVars (HsOuterExplicit { hso_xexplicit = tvbs, hso_ximplicit = tvs }) = binderVars tvbs ++ tvs
---------------
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
+outerTyVarBndrs (HsOuterExplicit{hso_xexplicit = exp_tvs, hso_ximplicit = imp_tvs}) = exp_tvs ++ [Bndr tv SpecifiedSpec | tv <- imp_tvs]
---------------
-scopedSortOuter :: HsOuterTyVarBndrs flag GhcTc -> TcM (HsOuterTyVarBndrs flag GhcTc)
+scopedSortOuter :: HsOuterSigTyVarBndrs GhcTc -> TcM (HsOuterSigTyVarBndrs 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 (HsOuterImplicit { hso_ximplicit = imp_tvs }) }
-scopedSortOuter bndrs@(HsOuterExplicit{})
+scopedSortOuter bndrs@(HsOuterExplicit{ hso_ximplicit =imp_tvs })
= -- No need to dependency-sort (or zonk) explicit quantifiers
- return bndrs
+ do { imp_tvs <- zonkAndScopedSort imp_tvs
+ ; return bndrs{ hso_ximplicit = imp_tvs } }
+
+---------------
+scopedSortOuterFam :: HsOuterFamEqnTyVarBndrs GhcTc -> TcM (HsOuterFamEqnTyVarBndrs GhcTc)
+-- Sort any /implicit/ binders into dependency order
+-- (zonking first so we can see the dependencies)
+-- /Explicit/ ones are already in the right order
+scopedSortOuterFam (HsOuterImplicit{hso_ximplicit = imp_tvs})
+ = do { imp_tvs <- zonkAndScopedSortFam imp_tvs
+ ; return (HsOuterImplicit { hso_ximplicit = imp_tvs }) }
+scopedSortOuterFam bndrs@(HsOuterExplicit{ hso_ximplicit =imp_tvs })
+ = -- No need to dependency-sort (or zonk) explicit quantifiers
+ do { imp_tvs <- zonkAndScopedSortFam imp_tvs
+ ; return bndrs{ hso_ximplicit = imp_tvs } }
---------------
bindOuterSigTKBndrs_Tv :: HsOuterSigTyVarBndrs GhcRn
-> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a)
bindOuterSigTKBndrs_Tv
- = bindOuterTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv })
+ = bindOuterTKBndrsX' (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv })
bindOuterSigTKBndrs_Tv_M :: TcTyMode
-> HsOuterSigTyVarBndrs GhcRn
@@ -3330,14 +3357,14 @@ 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 = SMDTyVarTv
+ = bindOuterTKBndrsX' (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv
, sm_holes = mode_holes mode })
bindOuterFamEqnTKBndrs_Q_Tv :: HsOuterFamEqnTyVarBndrs GhcRn
-> TcM a
-> TcM (HsOuterFamEqnTyVarBndrs GhcTc, a)
bindOuterFamEqnTKBndrs_Q_Tv hs_bndrs thing_inside
- = bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = 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]
@@ -3347,15 +3374,17 @@ bindOuterFamEqnTKBndrs :: SkolemInfo
-> TcM a
-> TcM (HsOuterFamEqnTyVarBndrs GhcTc, a)
bindOuterFamEqnTKBndrs skol_info
- = bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = True
- , sm_tvtv = SMDSkolemTv skol_info })
+ = bindOuterTKBndrsX
+ (smVanilla { sm_clone = False, sm_parent = True
+ , sm_tvtv = SMDTauTv })
+ (smVanilla { sm_clone = False, sm_parent = True
+ , sm_tvtv = SMDSkolemTv skol_info })
-- sm_clone=False: see Note [Cloning for type variable binders]
---------------
-tcOuterTKBndrs :: OutputableBndrFlag flag 'Renamed -- Only to support traceTc
- => SkolemInfo
- -> HsOuterTyVarBndrs flag GhcRn
- -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a)
+tcOuterTKBndrs :: SkolemInfo
+ -> HsOuterSigTyVarBndrs GhcRn
+ -> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a)
tcOuterTKBndrs skol_info
= tcOuterTKBndrsX (smVanilla { sm_clone = False
, sm_tvtv = SMDSkolemTv skol_info })
@@ -3363,10 +3392,10 @@ tcOuterTKBndrs skol_info
-- Do not clone the outer binders
-- See Note [Cloning for type variable binders] under "must not"
-tcOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed -- Only to support traceTc
- => SkolemMode -> SkolemInfo
- -> HsOuterTyVarBndrs flag GhcRn
- -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a)
+tcOuterTKBndrsX ::
+ SkolemMode -> SkolemInfo
+ -> HsOuterSigTyVarBndrs GhcRn
+ -> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a)
-- Push level, capture constraints, make implication
tcOuterTKBndrsX skol_mode skol_info outer_bndrs thing_inside
= case outer_bndrs of
@@ -3377,8 +3406,12 @@ tcOuterTKBndrsX skol_mode skol_info outer_bndrs thing_inside
HsOuterExplicit{hso_bndrs = exp_bndrs} ->
do { (exp_tvs', thing) <- tcExplicitTKBndrsX skol_mode exp_bndrs thing_inside
; return ( HsOuterExplicit { hso_xexplicit = exp_tvs'
- , hso_bndrs = exp_bndrs }
- , thing) }
+ , hso_bndrs = exp_bndrs
+ -- note nothing should be here since
+ -- sig
+ , hso_ximplicit = [] }
+ , thing)
+ }
--------------------------------------
-- Explicit tyvar binders
@@ -3392,7 +3425,7 @@ tcExplicitTKBndrs :: OutputableBndrFlag flag 'Renamed -- Only to suppor trace
tcExplicitTKBndrs skol_info
= tcExplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDSkolemTv skol_info })
-tcExplicitTKBndrsX :: OutputableBndrFlag flag 'Renamed -- Only to suppor traceTc
+tcExplicitTKBndrsX :: forall flag a. OutputableBndrFlag flag 'Renamed -- Only to suppor traceTc
=> SkolemMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
@@ -3544,6 +3577,7 @@ newTyVarBndr (SM { sm_clone = clone, sm_tvtv = tvtv }) name kind
; return (setNameUnique name uniq) }
False -> return name
; details <- case tvtv of
+ SMDTauTv -> newMetaDetails TauTv
SMDTyVarTv -> newMetaDetails TyVarTv
SMDSkolemTv skol_info ->
do { lvl <- getTcLevel
@@ -3636,6 +3670,7 @@ data SkolemMode
data SkolemModeDetails
= SMDTyVarTv
| SMDSkolemTv SkolemInfo
+ | SMDTauTv
smVanilla :: HasDebugCallStack => SkolemMode
@@ -3759,6 +3794,17 @@ zonkAndScopedSort spec_tkvs
-- Note [Ordering of implicit variables] in GHC.Rename.HsType
; return (scopedSort spec_tkvs) }
+-- zonkAndScopedSortFam is a version of zonkAndScopedSort that works does not check
+-- the zonking result is still a TcTyVar
+zonkAndScopedSortFam :: [TcTyVar] -> TcM [TcTyVar]
+zonkAndScopedSortFam spec_tkvs
+ = do { spec_tkvs <- liftZonkM $ zonkTcTyVarsToTcTyVarsMaybe spec_tkvs
+ -- Zonk the kinds, to we can do the dependency analysis
+
+ -- Do a stable topological sort, following
+ -- Note [Ordering of implicit variables] in GHC.Rename.HsType
+ ; return (scopedSort spec_tkvs) }
+
-- | Generalize some of the free variables in the given type.
-- All such variables should be *kind* variables; any type variables
-- should be explicitly quantified (with a `forall`) before now.
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -3298,7 +3298,7 @@ tcTyFamInstEqn fam_tc mb_clsinfo
<- tcTyFamInstEqnGuts fam_tc mb_clsinfo
outer_bndrs hs_pats hs_rhs_ty
-- Don't print results they may be knot-tied
- -- (tcFamInstEqnGuts zonks to Type)
+ -- (tcTyFamInstEqnGuts zonks to Type)
; let ax = mkCoAxBranch qtvs [] [] pats rhs_ty
(map (const Nominal) qtvs)
@@ -3448,7 +3448,8 @@ tcTyFamInstEqnGuts fam_tc mb_clsinfo outer_hs_bndrs hs_pats hs_rhs_ty
; rhs_ty <- tcCheckLHsTypeInContext hs_rhs_ty (TheKind rhs_kind)
; return (lhs_ty, rhs_ty) }
- ; outer_bndrs <- scopedSortOuter outer_bndrs
+ ; traceTc "tcTyFamInstEqnGuts 0" (ppr outer_bndrs $$ ppr skol_info)
+ ; outer_bndrs <- scopedSortOuterFam outer_bndrs
; let outer_tvs = outerTyVars outer_bndrs
; checkFamTelescope tclvl outer_hs_bndrs outer_tvs
@@ -3461,9 +3462,9 @@ tcTyFamInstEqnGuts fam_tc mb_clsinfo outer_hs_bndrs hs_pats hs_rhs_ty
-- check there too!
-- See Note [Generalising in tcTyFamInstEqnGuts]
- ; dvs <- candidateQTyVarsWithBinders outer_tvs lhs_ty
+ ; dvs <- candidateQTyVarsOfType lhs_ty
; qtvs <- quantifyTyVars skol_info dvs
- ; let final_tvs = scopedSort (qtvs ++ outer_tvs)
+ ; let final_tvs = scopedSort qtvs
-- 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
=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -964,7 +964,7 @@ tcDataFamInstHeader mb_clsinfo skol_info fam_tc hs_outer_bndrs fixity
, lhs_applied_kind
, res_kind ) }
- ; outer_bndrs <- scopedSortOuter outer_bndrs
+ ; outer_bndrs <- scopedSortOuterFam outer_bndrs
; let outer_tvs = outerTyVars outer_bndrs
; checkFamTelescope tclvl hs_outer_bndrs outer_tvs
@@ -975,14 +975,14 @@ tcDataFamInstHeader mb_clsinfo skol_info fam_tc hs_outer_bndrs fixity
-- check there too!
-- See GHC.Tc.TyCl Note [Generalising in tcTyFamInstEqnGuts]
- ; dvs <- candidateQTyVarsWithBinders outer_tvs lhs_ty
+ ; dvs <- candidateQTyVarsOfType lhs_ty
; qtvs <- quantifyTyVars skol_info dvs
-- Have to make a same defaulting choice for reuslt kind here
-- and the `kindGeneralizeAll` in `tcConDecl`.
-- see (GT4) in
-- GHC.Tc.TyCl Note [Generalising in tcTyFamInstEqnGuts]
- ; let final_tvs = scopedSort (qtvs ++ outer_tvs)
+ ; let final_tvs = scopedSort qtvs
-- 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
=====================================
compiler/GHC/Tc/Zonk/TcType.hs
=====================================
@@ -20,6 +20,7 @@ module GHC.Tc.Zonk.TcType
, zonkTcTyVarToTcTyVar, zonkTcTyVarsToTcTyVars
, zonkInvisTVBinder
, zonkCo
+ , zonkTcTyVarsToTcTyVarsMaybe
-- ** Zonking 'TyCon's
, zonkTcTyCon
@@ -83,7 +84,7 @@ import GHC.Core.Predicate
import GHC.Utils.Constants
import GHC.Utils.Outputable
import GHC.Utils.Misc
-import GHC.Utils.Monad ( mapAccumLM )
+import GHC.Utils.Monad ( mapAccumLM, mapMaybeM )
import GHC.Utils.Panic
import GHC.Data.Bag
@@ -269,6 +270,9 @@ zonkTcTyVar tv
zonkTcTyVarsToTcTyVars :: HasDebugCallStack => [TcTyVar] -> ZonkM [TcTyVar]
zonkTcTyVarsToTcTyVars = mapM zonkTcTyVarToTcTyVar
+zonkTcTyVarsToTcTyVarsMaybe :: HasDebugCallStack => [TcTyVar] -> ZonkM [TcTyVar]
+zonkTcTyVarsToTcTyVarsMaybe = mapMaybeM (fmap getTyVar_maybe . zonkTcTyVar)
+
zonkTcTyVarToTcTyVar :: HasDebugCallStack => TcTyVar -> ZonkM TcTyVar
zonkTcTyVarToTcTyVar tv
= do { ty <- zonkTcTyVar tv
=====================================
compiler/Language/Haskell/Syntax/Type.hs
=====================================
@@ -382,6 +382,8 @@ data HsOuterTyVarBndrs flag pass
-- @f :: forall a b. a -> b -> b@
{ hso_xexplicit :: XHsOuterExplicit pass flag
, hso_bndrs :: [LHsTyVarBndr flag (NoGhcTc pass)]
+ , hso_ximplicit :: XHsOuterImplicit pass
+ -- used only for Type family instances
}
| XHsOuterTyVarBndrs !(XXHsOuterTyVarBndrs pass)
=====================================
testsuite/tests/typecheck/should_compile/T25647d.hs
=====================================
@@ -0,0 +1,28 @@
+{-# LANGUAGE DataKinds, TypeFamilies, PolyKinds, MagicHash #-}
+
+module T25647d where
+
+import GHC.Exts
+import Data.Kind
+import GHC.Exts (RuntimeRep)
+import Data.Type.Equality ((:~:)(Refl) )
+
+type Cast0 :: forall (r :: RuntimeRep) (s :: RuntimeRep) (a :: RuntimeRep) (b :: RuntimeRep) -> (a :~: IntRep) -> (b :~: IntRep) -> Type -> Type
+type family Cast0 r s a b c d p where
+ Cast0 _ c _ _ Refl Refl (p->q) = Int
+
+type Cast1 :: forall (r :: RuntimeRep) (s :: RuntimeRep) (a :: RuntimeRep) (b :: RuntimeRep) -> (a :~: IntRep) -> (b :~: IntRep) -> Type -> Type
+type family Cast1 r s a b c d p where
+ Cast1 _ c _ b Refl Refl (p->q) = Int
+
+type Cast2 :: forall (r :: RuntimeRep) (s :: RuntimeRep) (a :: RuntimeRep) (b :: RuntimeRep) -> (a :~: IntRep) -> (b :~: IntRep) -> Type -> Type
+type family Cast2 r s a b c d p where
+ Cast2 _ c _ b Refl Refl (p->q) = Int
+
+type Cast3 :: forall (r :: RuntimeRep) (s :: RuntimeRep) (a :: RuntimeRep) (b :: RuntimeRep) -> (a :~: IntRep) -> (b :~: IntRep) -> Type -> Type
+type family Cast3 r s a b c d p where
+ forall. Cast3 _ c _ b Refl Refl (p->q) = Int
+
+type Cast4 :: forall (r :: RuntimeRep) (s :: RuntimeRep) (a :: RuntimeRep) (b :: RuntimeRep) -> (a :~: IntRep) -> (b :~: IntRep) -> Type -> Type
+type family Cast4 r s a b c d p where
+ forall aa cc. Cast4 aa cc _ b Refl Refl (p->q) = Int
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -937,5 +937,6 @@ test('T25597', normal, compile, [''])
test('T25647a', normal, compile, [''])
test('T25647b', normal, compile, [''])
test('T25647c', normal, compile, [''])
+test('T25647d', normal, compile, [''])
test('T25647_fail', normal, compile_fail, [''])
test('T25725', normal, compile, [''])
=====================================
utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
=====================================
@@ -483,8 +483,8 @@ reparenOuterTyVarBndrs
=> HsOuterTyVarBndrs flag a
-> HsOuterTyVarBndrs flag a
reparenOuterTyVarBndrs imp at HsOuterImplicit{} = imp
-reparenOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) =
- HsOuterExplicit x (map (mapXRec @(NoGhcTc a) reparenTyVar) exp_bndrs)
+reparenOuterTyVarBndrs (HsOuterExplicit x exp_bndrs imp_bndrs) =
+ HsOuterExplicit x (map (mapXRec @(NoGhcTc a) reparenTyVar) exp_bndrs) imp_bndrs
reparenOuterTyVarBndrs v at XHsOuterTyVarBndrs{} = v
-- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec')
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
=====================================
@@ -939,8 +939,8 @@ renameOuterTyVarBndrs
-> RnM (HsOuterTyVarBndrs flag DocNameI)
renameOuterTyVarBndrs (HsOuterImplicit{}) =
pure $ HsOuterImplicit{hso_ximplicit = noExtField}
-renameOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = exp_bndrs}) =
- HsOuterExplicit noExtField <$> mapM (renameLTyVarBndr return) exp_bndrs
+renameOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = exp_bndrs}) = do
+ HsOuterExplicit noExtField <$> mapM (renameLTyVarBndr return) exp_bndrs <*> pure NoExtField
renameWc
:: (in_thing -> RnM out_thing)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ebed7dcec5f0b07ef821d694dc251fd37d64e3a2...653aa8da0bc5d42018f2f68e57b72460f0b9a907
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ebed7dcec5f0b07ef821d694dc251fd37d64e3a2...653aa8da0bc5d42018f2f68e57b72460f0b9a907
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20250308/cdd23dde/attachment-0001.html>
More information about the ghc-commits
mailing list