[Git][ghc/ghc][wip/T25647] Add FamArgType to in AssocInstInfo
Patrick (@soulomoon)
gitlab at gitlab.haskell.org
Fri Feb 14 18:00:06 UTC 2025
Patrick pushed to branch wip/T25647 at Glasgow Haskell Compiler / GHC
Commits:
62fa41a4 by Patrick at 2025-02-15T01:59:30+08:00
Add FamArgType to in AssocInstInfo
to guide the create of tv for wildcard
- - - - -
4 changed files:
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Instance.hs
Changes:
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -142,6 +142,8 @@ import Data.List ( mapAccumL )
import Control.Monad
import Data.Tuple( swap )
import GHC.Types.SourceText
+import GHC.Tc.Instance.Class (AssocInstInfo (..), FamArgType (..),
+ buildPatsArgTypes, buildPatsFreeArgTypes)
{-
----------------------------
@@ -779,19 +781,20 @@ There is also the possibility of mentioning a wildcard
tcFamTyPats :: TyCon
-> HsFamEqnPats GhcRn -- Patterns
+ -> AssocInstInfo -- Associated instance info
-> TcM (TcType, TcKind) -- (lhs_type, lhs_kind)
-- Check the LHS of a type/data family instance
-- e.g. type instance F ty1 .. tyn = ...
-- Used for both type and data families
-tcFamTyPats fam_tc hs_pats
+tcFamTyPats fam_tc hs_pats mb_clsinfo
= do { traceTc "tcFamTyPats {" $
vcat [ ppr fam_tc, text "arity:" <+> ppr fam_arity ]
- ; mode <- mkHoleMode TypeLevel HM_FamPat
+ ; mode <- mkHoleMode TypeLevel (HM_FamPat FreeArg)
-- HM_FamPat: See Note [Wildcards in family instances] in
-- GHC.Rename.Module
; let fun_ty = mkTyConApp fam_tc []
- ; (fam_app, res_kind) <- tcInferTyApps mode lhs_fun fun_ty hs_pats
+ ; (fam_app, res_kind) <- tcInferTyApps mode lhs_fun fun_ty (buildPatsArgTypes mb_clsinfo hs_pats)
-- Hack alert: see Note [tcFamTyPats: zonking the result kind]
; res_kind <- liftZonkM $ zonkTcType res_kind
@@ -885,7 +888,7 @@ tcInferLHsTypeUnsaturated hs_ty
; case splitHsAppTys_maybe (unLoc hs_ty) of
Just (hs_fun_ty, hs_args)
-> do { (fun_ty, _ki) <- tcInferTyAppHead mode hs_fun_ty
- ; tcInferTyApps_nosat mode hs_fun_ty fun_ty hs_args }
+ ; tcInferTyApps_nosat mode hs_fun_ty fun_ty (buildPatsFreeArgTypes hs_args) }
-- Notice the 'nosat'; do not instantiate trailing
-- invisible arguments of a type family.
-- See Note [Dealing with :kind]
@@ -967,7 +970,7 @@ type HoleInfo = Maybe (TcLevel, HoleMode)
-- HoleMode says how to treat the occurrences
-- of anonymous wildcards; see tcAnonWildCardOcc
data HoleMode = HM_Sig -- Partial type signatures: f :: _ -> Int
- | HM_FamPat -- Family instances: F _ Int = Bool
+ | HM_FamPat FamArgType -- Family instances: F _ Int = Bool
| HM_VTA -- Visible type and kind application:
-- f @(Maybe _)
-- Maybe @(_ -> _)
@@ -989,9 +992,17 @@ mkHoleMode tyki hm
; return (TcTyMode { mode_tyki = tyki
, mode_holes = Just (lvl,hm) }) }
+updateFamArgType :: TcTyMode -> FamArgType -> TcTyMode
+updateFamArgType m at TcTyMode { mode_tyki = tyki, mode_holes = mh } fam_arg
+ |Just (lvl, HM_FamPat _) <- mh
+ = (TcTyMode { mode_tyki = tyki
+ , mode_holes = Just (lvl,HM_FamPat fam_arg) })
+ | otherwise
+ = m
+
instance Outputable HoleMode where
ppr HM_Sig = text "HM_Sig"
- ppr HM_FamPat = text "HM_FamPat"
+ ppr (HM_FamPat artType) = text ("HM_FamPat " ++ show artType)
ppr HM_VTA = text "HM_VTA"
ppr HM_TyAppPat = text "HM_TyAppPat"
@@ -1537,7 +1548,7 @@ tcInferTyAppHead mode ty
tc_app_ty :: TcTyMode -> HsType GhcRn -> ExpKind -> TcM TcType
tc_app_ty mode rn_ty exp_kind
= do { (fun_ty, _ki) <- tcInferTyAppHead mode hs_fun_ty
- ; (ty, infered_kind) <- tcInferTyApps mode hs_fun_ty fun_ty hs_args
+ ; (ty, infered_kind) <- tcInferTyApps mode hs_fun_ty fun_ty (buildPatsArgTypes NotAssociated hs_args)
; checkExpKind rn_ty ty infered_kind exp_kind }
where
(hs_fun_ty, hs_args) = splitHsAppTys rn_ty
@@ -1558,7 +1569,7 @@ tcInferTyApps, tcInferTyApps_nosat
:: TcTyMode
-> LHsType GhcRn -- ^ Function (for printing only)
-> TcType -- ^ Function
- -> [LHsTypeArg GhcRn] -- ^ Args
+ -> [(LHsTypeArg GhcRn, FamArgType)] -- ^ Args
-> TcM (TcType, TcKind) -- ^ (f args, result kind)
tcInferTyApps mode hs_ty fun hs_args
= do { (f_args, res_k) <- tcInferTyApps_nosat mode hs_ty fun hs_args
@@ -1590,7 +1601,7 @@ tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args
-> TcType -- Function applied to some args
-> Subst -- Applies to function kind
-> TcKind -- Function kind
- -> [LHsTypeArg GhcRn] -- Un-type-checked args
+ -> [(LHsTypeArg GhcRn, FamArgType)] -- Un-type-checked args
-> TcM (TcType, TcKind) -- Result type and its kind
-- INVARIANT: in any call (go n fun subst fun_ki args)
-- typeKind fun = subst(fun_ki)
@@ -1607,80 +1618,81 @@ tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args
---------------- No user-written args left. We're done!
([], _) -> return (fun, substTy subst fun_ki)
-
- ---------------- HsArgPar: We don't care about parens here
- (HsArgPar _ : args, _) -> go n fun subst fun_ki args
-
- ---------------- HsTypeArg: a kind application (fun @ki)
- (HsTypeArg _ hs_ki_arg : hs_args, Just (ki_binder, inner_ki)) ->
- case ki_binder of
-
- -- FunTy with PredTy on LHS, or ForAllTy with Inferred
- Named (Bndr kv Inferred) -> instantiate kv inner_ki
-
- Named (Bndr _ Specified) -> -- Visible kind application
- do { traceTc "tcInferTyApps (vis kind app)"
- (vcat [ ppr ki_binder, ppr hs_ki_arg
- , ppr (piTyBinderType ki_binder)
- , ppr subst ])
-
- ; let exp_kind = substTy subst $ piTyBinderType ki_binder
- ; arg_mode <- mkHoleMode KindLevel HM_VTA
- -- HM_VKA: see Note [Wildcards in visible kind application]
- ; ki_arg <- addErrCtxt (FunAppCtxt (FunAppCtxtTy orig_hs_ty hs_ki_arg) n) $
- tc_check_lhs_type arg_mode hs_ki_arg exp_kind
-
- ; traceTc "tcInferTyApps (vis kind app)" (ppr exp_kind)
- ; (subst', fun') <- mkAppTyM subst fun ki_binder ki_arg
- ; go (n+1) fun' subst' inner_ki hs_args }
-
- -- Attempted visible kind application (fun @ki), but fun_ki is
- -- forall k -> blah or k1 -> k2
- -- So we need a normal application. Error.
- _ -> ty_app_err hs_ki_arg $ substTy subst fun_ki
-
- -- No binder; try applying the substitution, or fail if that's not possible
- (HsTypeArg _ ki_arg : _, Nothing) -> try_again_after_substing_or $
- ty_app_err ki_arg substed_fun_ki
-
- ---------------- HsValArg: a normal argument (fun ty)
- (HsValArg _ arg : args, Just (ki_binder, inner_ki))
- -- next binder is invisible; need to instantiate it
- | Named (Bndr kv flag) <- ki_binder
- , isInvisibleForAllTyFlag flag -- ForAllTy with Inferred or Specified
- -> instantiate kv inner_ki
-
- -- "normal" case
- | otherwise
- -> do { traceTc "tcInferTyApps (vis normal app)"
- (vcat [ ppr ki_binder
- , ppr arg
- , ppr (piTyBinderType ki_binder)
- , ppr subst ])
- ; let exp_kind = substTy subst $ piTyBinderType ki_binder
- ; arg' <- addErrCtxt (FunAppCtxt (FunAppCtxtTy orig_hs_ty arg) n) $
- tc_check_lhs_type mode arg exp_kind
- ; traceTc "tcInferTyApps (vis normal app) 2" (ppr exp_kind)
- ; (subst', fun') <- mkAppTyM subst fun ki_binder arg'
- ; go (n+1) fun' subst' inner_ki args }
-
- -- no binder; try applying the substitution, or infer another arrow in fun kind
- (HsValArg _ _ : _, Nothing)
- -> try_again_after_substing_or $
- do { let arrows_needed = n_initial_val_args all_args
- ; co <- matchExpectedFunKind (HsTypeRnThing $ unLoc hs_ty) arrows_needed substed_fun_ki
-
- ; fun' <- liftZonkM $ zonkTcType (fun `mkCastTy` co)
- -- This zonk is essential, to expose the fruits
- -- of matchExpectedFunKind to the 'go' loop
-
- ; traceTc "tcInferTyApps (no binder)" $
- vcat [ ppr fun <+> dcolon <+> ppr fun_ki
- , ppr arrows_needed
- , ppr co
- , ppr fun' <+> dcolon <+> ppr (typeKind fun')]
- ; go_init n fun' all_args }
- -- Use go_init to establish go's INVARIANT
+ ((arg,famArgTy):argtys, kb) -> do
+ case (arg, kb) of
+ ---------------- HsArgPar: We don't care about parens here
+ (HsArgPar _, _) -> go n fun subst fun_ki argtys
+
+ ---------------- HsTypeArg: a kind application (fun @ki)
+ (HsTypeArg _ hs_ki_arg, Just (ki_binder, inner_ki)) ->
+ case ki_binder of
+
+ -- FunTy with PredTy on LHS, or ForAllTy with Inferred
+ Named (Bndr kv Inferred) -> instantiate kv inner_ki
+
+ Named (Bndr _ Specified) -> -- Visible kind application
+ do { traceTc "tcInferTyApps (vis kind app)"
+ (vcat [ ppr ki_binder, ppr hs_ki_arg
+ , ppr (piTyBinderType ki_binder)
+ , ppr subst ])
+
+ ; let exp_kind = substTy subst $ piTyBinderType ki_binder
+ ; arg_mode <- mkHoleMode KindLevel HM_VTA
+ -- HM_VKA: see Note [Wildcards in visible kind application]
+ ; ki_arg <- addErrCtxt (FunAppCtxt (FunAppCtxtTy orig_hs_ty hs_ki_arg) n) $
+ tc_check_lhs_type arg_mode hs_ki_arg exp_kind
+
+ ; traceTc "tcInferTyApps (vis kind app)" (ppr exp_kind)
+ ; (subst', fun') <- mkAppTyM subst fun ki_binder ki_arg
+ ; go (n+1) fun' subst' inner_ki argtys }
+
+ -- Attempted visible kind application (fun @ki), but fun_ki is
+ -- forall k -> blah or k1 -> k2
+ -- So we need a normal application. Error.
+ _ -> ty_app_err hs_ki_arg $ substTy subst fun_ki
+
+ -- No binder; try applying the substitution, or fail if that's not possible
+ (HsTypeArg _ ki_arg, Nothing) -> try_again_after_substing_or $
+ ty_app_err ki_arg substed_fun_ki
+
+ ---------------- HsValArg: a normal argument (fun ty)
+ (HsValArg _ arg, Just (ki_binder, inner_ki))
+ -- next binder is invisible; need to instantiate it
+ | Named (Bndr kv flag) <- ki_binder
+ , isInvisibleForAllTyFlag flag -- ForAllTy with Inferred or Specified
+ -> instantiate kv inner_ki
+
+ -- "normal" case
+ | otherwise
+ -> do { traceTc "tcInferTyApps (vis normal app)"
+ (vcat [ ppr ki_binder
+ , ppr arg
+ , ppr (piTyBinderType ki_binder)
+ , ppr subst ])
+ ; let exp_kind = substTy subst $ piTyBinderType ki_binder
+ ; arg' <- addErrCtxt (FunAppCtxt (FunAppCtxtTy orig_hs_ty arg) n) $
+ tc_check_lhs_type (updateFamArgType mode famArgTy) arg exp_kind
+ ; traceTc "tcInferTyApps (vis normal app) 2" (ppr exp_kind)
+ ; (subst', fun') <- mkAppTyM subst fun ki_binder arg'
+ ; go (n+1) fun' subst' inner_ki argtys }
+
+ -- no binder; try applying the substitution, or infer another arrow in fun kind
+ (HsValArg _ _, Nothing)
+ -> try_again_after_substing_or $
+ do { let arrows_needed = n_initial_val_args (fst <$> all_args)
+ ; co <- matchExpectedFunKind (HsTypeRnThing $ unLoc hs_ty) arrows_needed substed_fun_ki
+
+ ; fun' <- liftZonkM $ zonkTcType (fun `mkCastTy` co)
+ -- This zonk is essential, to expose the fruits
+ -- of matchExpectedFunKind to the 'go' loop
+
+ ; traceTc "tcInferTyApps (no binder)" $
+ vcat [ ppr fun <+> dcolon <+> ppr fun_ki
+ , ppr arrows_needed
+ , ppr co
+ , ppr fun' <+> dcolon <+> ppr (typeKind fun')]
+ ; go_init n fun' all_args }
+ -- Use go_init to establish go's INVARIANT
where
instantiate ki_binder inner_ki
= do { traceTc "tcInferTyApps (need to instantiate)"
@@ -1699,7 +1711,7 @@ tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args
zapped_subst = zapSubst subst
substed_fun_ki = substTy subst fun_ki
- hs_ty = appTypeToArg orig_hs_ty (take (n-1) orig_hs_args)
+ hs_ty = appTypeToArg orig_hs_ty (take (n-1) $ fst <$> orig_hs_args)
n_initial_val_args :: [HsArg p tm ty] -> Arity
-- Count how many leading HsValArgs we have
@@ -2231,17 +2243,22 @@ tcAnonWildCardOcc is_extra (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) }
; checkExpectedKind ty (mkTyVarTy wc_tv) wc_kind exp_kind }
where
-- See Note [Wildcard names]
- (wc_nm, mk_wc_details) = case hole_mode of
- HM_Sig -> (fsLit "w", newTauTvDetailsAtLevel)
- HM_FamPat -> (fsLit "_", newNoDefTauTvDetailsAtLevel)
- HM_VTA -> (fsLit "w", newTauTvDetailsAtLevel)
- HM_TyAppPat -> (fsLit "_", newTauTvDetailsAtLevel)
-
+ wc_nm = case hole_mode of
+ HM_Sig -> fsLit "w"
+ HM_FamPat _ -> fsLit "_"
+ HM_VTA -> fsLit "w"
+ HM_TyAppPat -> fsLit "_"
+ newSkolemTvDetailsAtLevel tclvl =
+ do { skol_info <- mkSkolemInfo FamInstSkol
+ ; return (SkolemTv skol_info tclvl False) }
+ mk_wc_details = case hole_mode of
+ HM_FamPat FreeArg -> newSkolemTvDetailsAtLevel
+ _ -> newTauTvDetailsAtLevel
emit_holes = case hole_mode of
- HM_Sig -> True
- HM_FamPat -> False
- HM_VTA -> False
- HM_TyAppPat -> False
+ HM_Sig -> True
+ HM_FamPat _ -> False
+ HM_VTA -> False
+ HM_TyAppPat -> False
tcAnonWildCardOcc is_extra _ _ _
-- mode_holes is Nothing. This means we have an anonymous wildcard
=====================================
compiler/GHC/Tc/Instance/Class.hs
=====================================
@@ -1,11 +1,14 @@
{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecordWildCards #-}
module GHC.Tc.Instance.Class (
matchGlobalInst, matchEqualityInst,
ClsInstResult(..),
InstanceWhat(..), safeOverlap, instanceReturnsDictCon,
AssocInstInfo(..), isNotAssociated,
- lookupHasFieldLabel
+ lookupHasFieldLabel, FamArgType(..), PartialAssocInstInfo,
+ buildAssocInstInfo, buildPatsArgTypes, buildPatsFreeArgTypes,
+ assocInstInfoPartialAssocInstInfo
) where
import GHC.Prelude
@@ -36,7 +39,7 @@ import GHC.Types.FieldLabel
import GHC.Types.Name.Reader
import GHC.Types.SafeHaskell
import GHC.Types.Name ( Name )
-import GHC.Types.Var.Env ( VarEnv )
+import GHC.Types.Var.Env ( VarEnv, lookupVarEnv )
import GHC.Types.Id
import GHC.Types.Var
@@ -89,7 +92,40 @@ data AssocInstInfo
-- 'GHC.Tc.Validity.checkConsistentFamInst'
, ai_inst_env :: VarEnv Type -- ^ Maps /class/ tyvars to their instance types
-- See Note [Matching in the consistent-instantiation check]
+ , ai_arg_types :: [FamArgType] -- ^ The types of the arguments to the associated type
}
+type PartialAssocInstInfo = Maybe (Class, [TyVar], VarEnv Type)
+
+assocInstInfoPartialAssocInstInfo :: AssocInstInfo -> PartialAssocInstInfo
+assocInstInfoPartialAssocInstInfo NotAssociated = Nothing
+assocInstInfoPartialAssocInstInfo (InClsInst {..}) = Just (ai_class, ai_tyvars, ai_inst_env)
+
+buildAssocInstInfo :: TyCon -> PartialAssocInstInfo -> AssocInstInfo
+buildAssocInstInfo _fam_tc Nothing = NotAssociated
+buildAssocInstInfo fam_tc (Just (cls, tvs, env)) = InClsInst cls tvs env argTypes
+ where
+ argTypes
+ = [ toArgType $ lookupVarEnv env fam_tc_tv | fam_tc_tv <- tyConTyVars fam_tc]
+ where
+ toArgType Nothing = FreeArg
+ toArgType _ = ClassArg
+
+buildPatsArgTypes :: (Outputable x) => AssocInstInfo -> [x] -> [(x, FamArgType)]
+buildPatsArgTypes NotAssociated xs = buildPatsFreeArgTypes xs
+buildPatsArgTypes (InClsInst {..}) xs =
+ assertPpr ((length ai_arg_types) == length xs)
+ (text "associated type family instance header patterns mismatch with ai_arg_types on length: "
+ <+> text "Args: "<> ppr xs <+> text "ai_arg_types:" <+> ppr xs)
+ $ zip xs ai_arg_types
+
+buildPatsFreeArgTypes :: [x] -> [(x, FamArgType)]
+buildPatsFreeArgTypes xs = (,FreeArg) <$> xs
+
+data FamArgType = ClassArg | FreeArg deriving (Eq, Show)
+
+instance Outputable FamArgType where
+ ppr ClassArg = text "ClassArg"
+ ppr FreeArg = text "FreeArg"
isNotAssociated :: AssocInstInfo -> Bool
isNotAssociated (NotAssociated {}) = True
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -49,7 +49,7 @@ import {-# SOURCE #-} GHC.Tc.TyCl.Instance( tcInstDecls1 )
import {-# SOURCE #-} GHC.Tc.Module( checkBootDeclM )
import GHC.Tc.Deriv (DerivInfo(..))
import GHC.Tc.Gen.HsType
-import GHC.Tc.Instance.Class( AssocInstInfo(..) )
+import GHC.Tc.Instance.Class( AssocInstInfo(..), PartialAssocInstInfo)
import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.TcType
import GHC.Tc.Instance.Family
@@ -3253,7 +3253,7 @@ kcTyFamInstEqn tc_fam_tc
; discardResult $
bindOuterFamEqnTKBndrs_Q_Tv outer_bndrs $
- do { (_fam_app, res_kind) <- tcFamTyPats tc_fam_tc hs_pats
+ do { (_fam_app, res_kind) <- tcFamTyPats tc_fam_tc hs_pats NotAssociated
; tcCheckLHsTypeInContext hs_rhs_ty (TheKind res_kind) }
-- Why "_Tv" here? Consider (#14066)
-- type family Bar x y where
@@ -3430,7 +3430,7 @@ tcTyFamInstEqnGuts fam_tc mb_clsinfo outer_hs_bndrs hs_pats hs_rhs_ty
; (tclvl, wanted, (outer_bndrs, (lhs_ty, rhs_ty)))
<- pushLevelAndSolveEqualitiesX "tcTyFamInstEqnGuts" $
bindOuterFamEqnTKBndrs skol_info outer_hs_bndrs $
- do { (lhs_ty, rhs_kind) <- tcFamTyPats fam_tc hs_pats
+ do { (lhs_ty, rhs_kind) <- tcFamTyPats fam_tc hs_pats mb_clsinfo
-- Ensure that the instance is consistent with its
-- parent class (#16008)
; addConsistencyConstraints mb_clsinfo lhs_ty
@@ -5539,19 +5539,19 @@ tcAddDeclCtxt :: TyClDecl GhcRn -> TcM a -> TcM a
tcAddDeclCtxt decl thing_inside
= addErrCtxt (tcMkDeclCtxt decl) thing_inside
-tcAddOpenTyFamInstCtxt :: AssocInstInfo -> TyFamInstDecl GhcRn -> TcM a -> TcM a
+tcAddOpenTyFamInstCtxt :: PartialAssocInstInfo -> TyFamInstDecl GhcRn -> TcM a -> TcM a
tcAddOpenTyFamInstCtxt mb_assoc decl
= tcAddFamInstCtxt flav (tyFamInstDeclName decl)
where
assoc = case mb_assoc of
- NotAssociated -> Nothing
- InClsInst { ai_class = cls } -> Just $ classTyCon cls
+ Nothing -> Nothing
+ Just (cls,_, _) -> Just $ classTyCon cls
flav = TyConInstFlavour
{ tyConInstFlavour = OpenFamilyFlavour IAmType assoc
, tyConInstIsDefault = False
}
-tcMkDataFamInstCtxt :: AssocInstInfo -> NewOrData -> DataFamInstDecl GhcRn -> ErrCtxtMsg
+tcMkDataFamInstCtxt :: PartialAssocInstInfo -> NewOrData -> DataFamInstDecl GhcRn -> ErrCtxtMsg
tcMkDataFamInstCtxt mb_assoc new_or_data (DataFamInstDecl { dfid_eqn = eqn })
= TyConInstCtxt (unLoc (feqn_tycon eqn))
(TyConInstFlavour
@@ -5560,10 +5560,10 @@ tcMkDataFamInstCtxt mb_assoc new_or_data (DataFamInstDecl { dfid_eqn = eqn })
})
where
assoc = case mb_assoc of
- NotAssociated -> Nothing
- InClsInst { ai_class = cls } -> Just $ classTyCon cls
+ Nothing -> Nothing
+ Just (cls,_,_) -> Just $ classTyCon cls
-tcAddDataFamInstCtxt :: AssocInstInfo -> NewOrData -> DataFamInstDecl GhcRn -> TcM a -> TcM a
+tcAddDataFamInstCtxt :: PartialAssocInstInfo -> NewOrData -> DataFamInstDecl GhcRn -> TcM a -> TcM a
tcAddDataFamInstCtxt assoc new_or_data decl
= addErrCtxt (tcMkDataFamInstCtxt assoc new_or_data decl)
=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -43,7 +43,7 @@ import GHC.Tc.Types.Constraint
import GHC.Tc.Types.Origin
import GHC.Tc.TyCl.Build
import GHC.Tc.Utils.Instantiate
-import GHC.Tc.Instance.Class( AssocInstInfo(..), isNotAssociated )
+import GHC.Tc.Instance.Class( AssocInstInfo(..), isNotAssociated, PartialAssocInstInfo, buildAssocInstInfo, assocInstInfoPartialAssocInstInfo )
import GHC.Core.Multiplicity
import GHC.Core.InstEnv
import GHC.Tc.Instance.Family
@@ -472,11 +472,11 @@ tcLocalInstDecl :: LInstDecl GhcRn
--
-- We check for respectable instance type, and context
tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl }))
- = do { fam_inst <- tcTyFamInstDecl NotAssociated (L loc decl)
+ = do { fam_inst <- tcTyFamInstDecl Nothing (L loc decl)
; return ([], [fam_inst], []) }
tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl }))
- = do { (fam_inst, m_deriv_info) <- tcDataFamInstDecl NotAssociated emptyVarEnv (L loc decl)
+ = do { (fam_inst, m_deriv_info) <- tcDataFamInstDecl Nothing emptyVarEnv (L loc decl)
; return ([], [fam_inst], maybeToList m_deriv_info) }
tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl }))
@@ -507,16 +507,15 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_ext = lwarn
fst $ splitForAllForAllTyBinders dfun_ty
visible_skol_tvs = drop n_inferred skol_tvs
- ; traceTc "tcLocalInstDecl 1" (ppr dfun_ty $$ ppr (invisibleBndrCount dfun_ty) $$ ppr skol_tvs)
+ ; traceTc "tcLocalInstDecl 1" (ppr dfun_ty $$ ppr (invisibleBndrCount dfun_ty) $$ ppr skol_tvs
+ $$ ppr (classTyVars clas))
-- Next, process any associated types.
; (datafam_stuff, tyfam_insts)
<- tcExtendNameTyVarEnv tv_skol_prs $
do { let mini_env = mkVarEnv (classTyVars clas `zip` substTys subst inst_tys)
mini_subst = mkTvSubst (mkInScopeSet (mkVarSet skol_tvs)) mini_env
- mb_info = InClsInst { ai_class = clas
- , ai_tyvars = visible_skol_tvs
- , ai_inst_env = mini_env }
+ mb_info = Just ( clas, visible_skol_tvs, mini_env)
; df_stuff <- mapAndRecoverM (tcDataFamInstDecl mb_info tv_skol_env) adts
; tf_insts1 <- mapAndRecoverM (tcTyFamInstDecl mb_info) ats
@@ -586,15 +585,16 @@ lot of kinding and type checking code with ordinary algebraic data types (and
GADTs).
-}
-tcTyFamInstDecl :: AssocInstInfo
+tcTyFamInstDecl :: PartialAssocInstInfo
-> LTyFamInstDecl GhcRn -> TcM FamInst
-- "type instance"; open type families only
-- See Note [Associated type instances]
-tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
+tcTyFamInstDecl partial_mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
= setSrcSpanA loc $
- tcAddOpenTyFamInstCtxt mb_clsinfo decl $
+ tcAddOpenTyFamInstCtxt partial_mb_clsinfo decl $
do { let fam_lname = feqn_tycon eqn
; fam_tc <- tcLookupLocatedTyCon fam_lname
+ ; let mb_clsinfo = buildAssocInstInfo fam_tc partial_mb_clsinfo
; tcFamInstDeclChecks mb_clsinfo IAmType fam_tc
-- (0) Check it's an open type family
@@ -681,7 +681,7 @@ than type family instances
-}
tcDataFamInstDecl ::
- AssocInstInfo
+ PartialAssocInstInfo
-> TyVarEnv Name -- If this is an associated data family instance, maps the
-- parent class's skolemized type variables to their
-- original Names. If this is a non-associated instance,
@@ -689,7 +689,7 @@ tcDataFamInstDecl ::
-- See Note [Associated data family instances and di_scoped_tvs].
-> LDataFamInstDecl GhcRn -> TcM (FamInst, Maybe DerivInfo)
-- "newtype instance" and "data instance"
-tcDataFamInstDecl mb_clsinfo tv_skol_env
+tcDataFamInstDecl partial_mb_clsinfo tv_skol_env
(L loc decl@(DataFamInstDecl { dfid_eqn =
FamEqn { feqn_bndrs = outer_bndrs
, feqn_pats = hs_pats
@@ -701,9 +701,9 @@ tcDataFamInstDecl mb_clsinfo tv_skol_env
, dd_kindSig = m_ksig
, dd_derivs = derivs } }}))
= setSrcSpanA loc $
- tcAddDataFamInstCtxt mb_clsinfo new_or_data decl $
+ tcAddDataFamInstCtxt partial_mb_clsinfo new_or_data decl $
do { fam_tc <- tcLookupLocatedTyCon lfam_name
-
+ ; let mb_clsinfo = buildAssocInstInfo fam_tc partial_mb_clsinfo
; tcFamInstDeclChecks mb_clsinfo (IAmData new_or_data) fam_tc
-- Check that the family declaration is for the right kind
@@ -843,7 +843,7 @@ tcDataFamInstDecl mb_clsinfo tv_skol_env
Just $ DerivInfo { di_rep_tc = rep_tc
, di_scoped_tvs = scoped_tvs
, di_clauses = preds
- , di_ctxt = tcMkDataFamInstCtxt mb_clsinfo new_or_data decl
+ , di_ctxt = tcMkDataFamInstCtxt (assocInstInfoPartialAssocInstInfo mb_clsinfo) new_or_data decl
}
; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom
@@ -933,7 +933,7 @@ tcDataFamInstHeader mb_clsinfo skol_info fam_tc hs_outer_bndrs fixity
<- pushLevelAndSolveEqualitiesX "tcDataFamInstHeader" $
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_ty, lhs_kind) <- tcFamTyPats fam_tc hs_pats mb_clsinfo
; (lhs_applied_ty, lhs_applied_kind)
<- tcInstInvisibleTyBinders lhs_ty lhs_kind
-- See Note [Data family/instance return kinds]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/62fa41a44d6985130ba68c3eb869b610c7671316
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/62fa41a44d6985130ba68c3eb869b610c7671316
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/20250214/a494022c/attachment-0001.html>
More information about the ghc-commits
mailing list