[Git][ghc/ghc][wip/T24553] 3 commits: docs: Remove mention of non-existent Ord instance for Complex
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Thu Mar 21 16:20:42 UTC 2024
Simon Peyton Jones pushed to branch wip/T24553 at Glasgow Haskell Compiler / GHC
Commits:
247fc0fa by Preetham Gujjula at 2024-03-21T10:19:18-04:00
docs: Remove mention of non-existent Ord instance for Complex
The documentation for Data.Complex says that the Ord instance for Complex Float
is deficient, but there is no Ord instance for Complex a. The Eq instance for
Complex Float is similarly deficient, so we use that as an example instead.
- - - - -
6fafc51e by Andrei Borzenkov at 2024-03-21T10:19:54-04:00
Fix TH handling in `pat_to_type_pat` function (#24571)
There was missing case for `SplicePat` in `pat_to_type_at` function,
hence patterns with splicing that checked against `forall->` doesn't work
properly because they fall into the "illegal pattern" case.
Code example that is now accepted:
g :: forall a -> ()
g $([p| a |]) = ()
- - - - -
f072fdcb by Simon Peyton Jones at 2024-03-21T16:20:22+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]
- - - - -
17 changed files:
- compiler/GHC/Core/Map/Type.hs
- compiler/GHC/Core/TyCo/Compare.hs
- compiler/GHC/Core/TyCo/Ppr.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Utils/TcType.hs
- libraries/base/src/Data/Complex.hs
- + testsuite/tests/th/T24571.hs
- testsuite/tests/th/all.T
- + 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/Map/Type.hs
=====================================
@@ -228,7 +228,7 @@ eqDeBruijnType env_t1@(D env1 t1) env_t2@(D env2 t2) =
andEq TEQX e = hasCast e
andEq TEQ e = e
- -- See Note [Comparing nullary type synonyms] in GHC.Core.Type
+ -- See Note [Comparing nullary type synonyms] in GHC.Core.TyCo.Compare
go (D _ (TyConApp tc1 [])) (D _ (TyConApp tc2 []))
| tc1 == tc2
= TEQ
=====================================
compiler/GHC/Core/TyCo/Compare.hs
=====================================
@@ -12,8 +12,9 @@ module GHC.Core.TyCo.Compare (
nonDetCmpTypesX, nonDetCmpTc,
eqVarBndrs,
- pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis,
+ pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck,
tcEqTyConApps,
+ mayLookIdentical,
-- * Visiblity comparision
eqForAllVis, cmpForAllVis
@@ -22,7 +23,8 @@ module GHC.Core.TyCo.Compare (
import GHC.Prelude
-import GHC.Core.Type( typeKind, coreView, tcSplitAppTyNoView_maybe, splitAppTyNoView_maybe )
+import GHC.Core.Type( typeKind, coreView, tcSplitAppTyNoView_maybe, splitAppTyNoView_maybe
+ , isLevityTy, isRuntimeRepTy, isMultiplicityTy )
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.FVs
@@ -129,52 +131,114 @@ Cabal.
See #19226.
-}
+mayLookIdentical :: Type -> Type -> Bool
+-- | Returns True if the /visible/ part of the types
+-- might look equal, even if they are really unequal (in the invisible bits)
+-- Always safe to return True -- this affects error messages only
+mayLookIdentical orig_ty1 orig_ty2
+ = go orig_env orig_ty1 orig_ty2
+ where
+ orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2]
+
+ go :: RnEnv2 -> Type -> Type -> Bool
+ -- See Note [Comparing nullary type synonyms]
+ go _ (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 = True
+
+ go env t1 t2 | Just t1' <- coreView t1 = go env t1' t2
+ go env t1 t2 | Just t2' <- coreView t2 = go env t1 t2'
+
+ go env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2
+ go _ (LitTy lit1) (LitTy lit2) = lit1 == lit2
+ go env (CastTy t1 _) t2 = go env t1 t2
+ go env t1 (CastTy t2 _) = go env t1 t2
+ go _ (CoercionTy {}) (CoercionTy {}) = True
+
+ go env (ForAllTy (Bndr tv1 vis1) ty1)
+ (ForAllTy (Bndr tv2 vis2) ty2)
+ = vis1 `eqForAllVis` vis2 -- See Note [ForAllTy and type equality]
+ && go (rnBndr2 env tv1 tv2) ty1 ty2
+ -- Visible stuff only: ignore kinds of binders
+
+ -- If we have (forall (r::RunTimeRep). ty1 ~ blah) then respond
+ -- with True. Reason: the type pretty-printer defaults RuntimeRep
+ -- foralls (see Ghc.Iface.Type.hideNonStandardTypes). That can make,
+ -- say (forall r. TYPE r -> Type) into (Type -> Type), so it looks the
+ -- same as a very different type (#24553). By responding True, we
+ -- tell GHC (see calls of mayLookIdentical) to display without defaulting.
+ -- See Note [Showing invisible bits of types in error messages]
+ -- in GHC.Tc.Errors.Ppr
+ go _ (ForAllTy b _) _ | isDefaultableBndr b = True
+ go _ _ (ForAllTy b _) | isDefaultableBndr b = True
+
+ go env (FunTy _ w1 arg1 res1) (FunTy _ w2 arg2 res2)
+ = go env arg1 arg2 && go env res1 res2 && go env w1 w2
+ -- Visible stuff only: ignore agg kinds
+
+ -- See Note [Equality on AppTys] in GHC.Core.Type
+ go env (AppTy s1 t1) ty2
+ | Just (s2, t2) <- tcSplitAppTyNoView_maybe ty2
+ = go env s1 s2 && go env t1 t2
+ go env ty1 (AppTy s2 t2)
+ | Just (s1, t1) <- tcSplitAppTyNoView_maybe ty1
+ = go env s1 s2 && go env t1 t2
+
+ go env (TyConApp tc1 ts1) (TyConApp tc2 ts2)
+ = tc1 == tc2 && gos env (tyConBinders tc1) ts1 ts2
+
+ go _ _ _ = False
+
+ gos :: RnEnv2 -> [TyConBinder] -> [Type] -> [Type] -> Bool
+ gos _ _ [] [] = True
+ gos env bs (t1:ts1) (t2:ts2)
+ | (invisible, bs') <- case bs of
+ [] -> (False, [])
+ (b:bs) -> (isInvisibleTyConBinder b, bs)
+ = (invisible || go env t1 t2) && gos env bs' ts1 ts2
+
+ gos _ _ _ _ = False
+
+
-- | Type equality comparing both visible and invisible arguments and expanding
-- type synonyms.
tcEqTypeNoSyns :: Type -> Type -> Bool
-tcEqTypeNoSyns ta tb = tc_eq_type False False ta tb
-
--- | Like 'tcEqType', but returns True if the /visible/ part of the types
--- are equal, even if they are really unequal (in the invisible bits)
-tcEqTypeVis :: Type -> Type -> Bool
-tcEqTypeVis ty1 ty2 = tc_eq_type False True ty1 ty2
+tcEqTypeNoSyns ta tb = tc_eq_type False ta tb
-- | Like 'pickyEqTypeVis', but returns a Bool for convenience
pickyEqType :: Type -> Type -> Bool
-- Check when two types _look_ the same, _including_ synonyms.
-- So (pickyEqType String [Char]) returns False
-- This ignores kinds and coercions, because this is used only for printing.
-pickyEqType ty1 ty2 = tc_eq_type True False ty1 ty2
+pickyEqType ty1 ty2 = tc_eq_type True ty1 ty2
-- | Real worker for 'tcEqType'. No kind check!
tc_eq_type :: Bool -- ^ True <=> do not expand type synonyms
- -> Bool -- ^ True <=> compare visible args only
-> Type -> Type
-> Bool
-- Flags False, False is the usual setting for tc_eq_type
-- See Note [Computing equality on types] in Type
-tc_eq_type keep_syns vis_only orig_ty1 orig_ty2
+{-# INLINE tc_eq_type #-} -- See Note [Specialising tc_eq_type].
+tc_eq_type keep_syns orig_ty1 orig_ty2
= go orig_env orig_ty1 orig_ty2
where
+ orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2]
+
go :: RnEnv2 -> Type -> Type -> Bool
- -- See Note [Comparing nullary type synonyms] in GHC.Core.Type.
- go _ (TyConApp tc1 []) (TyConApp tc2 [])
- | tc1 == tc2
- = True
+ -- See Note [Comparing nullary type synonyms]
+ go _ (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 = True
go env t1 t2 | not keep_syns, Just t1' <- coreView t1 = go env t1' t2
go env t1 t2 | not keep_syns, Just t2' <- coreView t2 = go env t1 t2'
- go env (TyVarTy tv1) (TyVarTy tv2)
- = rnOccL env tv1 == rnOccR env tv2
-
- go _ (LitTy lit1) (LitTy lit2)
- = lit1 == lit2
+ go env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2
+ go _ (LitTy lit1) (LitTy lit2) = lit1 == lit2
+ go env (CastTy t1 _) t2 = go env t1 t2
+ go env t1 (CastTy t2 _) = go env t1 t2
+ go _ (CoercionTy {}) (CoercionTy {}) = True
go env (ForAllTy (Bndr tv1 vis1) ty1)
(ForAllTy (Bndr tv2 vis2) ty2)
= vis1 `eqForAllVis` vis2 -- See Note [ForAllTy and type equality]
- && (vis_only || go env (varType tv1) (varType tv2))
+ && go env (varType tv1) (varType tv2)
&& go (rnBndr2 env tv1 tv2) ty1 ty2
-- Make sure we handle all FunTy cases since falling through to the
@@ -183,11 +247,9 @@ tc_eq_type keep_syns vis_only orig_ty1 orig_ty2
-- See Note [Equality on FunTys] in GHC.Core.TyCo.Rep: we must check
-- kinds here
go env (FunTy _ w1 arg1 res1) (FunTy _ w2 arg2 res2)
- = kinds_eq && go env arg1 arg2 && go env res1 res2 && go env w1 w2
- where
- kinds_eq | vis_only = True
- | otherwise = go env (typeKind arg1) (typeKind arg2) &&
- go env (typeKind res1) (typeKind res2)
+ = go env (typeKind arg1) (typeKind arg2) &&
+ go env (typeKind res1) (typeKind res2) &&
+ go env arg1 arg2 && go env res1 res2 && go env w1 w2
-- See Note [Equality on AppTys] in GHC.Core.Type
go env (AppTy s1 t1) ty2
@@ -198,32 +260,24 @@ tc_eq_type keep_syns vis_only orig_ty1 orig_ty2
= go env s1 s2 && go env t1 t2
go env (TyConApp tc1 ts1) (TyConApp tc2 ts2)
- = tc1 == tc2 && gos env (tc_vis tc1) ts1 ts2
-
- go env (CastTy t1 _) t2 = go env t1 t2
- go env t1 (CastTy t2 _) = go env t1 t2
- go _ (CoercionTy {}) (CoercionTy {}) = True
+ = tc1 == tc2 && gos env ts1 ts2
go _ _ _ = False
- gos _ _ [] [] = True
- gos env (ig:igs) (t1:ts1) (t2:ts2) = (ig || go env t1 t2)
- && gos env igs ts1 ts2
- gos _ _ _ _ = False
+ gos _ [] [] = True
+ gos env (t1:ts1) (t2:ts2) = go env t1 t2 && gos env ts1 ts2
+ gos _ _ _ = False
- tc_vis :: TyCon -> [Bool] -- True for the fields we should ignore
- tc_vis tc | vis_only = inviss ++ repeat False -- Ignore invisibles
- | otherwise = repeat False -- Ignore nothing
- -- The repeat False is necessary because tycons
- -- can legitimately be oversaturated
- where
- bndrs = tyConBinders tc
- inviss = map isInvisibleTyConBinder bndrs
-
- orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2]
-
-{-# INLINE tc_eq_type #-} -- See Note [Specialising tc_eq_type].
+isDefaultableBndr :: ForAllTyBinder -> Bool
+-- This function should line up with the defaulting done
+-- by GHC.Iface.Type.defaultIfaceTyVarsOfKind
+-- See Note [Showing invisible bits of types in error messages]
+-- in GHC.Tc.Errors.Ppr
+isDefaultableBndr (Bndr tv vis)
+ = isInvisibleForAllTyFlag vis && is_defaultable (tyVarKind tv)
+ where
+ is_defaultable ki = isLevityTy ki || isRuntimeRepTy ki || isMultiplicityTy ki
-- | Do these denote the same level of visibility? 'Required'
-- arguments are visible, others are not. So this function
@@ -543,7 +597,7 @@ nonDetCmpTypeX env orig_t1 orig_t2 =
-- Returns both the resulting ordering relation between
-- the two types and whether either contains a cast.
go :: RnEnv2 -> Type -> Type -> TypeOrdering
- -- See Note [Comparing nullary type synonyms].
+ -- See Note [Comparing nullary type synonyms]
go _ (TyConApp tc1 []) (TyConApp tc2 [])
| tc1 == tc2
= TEQ
=====================================
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,14 @@ 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 { sdocPrintExplicitKinds = True
+ , sdocPrintExplicitRuntimeReps = True }
else ctx
-- | This variant preserves any use of TYPE in a type, effectively
=====================================
compiler/GHC/Core/Unify.hs
=====================================
@@ -1066,7 +1066,7 @@ unify_ty :: UMEnv
-- Respects newtypes, PredTypes
-- See Note [Computing equality on types] in GHC.Core.Type
unify_ty _env (TyConApp tc1 []) (TyConApp tc2 []) _kco
- -- See Note [Comparing nullary type synonyms] in GHC.Core.Type.
+ -- See Note [Comparing nullary type synonyms] in GHC.Core.TyCo.Compare
| tc1 == tc2
= return ()
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -1189,7 +1189,7 @@ defaultIfaceTyVarsOfKind def_rep def_mult ty = go emptyFsEnv True ty
-> IfaceType
go subs True (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty)
| isInvisibleForAllTyFlag argf -- Don't default *visible* quantification
- -- or we get the mess in #13963
+ -- or we get the mess in #13963
, Just substituted_ty <- check_substitution var_kind
= let subs' = extendFsEnv subs var substituted_ty
-- Record that we should replace it with LiftedRep/Lifted/Many,
=====================================
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,60 @@ 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 = mayLookIdentical act exp -- See tests T9171, T9144.
+shouldPprWithInvisibleBits ty1 ty2 _ct
+ = mayLookIdentical 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 we 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.mayLookIdentical`
+
+* If not, display the types with their normally-visible parts made visible,
+ by setting flags in the `SDocContext":
+ Specifically:
+ - Display kind arguments: sdocPrintExplicitKinds
+ - Don't default away runtime-reps: sdocPrintExplicitRuntimeReps,
+ which controls `GHC.Iface.Type.hideNonStandardTypes`
+ (NB: foralls are always printed by pprType, it turns out.)
+
+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 +6089,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 +6172,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 +6434,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 +6458,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/Gen/Pat.hs
=====================================
@@ -534,6 +534,9 @@ pat_to_type_pat (SigPat _ pat sig_ty)
pat_to_type_pat (ParPat _ pat)
= do { HsTP x t <- pat_to_type_pat (unLoc pat)
; return (HsTP x (noLocA (HsParTy noAnn t))) }
+pat_to_type_pat (SplicePat (HsUntypedSpliceTop mod_finalizers pat) splice) = do
+ { HsTP x t <- pat_to_type_pat pat
+ ; return (HsTP x (noLocA (HsSpliceTy (HsUntypedSpliceTop mod_finalizers t) splice))) }
pat_to_type_pat pat =
-- There are other cases to handle (ConPat, ListPat, TuplePat, etc), but these
-- would always be rejected by the unification in `tcHsTyPat`, so it's fine to
=====================================
compiler/GHC/Tc/Solver/Equality.hs
=====================================
@@ -311,7 +311,7 @@ can_eq_nc
-> Type -> Type -- RHS, after and before type-synonym expansion, resp
-> TcS (StopOrContinue (Either IrredCt EqCt))
--- See Note [Comparing nullary type synonyms] in GHC.Core.Type.
+-- See Note [Comparing nullary type synonyms] in GHC.Core.TyCo.Compare
can_eq_nc _flat _rdr_env _envs ev eq_rel ty1@(TyConApp tc1 []) _ps_ty1 (TyConApp tc2 []) _ps_ty2
| tc1 == tc2
= canEqReflexive ev eq_rel ty1
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -95,7 +95,7 @@ module GHC.Tc.Utils.TcType (
-- Re-exported from GHC.Core.TyCo.Compare
-- mainly just for back-compat reasons
eqType, eqTypes, nonDetCmpType, nonDetCmpTypes, eqTypeX,
- pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis,
+ pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, mayLookIdentical,
tcEqTyConApps, eqForAllVis, eqVarBndrs,
---------------------------------
@@ -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
=====================================
libraries/base/src/Data/Complex.hs
=====================================
@@ -62,7 +62,7 @@ infix 6 :+
-- it holds that @z == 'abs' z * 'signum' z at .
--
-- Note that `Complex`'s instances inherit the deficiencies from the type
--- parameter's. For example, @Complex Float@'s 'Ord' instance has similar
+-- parameter's. For example, @Complex Float@'s 'Eq' instance has similar
-- problems to `Float`'s.
--
-- As can be seen in the examples, the 'Foldable'
=====================================
testsuite/tests/th/T24571.hs
=====================================
@@ -0,0 +1,5 @@
+{-# LANGUAGE TemplateHaskell, RequiredTypeArguments #-}
+module T24571 where
+
+g :: forall a -> ()
+g $([p| a |]) = ()
=====================================
testsuite/tests/th/all.T
=====================================
@@ -605,3 +605,4 @@ test('T14032a', normal, compile, [''])
test('T14032e', normal, compile_fail, ['-dsuppress-uniques'])
test('ListTuplePunsTH', [only_ways(['ghci']), extra_files(['ListTuplePunsTH.hs', 'T15843a.hs'])], ghci_script, ['ListTuplePunsTH.script'])
test('T24559', normal, compile, [''])
+test('T24571', normal, compile, [''])
=====================================
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/-/compare/4c4740b22cd166bbede9683c1d7be01c096cb311...f072fdcb4d6aa128bf4fd262b4523854ec075e25
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4c4740b22cd166bbede9683c1d7be01c096cb311...f072fdcb4d6aa128bf4fd262b4523854ec075e25
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/20240321/a71b05bf/attachment-0001.html>
More information about the ghc-commits
mailing list