[Git][ghc/ghc][wip/T24553] Print more info about kinds in error messages

Simon Peyton Jones (@simonpj) gitlab at gitlab.haskell.org
Wed Mar 20 08:59:30 UTC 2024



Simon Peyton Jones pushed to branch wip/T24553 at Glasgow Haskell Compiler / GHC


Commits:
03f78c74 by Simon Peyton Jones at 2024-03-20T08:59:14+00:00
Print more info about kinds in error messages

This fixes #24553, where GHC unhelpfully said

  error: [GHC-83865]
    • Expected kind ‘* -> * -> *’, but ‘Foo’ has kind ‘* -> * -> *’

See Note [Showing invisible bits of types in error messages]

- - - - -


9 changed files:

- compiler/GHC/Core/TyCo/Compare.hs
- compiler/GHC/Core/TyCo/Ppr.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Utils/TcType.hs
- + testsuite/tests/typecheck/should_fail/T24553.hs
- + testsuite/tests/typecheck/should_fail/T24553.stderr
- testsuite/tests/typecheck/should_fail/all.T


Changes:

=====================================
compiler/GHC/Core/TyCo/Compare.hs
=====================================
@@ -177,6 +177,13 @@ tc_eq_type keep_syns vis_only orig_ty1 orig_ty2
       && (vis_only || go env (varType tv1) (varType tv2))
       && go (rnBndr2 env tv1 tv2) ty1 ty2
 
+    -- If we have (forall a. ty1  ~   Maybe a) then respond (surprisingly)
+    -- with True; that result makes GHC print the type with all foralls and
+    -- kinds. See Note [Showing invisible bits of types in error messages]
+    -- in GHC.Tc.Errors.Ppr
+    go _ (ForAllTy {}) _ | vis_only = True
+    go _ _  (ForAllTy {})| vis_only = True
+
     -- Make sure we handle all FunTy cases since falling through to the
     -- AppTy case means that tcSplitAppTyNoView_maybe may see an unzonked
     -- kind variable, which causes things to blow up.


=====================================
compiler/GHC/Core/TyCo/Ppr.hs
=====================================
@@ -14,7 +14,7 @@ module GHC.Core.TyCo.Ppr
         pprTyVar, pprTyVars,
         pprThetaArrowTy, pprClassPred,
         pprKind, pprParendKind, pprTyLit,
-        pprDataCons, pprWithExplicitKindsWhen,
+        pprDataCons, pprWithInvisibleBitsWhen,
         pprWithTYPE, pprSourceTyCon,
 
 
@@ -330,13 +330,15 @@ pprTypeApp tc tys
     -- TODO: toIfaceTcArgs seems rather wasteful here
 
 ------------------
--- | Display all kind information (with @-fprint-explicit-kinds@) when the
--- provided 'Bool' argument is 'True'.
--- See @Note [Kind arguments in error messages]@ in "GHC.Tc.Errors".
-pprWithExplicitKindsWhen :: Bool -> SDoc -> SDoc
-pprWithExplicitKindsWhen b
+-- | Display all foralls, runtime-reps, and kind information
+-- when provided 'Bool' argument is 'True'.  See GHC.Tc.Errors.Ppr
+-- Note [Showing invisible bits of types in error messages]
+pprWithInvisibleBitsWhen :: Bool -> SDoc -> SDoc
+pprWithInvisibleBitsWhen b
   = updSDocContext $ \ctx ->
-      if b then ctx { sdocPrintExplicitKinds = True }
+      if b then ctx { sdocPrintExplicitForalls = True
+                    , sdocPrintExplicitKinds   = True
+                    , sdocPrintExplicitRuntimeReps = True }
            else ctx
 
 -- | This variant preserves any use of TYPE in a type, effectively


