Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC Commits: c6ea5c83 by Simon Peyton Jones at 2025-10-12T22:39:20+01:00 Error message wibbles ..plus arrange that a ~R# b is not defaulted if there are any enclosing equalities. This is a bit ad hoc Test UnliftedNewtypesCoerceFail.hs motivated this - - - - - 8 changed files: - compiler/GHC/Tc/Solver/Default.hs - testsuite/tests/rep-poly/UnliftedNewtypesCoerceFail.stderr - testsuite/tests/typecheck/should_compile/T25266a.stderr - testsuite/tests/typecheck/should_fail/T22684.stderr - testsuite/tests/typecheck/should_fail/T7368a.stderr - testsuite/tests/typecheck/should_fail/T7696.stderr - testsuite/tests/typecheck/should_fail/T8603.stderr - testsuite/tests/typecheck/should_fail/tcfail122.stderr Changes: ===================================== compiler/GHC/Tc/Solver/Default.hs ===================================== @@ -395,41 +395,47 @@ tryConstraintDefaulting wc | isEmptyWC wc = return wc | otherwise - = do { (unif_happened, better_wc) <- reportCoarseGrainUnifications (go_wc wc) + = do { (unif_happened, better_wc) <- reportCoarseGrainUnifications $ + go_wc False wc -- We may have done unifications; so solve again ; solveAgainIf unif_happened better_wc } where - go_wc :: WantedConstraints -> TcS WantedConstraints - go_wc wc@(WC { wc_simple = simples, wc_impl = implics }) - = do { simples' <- mapMaybeBagM go_simple simples - ; implics' <- mapBagM go_implic implics + go_wc :: Bool -> WantedConstraints -> TcS WantedConstraints + -- Bool is true if there are enclosing given equalities + go_wc encl_eqs wc@(WC { wc_simple = simples, wc_impl = implics }) + = do { simples' <- mapMaybeBagM (go_simple encl_eqs) simples + ; implics' <- mapBagM (go_implic encl_eqs) implics ; return (wc { wc_simple = simples', wc_impl = implics' }) } - go_simple :: Ct -> TcS (Maybe Ct) - go_simple ct = do { solved <- tryCtDefaultingStrategy ct - ; if solved then return Nothing - else return (Just ct) } + go_simple :: Bool -> Ct -> TcS (Maybe Ct) + go_simple encl_eqs ct + = do { solved <- tryCtDefaultingStrategy encl_eqs ct + ; if solved then return Nothing + else return (Just ct) } - go_implic :: Implication -> TcS Implication - -- The Maybe is because solving the CallStack constraint - -- may well allow us to discard the implication entirely - go_implic implic - | isSolvedStatus (ic_status implic) + go_implic :: Bool -> Implication -> TcS Implication + go_implic encl_eqs implic@(Implic { ic_status = status, ic_wanted = wanteds + , ic_given_eqs = given_eqs, ic_binds = binds }) + | isSolvedStatus status = return implic -- Nothing to solve inside here | otherwise - = do { wanteds <- setEvBindsTcS (ic_binds implic) $ - -- defaultCallStack sets a binding, so - -- we must set the correct binding group - go_wc (ic_wanted implic) - ; setImplicationStatus (implic { ic_wanted = wanteds }) } + = do { let encl_eqs' = encl_eqs || given_eqs /= NoGivenEqs + + ; wanteds' <- setEvBindsTcS binds $ + -- defaultCallStack sets a binding, so + -- we must set the correct binding group + go_wc encl_eqs' wanteds + + ; setImplicationStatus (implic { ic_wanted = wanteds' }) } -tryCtDefaultingStrategy :: CtDefaultingStrategy +tryCtDefaultingStrategy :: Bool -> CtDefaultingStrategy -- The composition of all the CtDefaultingStrategies we want -tryCtDefaultingStrategy +-- The Bool is True if there are enclosing equalities +tryCtDefaultingStrategy encl_eqs = foldr1 combineStrategies ( defaultCallStack :| defaultExceptionContext : - defaultEquality : + defaultEquality encl_eqs : [] ) -- | Default @ExceptionContext@ constraints to @emptyExceptionContext@. @@ -459,9 +465,10 @@ defaultCallStack ct | otherwise = return False -defaultEquality :: CtDefaultingStrategy +defaultEquality :: Bool -> CtDefaultingStrategy -- See Note [Defaulting equalities] -defaultEquality ct +-- The Bool is True if there are enclosing equalities +defaultEquality encl_eqs ct | EqPred eq_rel ty1 ty2 <- classifyPredType (ctPred ct) = do { -- Remember: `ct` may not be zonked; -- see (DE3) in Note [Defaulting equalities] @@ -477,11 +484,17 @@ defaultEquality ct _ -> return False ; ReprEq -- See Note [Defaulting representational equalities] + + -- Don't even try this for definitely-insoluble representational + -- equalities such as Int ~R# Bool. | CIrredCan (IrredCt { ir_reason }) <- ct , isInsolubleReason ir_reason - -- Don't do this for definitely insoluble representational - -- equalities such as Int ~R# Bool. -> return False + + -- Nor if there are enclosing equalities + | encl_eqs + -> return False + | otherwise -> try_default_repr z_ty1 z_ty2 } @@ -743,7 +756,7 @@ is thus as follows: representational equalities into nominal ones; we only want to default a representational equality when we can fully solve it. -Note that this does not threaten principle types. Recall that the original worry +Note that this does not threaten principal types. Recall that the original worry (as per Note [Do not unify representational equalities]) was that we might have [W] alpha ~R# Int ===================================== testsuite/tests/rep-poly/UnliftedNewtypesCoerceFail.stderr ===================================== @@ -2,9 +2,9 @@ UnliftedNewtypesCoerceFail.hs:14:8: error: [GHC-55287] • The first argument of ‘coerce’ does not have a fixed runtime representation. Its type is: - a0 :: TYPE k0 + b0 :: TYPE k0 When unifying: - • a0 -> b0 + • b0 -> b0 • x -> y Cannot unify ‘rep’ with the type variable ‘k0’ because the former is not a concrete ‘RuntimeRep’. ===================================== testsuite/tests/typecheck/should_compile/T25266a.stderr ===================================== @@ -1,4 +1,4 @@ -T25266a.hs:10:41: error: [GHC-25897] +T25266a.hs:10:39: error: [GHC-25897] • Could not deduce ‘p2 ~ p1’ from the context: a ~ Int bound by a pattern with constructor: T1 :: T Int, @@ -10,7 +10,7 @@ T25266a.hs:10:41: error: [GHC-25897] ‘p1’ is a rigid type variable bound by the inferred type of f :: p1 -> p2 -> T a -> Int at T25266a.hs:(9,1)-(11,40) - • In the expression: y + • In the expression: x In the first argument of ‘length’, namely ‘[x, y]’ In the expression: length [x, y] • Relevant bindings include ===================================== testsuite/tests/typecheck/should_fail/T22684.stderr ===================================== @@ -1,4 +1,3 @@ - T22684.hs:8:7: error: [GHC-88464] • Found hole: _ :: r Where: ‘r’ is a rigid type variable bound by @@ -27,9 +26,10 @@ T22684.hs:19:16: error: [GHC-88464] (.) :: Free p b c -> Free p a b -> Free p a c (bound at T22684.hs:19:7) Constraints include - b ~ (b2, c1) (from T22684.hs:19:9-12) b ~ Either a1 b1 (from T22684.hs:19:3-5) + b ~ (b2, c1) (from T22684.hs:19:9-12) Valid hole fits include q :: forall r. r with q @(Free p a c) (bound at T22684.hs:8:1) + ===================================== testsuite/tests/typecheck/should_fail/T7368a.stderr ===================================== @@ -1,6 +1,5 @@ - T7368a.hs:8:6: error: [GHC-18872] - • Couldn't match kind ‘* -> *’ with ‘*’ + • Couldn't match kind ‘*’ with ‘* -> *’ When matching types w0 :: * -> * Bad f :: * @@ -10,3 +9,4 @@ T7368a.hs:8:6: error: [GHC-18872] In an equation for ‘fun’: fun (Bad x) = True • Relevant bindings include fun :: f (Bad f) -> Bool (bound at T7368a.hs:8:1) + ===================================== testsuite/tests/typecheck/should_fail/T7696.stderr ===================================== @@ -1,5 +1,5 @@ T7696.hs:9:6: error: [GHC-18872] - • Couldn't match kind ‘* -> *’ with ‘*’ + • Couldn't match kind ‘*’ with ‘* -> *’ When matching types m0 :: * -> * () :: * ===================================== testsuite/tests/typecheck/should_fail/T8603.stderr ===================================== @@ -1,5 +1,5 @@ T8603.hs:33:17: error: [GHC-18872] - • Couldn't match kind ‘* -> *’ with ‘*’ + • Couldn't match kind ‘*’ with ‘* -> *’ When matching types m0 :: * -> * [a2] :: * ===================================== testsuite/tests/typecheck/should_fail/tcfail122.stderr ===================================== @@ -1,6 +1,5 @@ - tcfail122.hs:9:9: error: [GHC-18872] - • Couldn't match kind ‘* -> *’ with ‘*’ + • Couldn't match kind ‘*’ with ‘* -> *’ When matching types d0 :: * -> * b :: * @@ -17,3 +16,4 @@ tcfail122.hs:9:9: error: [GHC-18872] undefined :: forall (c :: (* -> *) -> *) (d :: * -> *). c d] • Relevant bindings include foo :: [a b] (bound at tcfail122.hs:8:1) + View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c6ea5c8355a2600e145f0cfb833c97d8... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c6ea5c8355a2600e145f0cfb833c97d8... You're receiving this email because of your account on gitlab.haskell.org.