[Git][ghc/ghc][wip/T25647] Fix mode args passing down

[Patrick (@soulomoon)]

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


Commits:
c23dd71c by Patrick at 2025-02-15T04:12:00+08:00
Fix mode args passing down

- - - - -


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
=====================================
@@ -143,7 +143,7 @@ import Control.Monad
 import Data.Tuple( swap )
 import GHC.Types.SourceText
 import GHC.Tc.Instance.Class (AssocInstInfo (..), FamArgType (..),
-  buildPatsArgTypes, buildPatsFreeArgTypes)
+  buildPatsArgTypes, buildPatsModeTypes)
 
 {-
         ----------------------------
@@ -888,12 +888,18 @@ 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 (buildPatsFreeArgTypes hs_args) }
+                    ; tcInferTyApps_nosat mode hs_fun_ty fun_ty (buildPatsModeTypes (tcTyModeFamArgType mode) hs_args) }
                       -- Notice the 'nosat'; do not instantiate trailing
                       -- invisible arguments of a type family.
                       -- See Note [Dealing with :kind]
            Nothing -> tc_infer_lhs_type mode hs_ty }
 
+tcTyModeFamArgType :: TcTyMode -> FamArgType
+tcTyModeFamArgType (TcTyMode { mode_holes = mh })
+  = case mh of
+      Just (_, HM_FamPat artType) -> artType
+      _ -> FreeArg
+
 {- Note [Dealing with :kind]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider this GHCi command
@@ -1548,7 +1554,8 @@ 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 (buildPatsArgTypes NotAssociated hs_args)
+       ; (ty, infered_kind) <- tcInferTyApps mode hs_fun_ty fun_ty
+                                 (buildPatsModeTypes (tcTyModeFamArgType mode) hs_args)
        ; checkExpKind rn_ty ty infered_kind exp_kind }
   where
     (hs_fun_ty, hs_args) = splitHsAppTys rn_ty
@@ -1667,6 +1674,7 @@ tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args
               -> do { traceTc "tcInferTyApps (vis normal app)"
                                 (vcat [ ppr ki_binder
                                       , ppr arg
+                                      , ppr famArgTy
                                       , ppr (piTyBinderType ki_binder)
                                       , ppr subst ])
                       ; let exp_kind = substTy subst $ piTyBinderType ki_binder


=====================================
compiler/GHC/Tc/Instance/Class.hs
=====================================
@@ -7,8 +7,8 @@ module GHC.Tc.Instance.Class (
      InstanceWhat(..), safeOverlap, instanceReturnsDictCon,
      AssocInstInfo(..), isNotAssociated,
      lookupHasFieldLabel, FamArgType(..), PartialAssocInstInfo,
-     buildAssocInstInfo, buildPatsArgTypes, buildPatsFreeArgTypes,
-     assocInstInfoPartialAssocInstInfo
+     buildAssocInstInfo, buildPatsArgTypes,
+     assocInstInfoPartialAssocInstInfo, buildPatsModeTypes
   ) where
 
 import GHC.Prelude
@@ -111,15 +111,15 @@ buildAssocInstInfo fam_tc (Just (cls, tvs, env)) = InClsInst cls tvs env argType
         toArgType _ = ClassArg
 
 buildPatsArgTypes :: (Outputable x) => AssocInstInfo -> [x] -> [(x, FamArgType)]
-buildPatsArgTypes NotAssociated xs = buildPatsFreeArgTypes xs
+buildPatsArgTypes NotAssociated xs = buildPatsModeTypes FreeArg 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
+buildPatsModeTypes :: FamArgType -> [x] -> [(x, FamArgType)]
+buildPatsModeTypes fa xs = (,fa) <$> xs
 
 data FamArgType = ClassArg | FreeArg deriving (Eq, Show)
 


=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -3279,7 +3279,7 @@ tcTyFamInstEqn fam_tc mb_clsinfo
               , text "fam tc bndrs" <+> pprTyVars (tyConTyVars fam_tc)
               , case mb_clsinfo of
                   NotAssociated {} -> empty
-                  InClsInst { ai_class = cls } -> text "class" <+> ppr cls <+> pprTyVars (classTyVars cls) ]
+                  InClsInst { ai_class = cls, ai_arg_types = arg_types } -> text "class" <+> ppr cls <+> pprTyVars (classTyVars cls) <+> ppr arg_types]
 
        ; checkTyFamInstEqn fam_tc eqn_tc_name hs_pats
 


=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -517,7 +517,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_ext = lwarn
                           mini_subst = mkTvSubst (mkInScopeSet (mkVarSet 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
+                    ; tf_insts1 <- mapAndRecoverM (tcTyFamInstDecl mb_info) ats
 
                       -- Check for missing associated types and build them
                       -- from their defaults (if available)



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

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