[Git][ghc/ghc][wip/T25647] flip the classVar to TyVarTv to observe any breakage

[Patrick (@soulomoon)]

Patrick pushed to branch wip/T25647 at Glasgow Haskell Compiler / GHC


Commits:
cc2f13c6 by Patrick at 2025-02-17T05:26:13+08:00
flip the classVar to TyVarTv to observe any breakage

- - - - -


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
=====================================
@@ -1285,7 +1285,7 @@ tcHsType mode rn_ty@(HsAppKindTy{}) exp_kind = tc_app_ty mode rn_ty exp_kind
 tcHsType mode rn_ty@(HsOpTy{})      exp_kind = tc_app_ty mode rn_ty exp_kind
 
 tcHsType mode rn_ty@(HsKindSig _ ty sig) exp_kind
-  = do { let mode' = (updateFamArgType ClassArg $ mode { mode_tyki = KindLevel})
+  = do { let mode' = (updateFamArgType SigArg $ mode { mode_tyki = KindLevel})
        ; sig' <- tc_lhs_kind_sig mode' KindSigCtxt sig
                  -- We must typecheck the kind signature, and solve all
                  -- its equalities etc; from this point on we may do
@@ -2258,6 +2258,8 @@ tcAnonWildCardOcc is_extra (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) }
                HM_TyAppPat  -> fsLit "_"
      mk_wc_details = case hole_mode of
                       HM_FamPat FreeArg -> newTyVarMetaVarDetailsAtLevel
+                      HM_FamPat ClassArg -> newTyVarMetaVarDetailsAtLevel
+                      HM_FamPat SigArg -> newTauTvDetailsAtLevel
                       _ -> newTauTvDetailsAtLevel
      emit_holes = case hole_mode of
                      HM_Sig       -> True


=====================================
compiler/GHC/Tc/Instance/Class.hs
=====================================
@@ -39,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, lookupVarEnv )
+import GHC.Types.Var.Env ( VarEnv, lookupVarEnv, elemVarEnv )
 import GHC.Types.Id
 import GHC.Types.Var
 
@@ -102,13 +102,9 @@ assocInstInfoPartialAssocInstInfo (InClsInst {..}) = Just (ai_class, ai_tyvars,
 
 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
+buildAssocInstInfo fam_tc (Just (cls, tvs, env))
+  = InClsInst cls tvs env
+  [ if elemVarEnv fam_tc_tv env then ClassArg else FreeArg  | fam_tc_tv <- tyConTyVars fam_tc]
 
 buildPatsArgTypes :: (Outputable x) => AssocInstInfo -> [x] -> [(x, FamArgType)]
 buildPatsArgTypes NotAssociated xs = buildPatsModeTypes FreeArg xs
@@ -117,11 +113,12 @@ buildPatsArgTypes (InClsInst {..}) xs = zip xs (ai_arg_types ++ cycle [FreeArg])
 buildPatsModeTypes :: FamArgType -> [x] -> [(x, FamArgType)]
 buildPatsModeTypes fa xs = (,fa) <$> xs
 
-data FamArgType = ClassArg | FreeArg deriving (Eq, Show)
+data FamArgType = ClassArg | FreeArg | SigArg deriving (Eq, Show)
 
 instance Outputable FamArgType where
   ppr ClassArg = text "ClassArg"
   ppr FreeArg = text "FreeArg"
+  ppr SigArg = text "SigArg"
 
 isNotAssociated :: AssocInstInfo -> Bool
 isNotAssociated (NotAssociated {}) = True


=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -5545,7 +5545,7 @@ tcAddOpenTyFamInstCtxt mb_assoc decl
   where
     assoc = case mb_assoc of
       Nothing -> Nothing
-      Just (cls,_, _) -> Just $ classTyCon cls
+      Just (cls,_,_) -> Just $ classTyCon cls
     flav = TyConInstFlavour
          { tyConInstFlavour = OpenFamilyFlavour IAmType assoc
          , tyConInstIsDefault = False


=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -515,7 +515,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_ext = lwarn
              <- 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    = Just ( clas, visible_skol_tvs, 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
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cc2f13c60433e8af3cdacee07898a7d0363f5367

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cc2f13c60433e8af3cdacee07898a7d0363f5367
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/20250216/03977217/attachment-0001.html>