=====================================
compiler/GHC/Tc/Errors.hs
=====================================
@@ -2094,10 +2094,9 @@ mkMismatchMsg item ty1 ty2 =
   case orig of
     TypeEqOrigin { uo_actual, uo_expected, uo_thing = mb_thing } ->
       (TypeEqMismatch
-        { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds
-        , teq_mismatch_item = item
-        , teq_mismatch_ty1  = ty1
-        , teq_mismatch_ty2  = ty2
+        { teq_mismatch_item     = item
+        , teq_mismatch_ty1      = ty1
+        , teq_mismatch_ty2      = ty2
         , teq_mismatch_actual   = uo_actual
         , teq_mismatch_expected = uo_expected
         , teq_mismatch_what     = mb_thing
@@ -2121,25 +2120,6 @@ mkMismatchMsg item ty1 ty2 =
   where
     orig = errorItemOrigin item
     mb_same_occ = sameOccExtras ty2 ty1
-    ppr_explicit_kinds = shouldPprWithExplicitKinds ty1 ty2 orig
-
--- | Whether to print explicit kinds (with @-fprint-explicit-kinds@)
--- in an 'SDoc' when a type mismatch occurs to due invisible kind arguments.
---
--- This function first checks to see if the 'CtOrigin' argument is a
--- 'TypeEqOrigin'. If so, it first checks whether the equality is a visible
--- equality; if it's not, definitely print the kinds. Even if the equality is
--- a visible equality, check the expected/actual types to see if the types
--- have equal visible components. If the 'CtOrigin' is
--- not a 'TypeEqOrigin', fall back on the actual mismatched types themselves.
-shouldPprWithExplicitKinds :: Type -> Type -> CtOrigin -> Bool
-shouldPprWithExplicitKinds _ty1 _ty2 (TypeEqOrigin { uo_actual = act
-                                                   , uo_expected = exp
-                                                   , uo_visible = vis })
-  | not vis   = True                  -- See tests T15870, T16204c
-  | otherwise = tcEqTypeVis act exp   -- See tests T9171, T9144.
-shouldPprWithExplicitKinds ty1 ty2 _ct
-  = tcEqTypeVis ty1 ty2
 
 {- Note [Insoluble mis-match]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2403,29 +2383,6 @@ results in
       in the import of ‘Data.Monoid’
 -}
 
-{-
-Note [Kind arguments in error messages]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It can be terribly confusing to get an error message like (#9171)
-
-    Couldn't match expected type ‘GetParam Base (GetParam Base Int)’
-                with actual type ‘GetParam Base (GetParam Base Int)’
-
-The reason may be that the kinds don't match up.  Typically you'll get
-more useful information, but not when it's as a result of ambiguity.
-
-To mitigate this, GHC attempts to enable the -fprint-explicit-kinds flag
-whenever any error message arises due to a kind mismatch. This means that
-the above error message would instead be displayed as:
-
-    Couldn't match expected type
-                  ‘GetParam @* @k2 @* Base (GetParam @* @* @k2 Base Int)’
-                with actual type
-                  ‘GetParam @* @k20 @* Base (GetParam @* @* @k20 Base Int)’
-
-Which makes it clearer that the culprit is the mismatch between `k2` and `k20`.
--}
-
 -----------------------
 -- relevantBindings looks at the value environment and finds values whose
 -- types mention any of the offending type variables.  It has to be


=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -54,8 +54,8 @@ import GHC.Core.ConLike
 import GHC.Core.FamInstEnv ( FamInst(..), famInstAxiom, pprFamInst )
 import GHC.Core.InstEnv
 import GHC.Core.TyCo.Rep (Type(..))
-import GHC.Core.TyCo.Ppr (pprWithExplicitKindsWhen,
-                          pprSourceTyCon, pprTyVars, pprWithTYPE, pprTyVar, pprTidiedType)
+import GHC.Core.TyCo.Ppr (pprWithInvisibleBitsWhen, pprSourceTyCon,
+                          pprTyVars, pprWithTYPE, pprTyVar, pprTidiedType)
 import GHC.Core.PatSyn ( patSynName, pprPatSynType )
 import GHC.Core.Predicate
 import GHC.Core.Type
@@ -536,7 +536,7 @@ instance Diagnostic TcRnMessage where
                                 , text "cannot be inferred from the right-hand side." ]
                      in (injectivityErrorHerald $$ body $$ text "In the type family equation:", show_kinds)
 
-         in mkSimpleDecorated $ pprWithExplicitKindsWhen show_kinds $
+         in mkSimpleDecorated $ pprWithInvisibleBitsWhen show_kinds $
               hang herald
                 2 (vcat (map (pprCoAxBranchUser fam_tc) (eqn1 : rest_eqns)))
     TcRnBangOnUnliftedType ty
@@ -1182,7 +1182,7 @@ instance Diagnostic TcRnMessage where
                 ppr con <+> dcolon <+> ppr (dataConDisplayType True con))
               IsGADT ->
                 (text "A newtype must not be a GADT",
-                ppr con <+> dcolon <+> pprWithExplicitKindsWhen sneaky_eq_spec
+                ppr con <+> dcolon <+> pprWithInvisibleBitsWhen sneaky_eq_spec
                                        (ppr $ dataConDisplayType show_linear_types con))
               HasConstructorContext ->
                 (text "A newtype constructor must not have a context in its type",
@@ -1432,7 +1432,7 @@ instance Diagnostic TcRnMessage where
             , text "Perhaps enable PolyKinds or add a kind signature" ])
     TcRnUninferrableTyVar tidied_tvs context ->
       mkSimpleDecorated $
-      pprWithExplicitKindsWhen True $
+      pprWithInvisibleBitsWhen True $
       vcat [ text "Uninferrable type variable"
               <> plural tidied_tvs
               <+> pprWithCommas pprTyVar tidied_tvs
@@ -1440,7 +1440,7 @@ instance Diagnostic TcRnMessage where
             , pprUninferrableTyVarCtx context ]
     TcRnSkolemEscape escapees tv orig_ty ->
       mkSimpleDecorated $
-      pprWithExplicitKindsWhen True $
+      pprWithInvisibleBitsWhen True $
       vcat [ sep [ text "Cannot generalise type; skolem" <> plural escapees
                 , quotes $ pprTyVars escapees
                 , text "would escape" <+> itsOrTheir escapees <+> text "scope"
@@ -1884,7 +1884,7 @@ instance Diagnostic TcRnMessage where
 
     TcRnInvalidDefaultedTyVar wanteds proposal bad_tvs ->
       mkSimpleDecorated $
-      pprWithExplicitKindsWhen True $
+      pprWithInvisibleBitsWhen True $
       vcat [ text "Invalid defaulting proposal."
            , hang (text "The following type variable" <> plural (NE.toList bad_tvs) <+> text "cannot be defaulted, as" <+> why <> colon)
                 2 (pprQuotedList (NE.toList bad_tvs))
@@ -4146,17 +4146,18 @@ pprMismatchMsg _
               | otherwise       = text "kind" <+> quotes (ppr exp)
 
 pprMismatchMsg ctxt
-  (TypeEqMismatch { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds
-                  , teq_mismatch_item     = item
+  (TypeEqMismatch { teq_mismatch_item     = item
                   , teq_mismatch_ty1      = ty1   -- These types are the actual types
                   , teq_mismatch_ty2      = ty2   --   that don't match; may be swapped
                   , teq_mismatch_expected = exp   -- These are the context of
                   , teq_mismatch_actual   = act   --   the mis-match
                   , teq_mismatch_what     = mb_thing
                   , teq_mb_same_occ       = mb_same_occ })
-  = addArising ct_loc $ pprWithExplicitKindsWhen ppr_explicit_kinds msg
-  $$ maybe empty pprSameOccInfo mb_same_occ
+  = addArising ct_loc $
+    pprWithInvisibleBitsWhen ppr_invis_bits msg
+    $$ maybe empty pprSameOccInfo mb_same_occ
   where
+
     msg | Just (torc, rep) <- sORTKind_maybe exp
         = msg_for_exp_sort torc rep
 
@@ -4219,6 +4220,7 @@ pprMismatchMsg ctxt
     ct_loc = errorItemCtLoc item
     orig   = errorItemOrigin item
     level  = ctLocTypeOrKind_maybe ct_loc `orElse` TypeLevel
+    ppr_invis_bits = shouldPprWithInvisibleBits ty1 ty2 orig
 
     num_args_msg = case level of
       KindLevel
@@ -4310,6 +4312,59 @@ pprMismatchMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra)
         _        -> pprTheta wanteds
 
 
+-- | Whether to print explicit kinds (with @-fprint-explicit-kinds@)
+-- in an 'SDoc' when a type mismatch occurs to due invisible parts of the types.
+-- See Note [Showing invisible bits of types in error messages]
+--
+-- This function first checks to see if the 'CtOrigin' argument is a
+-- 'TypeEqOrigin'. If so, it first checks whether the equality is a visible
+-- equality; if it's not, definitely print the kinds. Even if the equality is
+-- a visible equality, check the expected/actual types to see if the types
+-- have equal visible components. If the 'CtOrigin' is
+-- not a 'TypeEqOrigin', fall back on the actual mismatched types themselves.
+shouldPprWithInvisibleBits :: Type -> Type -> CtOrigin -> Bool
+shouldPprWithInvisibleBits _ty1 _ty2 (TypeEqOrigin { uo_actual = act
+                                                   , uo_expected = exp
+                                                   , uo_visible = vis })
+  | not vis   = True                  -- See tests T15870, T16204c
+  | otherwise = tcEqTypeVis act exp   -- See tests T9171, T9144.
+shouldPprWithInvisibleBits ty1 ty2 _ct
+  = tcEqTypeVis ty1 ty2
+
+{- Note [Showing invisible bits of types in error messages]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It can be terribly confusing to get an error message like (#9171)
+
+    Couldn't match expected type ‘GetParam Base (GetParam Base Int)’
+                with actual type ‘GetParam Base (GetParam Base Int)’
+
+The reason may be that the kinds don't match up.  Typically you'll get
+more useful information, but not when it's as a result of ambiguity.
+
+To mitigate this, when find a type or kind mis-match:
+
+* See if normally-visible parts of the type would make the two types
+  look different.  This check is made by `GHC.Core.TyCo.Compare.tcEqTypeVis`
+
+* If not, display the types with their normally-visible parts made visible,
+  by setting flags in the `SDocContext":
+  Specifically:
+    - Display kind arguments: sdocPrintExplicitKinds
+    - Display foralls: sdocPrintExplicitForalls
+    - Don't default away runtime-reps: sdocPrintExplicitRuntimeReps,
+           which controls `GHC.Iface.Type.hideNonStandardTypes`
+
+As a result the above error message would instead be displayed as:
+
+    Couldn't match expected type
+                  ‘GetParam @* @k2 @* Base (GetParam @* @* @k2 Base Int)’
+                with actual type
+                  ‘GetParam @* @k20 @* Base (GetParam @* @* @k20 Base Int)’
+
+Which makes it clearer that the culprit is the mismatch between `k2` and `k20`.
+
+Another example of what goes wrong without this: #24553.
+-}
 
 {- *********************************************************************
 *                                                                      *
@@ -6033,7 +6088,7 @@ pprIllegalInstance = \case
   IllegalFamilyInstance reason ->
     pprIllegalFamilyInstance reason
   IllegalFamilyApplicationInInstance inst_ty invis_arg tf_tc tf_args ->
-    pprWithExplicitKindsWhen invis_arg $
+    pprWithInvisibleBitsWhen invis_arg $
       hang (text "Illegal type synonym family application"
               <+> quotes (ppr tf_ty) <+> text "in instance" <> colon)
          2 (ppr inst_ty)
@@ -6116,7 +6171,7 @@ pprNotCovered clas
   , not_covered_invis_vis_tvs = undetermined_tvs
   , not_covered_liberal       = which_cc_failed
   } =
-  pprWithExplicitKindsWhen (isEmptyVarSet $ pSnd undetermined_tvs) $
+  pprWithInvisibleBitsWhen (isEmptyVarSet $ pSnd undetermined_tvs) $
     vcat [ sep [ text "The"
                   <+> ppWhen liberal (text "liberal")
                   <+> text "coverage condition fails in class"
@@ -6378,7 +6433,7 @@ pprInvalidAssocInstance = \case
         , text "mentions none of the type or kind variables of the class" <+>
                 quotes (ppr cls <+> hsep (map ppr (classTyVars cls)))]
   AssocTyVarsDontMatch vis fam_tc exp_tys act_tys ->
-    pprWithExplicitKindsWhen (isInvisibleForAllTyFlag vis) $
+    pprWithInvisibleBitsWhen (isInvisibleForAllTyFlag vis) $
     vcat [ text "Type indexes must match class instance head"
          , text "Expected:" <+> pp exp_tys
          , text "  Actual:" <+> pp act_tys ]
@@ -6402,7 +6457,7 @@ pprInvalidAssocDefault = \case
             let (pat_tv, pat_vis) = NE.head dups
             in (pat_vis,
                 text "Illegal duplicate variable" <+> quotes (ppr pat_tv) <+> text "in:")
-    in pprWithExplicitKindsWhen (isInvisibleForAllTyFlag pat_vis) $
+    in pprWithInvisibleBitsWhen (isInvisibleForAllTyFlag pat_vis) $
          hang main_msg
             2 (vcat [ppr_eqn, suggestion])
     where


=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -5508,8 +5508,7 @@ data MismatchMsg
   --
   -- Test cases: T1470, tcfail212.
   | TypeEqMismatch
-      { teq_mismatch_ppr_explicit_kinds :: Bool
-      , teq_mismatch_item     :: ErrorItem
+      { teq_mismatch_item     :: ErrorItem
       , teq_mismatch_ty1      :: Type
       , teq_mismatch_ty2      :: Type
       , teq_mismatch_expected :: Type -- ^ The overall expected type


=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -888,7 +888,8 @@ tcTyFamInsts = map (\(_,b,c) -> (b,c)) . tcTyFamInstsAndVis
 -- to @C@, whereas @F Bool@ is paired with 'False' since it appears an a
 -- /visible/ argument to @C at .
 --
--- See also @Note [Kind arguments in error messages]@ in "GHC.Tc.Errors".
+-- See also Note [Showing invisible bits of types in error messages]
+-- in "GHC.Tc.Errors.Ppr".
 tcTyFamInstsAndVis :: Type -> [(Bool, TyCon, [Type])]
 tcTyFamInstsAndVis = tcTyFamInstsAndVisX False
 


=====================================
testsuite/tests/typecheck/should_fail/T24553.hs
=====================================
@@ -0,0 +1,8 @@
+module T24553 where
+
+import GHC.Exts
+
+type Foo :: * -> forall r. TYPE r -> *
+newtype Foo m a = MkFoo ()
+
+type Bar = Foo :: forall r. * -> TYPE r -> *


=====================================
testsuite/tests/typecheck/should_fail/T24553.stderr
=====================================
@@ -0,0 +1,6 @@
+
+T24553.hs:8:12: error: [GHC-83865]
+    • Expected kind ‘forall (r :: RuntimeRep). * -> TYPE r -> *’,
+        but ‘Foo’ has kind ‘* -> forall (r :: RuntimeRep). TYPE r -> *’
+    • In the type ‘Foo :: forall r. * -> TYPE r -> *’
+      In the type declaration for ‘Bar’


=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -724,3 +724,5 @@ test('T17594d', normal, compile_fail, [''])
 test('T17594g', normal, compile_fail, [''])
 
 test('T24470a', normal, compile_fail, [''])
+test('T24553', normal, compile_fail, [''])
+



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/03f78c7406907cc4f7fa302070e5d19b5033aa9c
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/20240320/0a139058/attachment-0001.html>


More information about the ghc-commits mailing list