[Git][ghc/ghc][wip/T25647] Ensure wildcard behave correctly

[Patrick (@soulomoon)]

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


Commits:
6687b241 by Patrick at 2025-03-05T08:32:59+08:00
Ensure wildcard behave correctly

- - - - -


3 changed files:

- compiler/GHC/Tc/Gen/HsType.hs
- + testsuite/tests/typecheck/should_compile/T25647c.hs
- testsuite/tests/typecheck/should_compile/all.T


Changes:

=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -888,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 (cycle [FreeArg])}
+                    ; tcInferTyApps_nosat mode hs_fun_ty fun_ty hs_args (cycle [tcTyModeFamArgFlavour mode])}
                       -- Notice the 'nosat'; do not instantiate trailing
                       -- invisible arguments of a type family.
                       -- See Note [Dealing with :kind]
@@ -1286,6 +1286,7 @@ 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' = (updateFamArgFlavour SigArg $ mode { mode_tyki = KindLevel})
+       ; traceTc "tcHsType:sig0" (ppr ty <+> ppr (mode_holes mode'))
        ; 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
@@ -1555,7 +1556,7 @@ 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 (cycle [FreeArg])
+                                 hs_args (cycle [tcTyModeFamArgFlavour mode])
        ; checkExpKind rn_ty ty infered_kind exp_kind }
   where
     (hs_fun_ty, hs_args) = splitHsAppTys rn_ty
@@ -1610,7 +1611,7 @@ tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args fam_arg_flvs
        -> Subst        -- Applies to function kind
        -> TcKind          -- Function kind
        -> [LHsTypeArg GhcRn]    -- Un-type-checked args
-       -> [FamArgFlavour]    -- Un-type-checked args
+       -> [FamArgFlavour]    -- Flavours of the args see Note [FamArgFlavour]
        -> TcM (TcType, TcKind)  -- Result type and its kind
     -- INVARIANT: in any call (go n fun subst fun_ki args)
     --               typeKind fun  =  subst(fun_ki)
@@ -1623,7 +1624,7 @@ tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args fam_arg_flvs
     -- is apply 'fun' to an argument type.
 
     -- Dispatch on all_args first, for performance reasons
-    go n fun subst fun_ki all_args [] = error "tcInferTyApps_nosat: empty all_args"
+    go _ _ _ _ _ [] = error "tcInferTyApps: FamArgFlavour should be infinite"
     go n fun subst fun_ki all_args arg_flvs@(arg_flv:rest_arg_flvs) = case (all_args, tcSplitPiTy_maybe fun_ki) of
       ---------------- No user-written args left. We're done!
       ([], _) -> return (fun, substTy subst fun_ki)
@@ -2241,7 +2242,7 @@ tcAnonWildCardOcc is_extra (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) }
              wc_kind = mkTyVarTy kv
              wc_tv   = mkTcTyVar wc_name wc_kind wc_details
 
-       ; traceTc "tcAnonWildCardOcc" (ppr hole_lvl <+> ppr emit_holes)
+       ; traceTc "tcAnonWildCardOcc" (ppr hole_lvl <+> ppr emit_holes <+> ppr hole_mode)
        ; when emit_holes $
          emitAnonTypeHole is_extra wc_tv
          -- Why the 'when' guard?


=====================================
testsuite/tests/typecheck/should_compile/T25647c.hs
=====================================
@@ -0,0 +1,71 @@
+{-# LANGUAGE DataKinds, TypeFamilies, PolyKinds, MagicHash #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+
+module T25647c where
+
+import GHC.Exts
+import Data.Kind
+
+-- testing the behavior of anonymous wildcards in type family instances
+
+-- class position wildcard matching an non-type variable
+-- free position wildcard in the type family instance
+class CW2 a b where
+  type TW2 a b c
+  fun2 :: TW2 a b c -> Int
+instance CW2 Int Int where
+  type TW2 _ Int _ = Int
+  fun2 :: TW2 Int Int Int -> Int
+  fun2 _ = 1
+
+-- class wildcard matching an type variable
+class CW5 a b where
+  type TW5 a b
+  fun5 :: TW5 a b -> Int
+instance CW5 a Int where
+  type TW5 _ Int = Int
+  fun5 :: TW5 a Int -> Int
+  fun5 _ = 1
+
+-- class position signature wildcard matching non-type variable
+class CW3 (a :: RuntimeRep) b where
+  type TW3 (b :: TYPE a)
+  fun3 :: TW3 b -> Int
+instance CW3 'IntRep Int# where
+  type TW3 (_ :: _) = Int
+  fun3 :: TW3 Int# -> Int
+  fun3 _ = 1
+
+-- free wildcard, class wildcard, both position signature wildcard
+class CW4 b where
+  type TW4 a b
+  fun4 :: TW4 a b -> TW4 d b -> Int
+instance CW4 Int# where
+  type TW4 (_ :: _) (_ :: _) = Int
+  fun4 :: Int -> Int -> Int
+  fun4 1 _ = 1
+
+-- class position wildcard matching type variable
+-- class position signature wildcard matching type variable
+-- free position signature wildcard
+class CW7 (a :: RuntimeRep) b where
+  type TW7 (b :: TYPE a) (c :: RuntimeRep) (d::TYPE c)
+  fun7 :: TW7 b c d-> Int
+  funa7 :: TW7 b c d -> Int
+instance CW7 aa bb where
+  type TW7 (_::TYPE _) _ _ = Int
+  funa7 :: TW7 Int 'IntRep d -> Int
+  funa7 _ = 1
+  fun7 :: TW7 Int#  LiftedRep d -> Int
+  fun7 _ = 1
+
+-- class position wildcard matching non-type-variable
+-- class position signature wildcard matching non-type-variable
+-- free position signature wildcard
+class CW8 (a :: RuntimeRep) b where
+  type TW8 (b :: TYPE a) (c :: RuntimeRep) (d::TYPE c)
+  fun8 :: TW8 b c d -> Int
+instance CW8 'IntRep Int# where
+  type TW8 (_::TYPE _) _ _ = Int
+  fun8 :: TW8 Int# LiftedRep Int -> Int
+  fun8 _ = 1


=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -935,5 +935,6 @@ test('T25266b', normal, compile, [''])
 test('T25597', normal, compile, [''])
 test('T25647a', normal, compile, [''])
 test('T25647b', normal, compile, [''])
+test('T25647c', normal, compile, [''])
 test('T25647_fail', normal, compile_fail, [''])
 test('T25725', normal, compile, [''])



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

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