Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC

Commits:

8 changed files:

Changes:

  • compiler/GHC/Tc/Solver/Default.hs
    ... ... @@ -395,41 +395,47 @@ tryConstraintDefaulting wc
    395 395 
       | isEmptyWC wc
    396 396 
       = return wc
    397 397 
       | otherwise
    398 
    -  = do { (unif_happened, better_wc) <- reportCoarseGrainUnifications (go_wc wc)
    398 
    +  = do { (unif_happened, better_wc) <- reportCoarseGrainUnifications $
    399 
    +                                       go_wc False wc
    399 400 
              -- We may have done unifications; so solve again
    400 401 
            ; solveAgainIf unif_happened better_wc }
    401 402 
       where
    402 
    -    go_wc :: WantedConstraints -> TcS WantedConstraints
    403 
    -    go_wc wc@(WC { wc_simple = simples, wc_impl = implics })
    404 
    -      = do { simples' <- mapMaybeBagM go_simple simples
    405 
    -           ; implics' <- mapBagM go_implic implics
    403 
    +    go_wc :: Bool -> WantedConstraints -> TcS WantedConstraints
    404 
    +    -- Bool is true if there are enclosing given equalities
    405 
    +    go_wc encl_eqs wc@(WC { wc_simple = simples, wc_impl = implics })
    406 
    +      = do { simples' <- mapMaybeBagM (go_simple encl_eqs) simples
    407 
    +           ; implics' <- mapBagM (go_implic encl_eqs) implics
    406 408 
                ; return (wc { wc_simple = simples', wc_impl = implics' }) }
    407 409
    408 
    -    go_simple :: Ct -> TcS (Maybe Ct)
    409 
    -    go_simple ct = do { solved <- tryCtDefaultingStrategy ct
    410 
    -                      ; if solved then return Nothing
    411 
    -                                  else return (Just ct) }
    410 
    +    go_simple :: Bool -> Ct -> TcS (Maybe Ct)
    411 
    +    go_simple encl_eqs ct
    412 
    +      = do { solved <- tryCtDefaultingStrategy encl_eqs ct
    413 
    +           ; if solved then return Nothing
    414 
    +                       else return (Just ct) }
    412 415
    413 
    -    go_implic :: Implication -> TcS Implication
    414 
    -    -- The Maybe is because solving the CallStack constraint
    415 
    -    -- may well allow us to discard the implication entirely
    416 
    -    go_implic implic
    417 
    -      | isSolvedStatus (ic_status implic)
    416 
    +    go_implic :: Bool -> Implication -> TcS Implication
    417 
    +    go_implic encl_eqs implic@(Implic { ic_status = status, ic_wanted = wanteds
    418 
    +                                       , ic_given_eqs = given_eqs, ic_binds = binds })
    419 
    +      | isSolvedStatus status
    418 420 
           = return implic  -- Nothing to solve inside here
    419 421 
           | otherwise
    420 
    -      = do { wanteds <- setEvBindsTcS (ic_binds implic) $
    421 
    -                        -- defaultCallStack sets a binding, so
    422 
    -                        -- we must set the correct binding group
    423 
    -                        go_wc (ic_wanted implic)
    424 
    -           ; setImplicationStatus (implic { ic_wanted = wanteds }) }
    422 
    +      = do { let encl_eqs' = encl_eqs || given_eqs /= NoGivenEqs
    423 
    +
    424 
    +           ; wanteds' <- setEvBindsTcS binds $
    425 
    +                         -- defaultCallStack sets a binding, so
    426 
    +                         -- we must set the correct binding group
    427 
    +                         go_wc encl_eqs' wanteds
    428 
    +
    429 
    +           ; setImplicationStatus (implic { ic_wanted = wanteds' }) }
    425 430
    426 
    -tryCtDefaultingStrategy :: CtDefaultingStrategy
    431 
    +tryCtDefaultingStrategy :: Bool -> CtDefaultingStrategy
    427 432 
     -- The composition of all the CtDefaultingStrategies we want
    428 
    -tryCtDefaultingStrategy
    433 
    +-- The Bool is True if there are enclosing equalities
    434 
    +tryCtDefaultingStrategy encl_eqs
    429 435 
       = foldr1 combineStrategies
    430 436 
         ( defaultCallStack :|
    431 437 
           defaultExceptionContext :
    432 
    -      defaultEquality :
    438 
    +      defaultEquality encl_eqs :
    433 439 
           [] )
    434 440
    435 441 
     -- | Default @ExceptionContext@ constraints to @emptyExceptionContext@.
    ... ... @@ -459,9 +465,10 @@ defaultCallStack ct
    459 465 
       | otherwise
    460 466 
       = return False
    461 467
    462 
    -defaultEquality :: CtDefaultingStrategy
    468 
    +defaultEquality :: Bool -> CtDefaultingStrategy
    463 469 
     -- See Note [Defaulting equalities]
    464 
    -defaultEquality ct
    470 
    +-- The Bool is True if there are enclosing equalities
    471 
    +defaultEquality encl_eqs ct
    465 472 
       | EqPred eq_rel ty1 ty2 <- classifyPredType (ctPred ct)
    466 473 
       = do { -- Remember: `ct` may not be zonked;
    467 474 
              -- see (DE3) in Note [Defaulting equalities]
    ... ... @@ -477,11 +484,17 @@ defaultEquality ct
    477 484 
                           _               -> return False ;
    478 485
    479 486 
                ReprEq -- See Note [Defaulting representational equalities]
    487 
    +
    488 
    +                  -- Don't even try this for definitely-insoluble representational
    489 
    +                  -- equalities such as Int ~R# Bool.
    480 490 
                       | CIrredCan (IrredCt { ir_reason }) <- ct
    481 491 
                       , isInsolubleReason ir_reason
    482 
    -                  -- Don't do this for definitely insoluble representational
    483 
    -                  -- equalities such as Int ~R# Bool.
    484 492 
                       -> return False
    493 
    +
    494 
    +                  -- Nor if there are enclosing equalities
    495 
    +                  | encl_eqs
    496 
    +                  -> return False
    497 
    +
    485 498 
                       | otherwise
    486 499 
                       -> try_default_repr z_ty1 z_ty2
    487 500 
             }
    ... ... @@ -743,7 +756,7 @@ is thus as follows:
    743 756 
     representational equalities into nominal ones; we only want to default a
    744 757 
     representational equality when we can fully solve it.
    745 758
    746 
    -Note that this does not threaten principle types. Recall that the original worry
    759 
    +Note that this does not threaten principal types. Recall that the original worry
    747 760 
     (as per Note [Do not unify representational equalities]) was that we might have
    748 761
    749 762 
         [W] alpha ~R# Int

  • testsuite/tests/rep-poly/UnliftedNewtypesCoerceFail.stderr
    ... ... @@ -2,9 +2,9 @@ UnliftedNewtypesCoerceFail.hs:14:8: error: [GHC-55287]
    2 2 
         • The first argument of ‘coerce’
    3 3 
           does not have a fixed runtime representation.
    4 4 
           Its type is:
    5 
    -        a0 :: TYPE k0
    5 
    +        b0 :: TYPE k0
    6 6 
           When unifying:
    7 
    -        • a0 -> b0
    7 
    +        • b0 -> b0
    8 8 
             • x -> y
    9 9 
           Cannot unify ‘rep’ with the type variable ‘k0’
    10 10 
           because the former is not a concrete ‘RuntimeRep’.

  • testsuite/tests/typecheck/should_compile/T25266a.stderr
    1 
    -T25266a.hs:10:41: error: [GHC-25897]
    1 
    +T25266a.hs:10:39: error: [GHC-25897]
    2 2 
         • Could not deduce ‘p2 ~ p1’
    3 3 
           from the context: a ~ Int
    4 4 
             bound by a pattern with constructor: T1 :: T Int,
    ... ... @@ -10,7 +10,7 @@ T25266a.hs:10:41: error: [GHC-25897]
    10 10 
           ‘p1’ is a rigid type variable bound by
    11 11 
             the inferred type of f :: p1 -> p2 -> T a -> Int
    12 12 
             at T25266a.hs:(9,1)-(11,40)
    13 
    -    • In the expression: y
    13 
    +    • In the expression: x
    14 14 
           In the first argument of ‘length’, namely ‘[x, y]’
    15 15 
           In the expression: length [x, y]
    16 16 
         • Relevant bindings include

  • testsuite/tests/typecheck/should_fail/T22684.stderr
    1 
    -
    2 1 
     T22684.hs:8:7: error: [GHC-88464]
    3 2 
         • Found hole: _ :: r
    4 3 
           Where: ‘r’ is a rigid type variable bound by
    ... ... @@ -27,9 +26,10 @@ T22684.hs:19:16: error: [GHC-88464]
    27 26 
             (.) :: Free p b c -> Free p a b -> Free p a c
    28 27 
               (bound at T22684.hs:19:7)
    29 28 
           Constraints include
    30 
    -        b ~ (b2, c1) (from T22684.hs:19:9-12)
    31 29 
             b ~ Either a1 b1 (from T22684.hs:19:3-5)
    30 
    +        b ~ (b2, c1) (from T22684.hs:19:9-12)
    32 31 
           Valid hole fits include
    33 32 
             q :: forall r. r
    34 33 
               with q @(Free p a c)
    35 34 
               (bound at T22684.hs:8:1)
    35 
    +

  • testsuite/tests/typecheck/should_fail/T7368a.stderr
    1 
    -
    2 1 
     T7368a.hs:8:6: error: [GHC-18872]
    3 
    -    • Couldn't match kind ‘* -> *’ with ‘*’
    2 
    +    • Couldn't match kind ‘*’ with ‘* -> *’
    4 3 
           When matching types
    5 4 
             w0 :: * -> *
    6 5 
             Bad f :: *
    ... ... @@ -10,3 +9,4 @@ T7368a.hs:8:6: error: [GHC-18872]
    10 9 
           In an equation for ‘fun’: fun (Bad x) = True
    11 10 
         • Relevant bindings include
    12 11 
             fun :: f (Bad f) -> Bool (bound at T7368a.hs:8:1)
    12 
    +

  • testsuite/tests/typecheck/should_fail/T7696.stderr
    1 1 
     T7696.hs:9:6: error: [GHC-18872]
    2 
    -    • Couldn't match kind ‘* -> *’ with ‘*’
    2 
    +    • Couldn't match kind ‘*’ with ‘* -> *’
    3 3 
           When matching types
    4 4 
             m0 :: * -> *
    5 5 
             () :: *

  • testsuite/tests/typecheck/should_fail/T8603.stderr
    1 1 
     T8603.hs:33:17: error: [GHC-18872]
    2 
    -    • Couldn't match kind ‘* -> *’ with ‘*’
    2 
    +    • Couldn't match kind ‘*’ with ‘* -> *’
    3 3 
           When matching types
    4 4 
             m0 :: * -> *
    5 5 
             [a2] :: *

  • testsuite/tests/typecheck/should_fail/tcfail122.stderr
    1 
    -
    2 1 
     tcfail122.hs:9:9: error: [GHC-18872]
    3 
    -    • Couldn't match kind ‘* -> *’ with ‘*’
    2 
    +    • Couldn't match kind ‘*’ with ‘* -> *’
    4 3 
           When matching types
    5 4 
             d0 :: * -> *
    6 5 
             b :: *
    ... ... @@ -17,3 +16,4 @@ tcfail122.hs:9:9: error: [GHC-18872]
    17 16 
                    undefined :: forall (c :: (* -> *) -> *) (d :: * -> *). c d]
    18 17 
         • Relevant bindings include
    19 18 
             foo :: [a b] (bound at tcfail122.hs:8:1)
    19 
    +

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help