[Git][ghc/ghc][wip/T24553] 5 commits: Type-check default declarations before deriving clauses (#24566)
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Fri Mar 22 12:12:56 UTC 2024
Simon Peyton Jones pushed to branch wip/T24553 at Glasgow Haskell Compiler / GHC
Commits:
52072f8e by Sylvain Henry at 2024-03-21T21:01:59-04:00
Type-check default declarations before deriving clauses (#24566)
See added Note and #24566. Default declarations must be type-checked
before deriving clauses.
- - - - -
7dfdf3d9 by Sylvain Henry at 2024-03-21T21:02:40-04:00
Lexer: small perf changes
- Use unsafeChr because we know our values to be valid
- Remove some unnecessary use of `ord` (return Word8 values directly)
- - - - -
864922ef by Sylvain Henry at 2024-03-21T21:02:40-04:00
JS: fix some comments
- - - - -
3e0b2b1f by Sebastian Graf at 2024-03-21T21:03:16-04:00
Simplifier: Re-do dependency analysis in abstractFloats (#24551)
In #24551, we abstracted a string literal binding over a type variable,
triggering a CoreLint error when that binding floated to top-level.
The solution implemented in this patch fixes this by re-doing dependency
analysis on a simplified recursive let binding that is about to be type
abstracted, in order to find the minimal set of type variables to abstract over.
See wrinkle (AB5) of Note [Floating and type abstraction] for more details.
Fixes #24551
- - - - -
e42aa904 by Simon Peyton Jones at 2024-03-22T12:12:29+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]
- - - - -
23 changed files:
- compiler/GHC/Core/Map/Type.hs
- compiler/GHC/Core/Opt/Simplify/Utils.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/Parser/Lexer.x
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Utils/TcType.hs
- libraries/ghc-internal/src/GHC/Internal/Maybe.hs
- + testsuite/tests/simplCore/should_compile/T24551.hs
- testsuite/tests/simplCore/should_compile/all.T
- testsuite/tests/typecheck/should_compile/Makefile
- + testsuite/tests/typecheck/should_compile/T24566.hs
- testsuite/tests/typecheck/should_compile/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/Opt/Simplify/Utils.hs
=====================================
@@ -85,6 +85,8 @@ import GHC.Utils.Panic
import Control.Monad ( when )
import Data.List ( sortBy )
+import GHC.Types.Name.Env
+import Data.Graph
{- *********************************************************************
* *
@@ -2108,6 +2110,27 @@ new binding is abstracted. Several points worth noting
which showed that it's harder to do polymorphic specialisation well
if there are dictionaries abstracted over unnecessary type variables.
See Note [Weird special case for SpecDict] in GHC.Core.Opt.Specialise
+
+(AB5) We do dependency analysis on recursive groups prior to determining
+ which variables to abstract over.
+ This is useful, because ANFisation in prepareBinding may float out
+ values out of a complex recursive binding, e.g.,
+ letrec { xs = g @a "blah"# ((:) 1 []) xs } in ...
+ ==> { prepareBinding }
+ letrec { foo = "blah"#
+ bar = [42]
+ xs = g @a foo bar xs } in
+ ...
+ and we don't want to abstract foo and bar over @a.
+
+ (Why is it OK to float the unlifted `foo` there?
+ See Note [Core top-level string literals] in GHC.Core;
+ it is controlled by GHC.Core.Opt.Simplify.Env.unitLetFloat.)
+
+ It is also necessary to do dependency analysis, because
+ otherwise (in #24551) we might get `foo = \@_ -> "missing"#` at the
+ top-level, and that triggers a CoreLint error because `foo` is *not*
+ manifestly a literal string.
-}
abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats
@@ -2115,15 +2138,27 @@ abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats
abstractFloats uf_opts top_lvl main_tvs floats body
= assert (notNull body_floats) $
assert (isNilOL (sfJoinFloats floats)) $
- do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats
+ do { let sccs = concatMap to_sccs body_floats
+ ; (subst, float_binds) <- mapAccumLM abstract empty_subst sccs
; return (float_binds, GHC.Core.Subst.substExpr subst body) }
where
is_top_lvl = isTopLevel top_lvl
body_floats = letFloatBinds (sfLetFloats floats)
empty_subst = GHC.Core.Subst.mkEmptySubst (sfInScope floats)
- abstract :: GHC.Core.Subst.Subst -> OutBind -> SimplM (GHC.Core.Subst.Subst, OutBind)
- abstract subst (NonRec id rhs)
+ -- See wrinkle (AB5) in Note [Which type variables to abstract over]
+ -- for why we need to re-do dependency analysis
+ to_sccs :: OutBind -> [SCC (Id, CoreExpr, VarSet)]
+ to_sccs (NonRec id e) = [AcyclicSCC (id, e, emptyVarSet)] -- emptyVarSet: abstract doesn't need it
+ to_sccs (Rec prs) = sccs
+ where
+ (ids,rhss) = unzip prs
+ sccs = depAnal (\(id,_rhs,_fvs) -> [getName id])
+ (\(_id,_rhs,fvs) -> nonDetStrictFoldVarSet ((:) . getName) [] fvs) -- Wrinkle (AB3)
+ (zip3 ids rhss (map exprFreeVars rhss))
+
+ abstract :: GHC.Core.Subst.Subst -> SCC (Id, CoreExpr, VarSet) -> SimplM (GHC.Core.Subst.Subst, OutBind)
+ abstract subst (AcyclicSCC (id, rhs, _empty_var_set))
= do { (poly_id1, poly_app) <- mk_poly1 tvs_here id
; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs'
!subst' = GHC.Core.Subst.extendIdSubst subst id poly_app
@@ -2134,7 +2169,7 @@ abstractFloats uf_opts top_lvl main_tvs floats body
-- tvs_here: see Note [Which type variables to abstract over]
tvs_here = choose_tvs (exprSomeFreeVars isTyVar rhs')
- abstract subst (Rec prs)
+ abstract subst (CyclicSCC trpls)
= do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids
; let subst' = GHC.Core.Subst.extendSubstList subst (ids `zip` poly_apps)
poly_pairs = [ mk_poly2 poly_id tvs_here rhs'
@@ -2142,15 +2177,15 @@ abstractFloats uf_opts top_lvl main_tvs floats body
, let rhs' = GHC.Core.Subst.substExpr subst' rhs ]
; return (subst', Rec poly_pairs) }
where
- (ids,rhss) = unzip prs
-
+ (ids,rhss,_fvss) = unzip3 trpls
-- tvs_here: see Note [Which type variables to abstract over]
- tvs_here = choose_tvs (mapUnionVarSet get_bind_fvs prs)
+ tvs_here = choose_tvs (mapUnionVarSet get_bind_fvs trpls)
-- See wrinkle (AB4) in Note [Which type variables to abstract over]
- get_bind_fvs (id,rhs) = tyCoVarsOfType (idType id) `unionVarSet` get_rec_rhs_tvs rhs
- get_rec_rhs_tvs rhs = nonDetStrictFoldVarSet get_tvs emptyVarSet (exprFreeVars rhs)
+ get_bind_fvs (id,_rhs,rhs_fvs) = tyCoVarsOfType (idType id) `unionVarSet` get_rec_rhs_tvs rhs_fvs
+ get_rec_rhs_tvs rhs_fvs = nonDetStrictFoldVarSet get_tvs emptyVarSet rhs_fvs
+ -- nonDet is safe because of wrinkle (AB3)
get_tvs :: Var -> VarSet -> VarSet
get_tvs var free_tvs
=====================================
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
+ [] -> (True,[])
+ (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/Parser/Lexer.x
=====================================
@@ -2814,19 +2814,19 @@ characters into single bytes.
{-# INLINE adjustChar #-}
adjustChar :: Char -> Word8
-adjustChar c = fromIntegral $ ord adj_c
- where non_graphic = '\x00'
- upper = '\x01'
- lower = '\x02'
- digit = '\x03'
- symbol = '\x04'
- space = '\x05'
- other_graphic = '\x06'
- uniidchar = '\x07'
+adjustChar c = adj_c
+ where non_graphic = 0x00
+ upper = 0x01
+ lower = 0x02
+ digit = 0x03
+ symbol = 0x04
+ space = 0x05
+ other_graphic = 0x06
+ uniidchar = 0x07
adj_c
| c <= '\x07' = non_graphic
- | c <= '\x7f' = c
+ | c <= '\x7f' = fromIntegral (ord c)
-- Alex doesn't handle Unicode, so when Unicode
-- character is encountered we output these values
-- with the actual character value hidden in the state.
@@ -2866,15 +2866,18 @@ adjustChar c = fromIntegral $ ord adj_c
--
-- See Note [Unicode in Alex] and #13986.
alexInputPrevChar :: AlexInput -> Char
-alexInputPrevChar (AI _ buf) = chr (fromIntegral (adjustChar pc))
+alexInputPrevChar (AI _ buf) = unsafeChr (fromIntegral (adjustChar pc))
where pc = prevChar buf '\n'
+unsafeChr :: Int -> Char
+unsafeChr (I# c) = C# (chr# c)
+
-- backwards compatibility for Alex 2.x
alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
alexGetChar inp = case alexGetByte inp of
Nothing -> Nothing
Just (b,i) -> c `seq` Just (c,i)
- where c = chr $ fromIntegral b
+ where c = unsafeChr $ fromIntegral b
-- See Note [Unicode in Alex]
alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)
=====================================
compiler/GHC/StgToJS/Linker/Linker.hs
=====================================
@@ -738,7 +738,7 @@ writeExterns out = writeFile (out </> "all.js.externs")
-- | Get all block dependencies for a given set of roots
--
--- Returns the update block info map and the blocks.
+-- Returns the updated block info map and the blocks.
getDeps :: Map Module LocatedBlockInfo -- ^ Block info per module
-> (Module -> IO LocatedBlockInfo) -- ^ Used to load block info if missing
-> Set ExportedFun -- ^ start here
@@ -754,7 +754,7 @@ getDeps init_infos load_info root_funs root_blocks = traverse_funs init_infos S.
-- 1. We use the BlockInfos to find the block corresponding to every
-- exported root functions.
--
- -- 2. We had these blocks to the set of root_blocks if they aren't already
+ -- 2. We add these blocks to the set of root_blocks if they aren't already
-- added to the result.
--
-- 3. Then we traverse the root_blocks to find their dependencies and we
=====================================
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/Module.hs
=====================================
@@ -709,7 +709,7 @@ tcRnHsBootDecls boot_or_sig decls
-- Typecheck type/class/instance decls
; traceTc "Tc2 (boot)" empty
; (tcg_env, inst_infos, _deriv_binds, _th_bndrs)
- <- tcTyClsInstDecls tycl_decls deriv_decls val_binds
+ <- tcTyClsInstDecls tycl_decls deriv_decls def_decls val_binds
; setGblEnv tcg_env $ do {
-- Emit Typeable bindings
@@ -1612,7 +1612,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
traceTc "Tc3" empty ;
(tcg_env, inst_infos, th_bndrs,
XValBindsLR (NValBinds deriv_binds deriv_sigs))
- <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ;
+ <- tcTyClsInstDecls tycl_decls deriv_decls default_decls val_binds ;
updLclCtxt (\tcl_env -> tcl_env { tcl_th_bndrs = th_bndrs `plusNameEnv` tcl_th_bndrs tcl_env }) $
setGblEnv tcg_env $ do {
@@ -1622,11 +1622,6 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
(fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ;
tcExtendGlobalValEnv fi_ids $ do {
- -- Default declarations
- traceTc "Tc4a" empty ;
- default_tys <- tcDefaults default_decls ;
- updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
-
-- Value declarations next.
-- It is important that we check the top-level value bindings
-- before the GHC-generated derived bindings, since the latter
@@ -1686,13 +1681,14 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
addUsedGREs NoDeprecationWarnings (bagToList fo_gres) ;
return (tcg_env', tcl_env)
- }}}}}}
+ }}}}}
tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn"
---------------------------
tcTyClsInstDecls :: [TyClGroup GhcRn]
-> [LDerivDecl GhcRn]
+ -> [LDefaultDecl GhcRn]
-> [(RecFlag, LHsBinds GhcRn)]
-> TcM (TcGblEnv, -- The full inst env
[InstInfo GhcRn], -- Source-code instance decls to
@@ -1702,16 +1698,24 @@ tcTyClsInstDecls :: [TyClGroup GhcRn]
HsValBinds GhcRn) -- Supporting bindings for derived
-- instances
-tcTyClsInstDecls tycl_decls deriv_decls binds
+tcTyClsInstDecls tycl_decls deriv_decls default_decls binds
= tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $
tcAddPatSynPlaceholders (getPatSynBinds binds) $
do { (tcg_env, inst_info, deriv_info, th_bndrs)
<- tcTyAndClassDecls tycl_decls ;
+
; setGblEnv tcg_env $ do {
+
-- With the @TyClDecl at s and @InstDecl at s checked we're ready to
-- process the deriving clauses, including data family deriving
-- clauses discovered in @tcTyAndClassDecls at .
--
+ -- But only after we've typechecked 'default' declarations.
+ -- See Note [Typechecking default declarations]
+ default_tys <- tcDefaults default_decls ;
+ updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
+
+
-- Careful to quit now in case there were instance errors, so that
-- the deriving errors don't pile up as well.
; failIfErrsM
@@ -1720,7 +1724,7 @@ tcTyClsInstDecls tycl_decls deriv_decls binds
; setGblEnv tcg_env' $ do {
failIfErrsM
; pure ( tcg_env', inst_info' ++ inst_info, th_bndrs, val_binds )
- }}}
+ }}}}
{- *********************************************************************
* *
@@ -3141,3 +3145,43 @@ mark_plugin_unsafe dflags = unless (gopt Opt_PluginTrustworthy dflags) $
pluginUnsafe =
singleMessage $
mkPlainMsgEnvelope diag_opts noSrcSpan TcRnUnsafeDueToPlugin
+
+
+-- Note [Typechecking default declarations]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Typechecking default declarations requires careful placement:
+--
+-- 1. We must check them after types (tcTyAndClassDecls) because they can refer
+-- to them. E.g.
+--
+-- data T = MkT ...
+-- default(Int, T, Integer)
+--
+-- -- or even (tested by T11974b and T2245)
+-- default(Int, T, Integer)
+-- data T = MkT ...
+--
+-- 2. We must check them before typechecking deriving clauses (tcInstDeclsDeriv)
+-- otherwise we may lookup default default types (Integer, Double) while checking
+-- deriving clauses, ignoring the default declaration.
+--
+-- Before this careful placement (#24566), compiling the following example
+-- (T24566) with "-ddump-if-trace -ddump-tc-trace" showed a call to
+-- `applyDefaultingRules` with default types set to "(Integer,Double)":
+--
+-- module M where
+--
+-- import GHC.Classes
+-- default ()
+--
+-- data Foo a = Nothing | Just a
+-- deriving (Eq, Ord)
+--
+-- This was an issue while building modules like M in the ghc-internal package
+-- because they would spuriously fail to build if the module defining Integer
+-- (ghc-bignum:GHC.Num.Integer) wasn't compiled yet and its interface not to be
+-- found. The implicit dependency between M and GHC.Num.Integer isn't known to
+-- the build system.
+-- In addition, trying to explicitly avoid the implicit dependency with `default
+-- ()` didn't work, except if *standalone* deriving was used, which was an
+-- inconsistent behavior.
=====================================
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/ghc-internal/src/GHC/Internal/Maybe.hs
=====================================
@@ -28,14 +28,5 @@ default ()
--
data Maybe a = Nothing | Just a
deriving ( Eq -- ^ @since base-2.01
-
- --, Ord -- ^ @since base-2.01
+ , Ord -- ^ @since base-2.01
)
-
--- ???
--- A non-standalone instance will slurp the interface file for GHC.Num.Integer.
- -- During simplifyInstanceContexts, a call to GHC.Tc.Utils.Env.tcGetDefaultTys
- -- apparently sees mb_defaults = Nothing and thus tries to bring in the
- -- default "default" types, including Integer. This seems wrong.
-deriving instance Ord a => Ord (Maybe a) -- ^ @since base-2.01
-
=====================================
testsuite/tests/simplCore/should_compile/T24551.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE MagicHash #-}
+module T24551 (f) where
+
+import GHC.Exts
+
+f :: a -> a
+f = repeatFB g
+
+repeatFB :: (Addr# -> (a -> a) -> a -> a) -> a -> a
+repeatFB c = let xs = c "missing"# xs in xs
+{-# INLINE [0] repeatFB #-}
+
+g :: Addr# -> (a -> a) -> a -> a
+g _ _ x = x
+{-# NOINLINE g #-}
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -514,3 +514,4 @@ test('T23209', [extra_files(['T23209_Aux.hs'])], multimod_compile, ['T23209', '-
test('T24229a', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques -dppr-cols=99999'])
test('T24229b', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques -dppr-cols=99999'])
test('T24370', normal, compile, ['-O'])
+test('T24551', normal, compile, ['-O -dcore-lint'])
=====================================
testsuite/tests/typecheck/should_compile/Makefile
=====================================
@@ -122,3 +122,7 @@ InlinePatSyn_ExplicitBidiBuilder:
InlinePatSyn_ExplicitBidiMatcher:
$(RM) -f InlinePatSyn_ExplicitBidiMatcher.o InlinePatSyn_ExplicitBidiMatcher.hi
'$(TEST_HC)' $(TEST_HC_OPTS) -c InlinePatSyn_ExplicitBidiMatcher.hs -O -dsuppress-all -ddump-simpl | sed -n '/^test/,/^$$/p' | grep -vq 'Pattern'
+
+T24566:
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c T24566.hs -fno-code -dno-typeable-binds -ddump-if-trace 2>&1 | grep Integer || true
+ # Not expecting any mention of Integer in the interface loading trace
=====================================
testsuite/tests/typecheck/should_compile/T24566.hs
=====================================
@@ -0,0 +1,7 @@
+module M where
+
+import GHC.Classes
+default ()
+
+data Foo a = Nothing | Just a
+ deriving (Eq, Ord)
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -913,3 +913,4 @@ test('T17594a', req_th, compile, [''])
test('T17594f', normal, compile, [''])
test('WarnDefaultedExceptionContext', normal, compile, ['-Wdefaulted-exception-context'])
test('T24470b', normal, compile, [''])
+test('T24566', [], makefile_test, [])
=====================================
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/f072fdcb4d6aa128bf4fd262b4523854ec075e25...e42aa90444ab522a689ba5ab211d9331103b2a5f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f072fdcb4d6aa128bf4fd262b4523854ec075e25...e42aa90444ab522a689ba5ab211d9331103b2a5f
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/20240322/afa7b066/attachment-0001.html>
More information about the ghc-commits
mailing list