[Git][ghc/ghc][wip/T24978] Wibble

[Simon Peyton Jones (@simonpj)]

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


Commits:
a9123575 by Simon Peyton Jones at 2024-07-04T15:52:36+01:00
Wibble

- - - - -


1 changed file:

- compiler/GHC/Tc/Solver/Equality.hs


Changes:

=====================================
compiler/GHC/Tc/Solver/Equality.hs
=====================================
@@ -3107,26 +3107,28 @@ improveGivenLocalFunEqs funeqs_for_tc fam_tc work_args work_ev work_rhs
       | isGiven inert_ev                    -- Given/Given interaction
       , TyFamLHS _ inert_args <- inert_lhs  -- Inert item is F inert_args ~ inert_rhs
       , work_rhs `tcEqType` inert_rhs       -- Both RHSs are the same
-      , not (null pairs)
-      = -- So we have work_ev  : F work_args  ~ rhs
+      , -- So we have work_ev  : F work_args  ~ rhs
         --            inert_ev : F inert_args ~ rhs
-        do { traceTcS "improveGivenLocalFunEqs" (vcat[ ppr fam_tc <+> ppr work_args
+        let pairs :: [(CoAxiomRule, TypeEqn)]
+            pairs = tryInteractInertFam ops fam_tc work_args inert_args
+      , not (null pairs)
+      = do { traceTcS "improveGivenLocalFunEqs" (vcat[ ppr fam_tc <+> ppr work_args
                                                      , text "work_ev" <+>  ppr work_ev
                                                      , text "inert_ev" <+> ppr inert_ev
                                                      , ppr work_rhs
                                                      , ppr pairs ])
-           ; emitNewGivens (ctEvLoc inert_ev) pairs }
+           ; emitNewGivens (ctEvLoc inert_ev) (map mk_ax_co pairs) }
              -- This CtLoc for the new Givens doesn't reflect the
              -- fact that it's a combination of Givens, but I don't
              -- this that matters.
       where
-        pairs = [ (Nominal, mkAxiomRuleCo ax [combined_co])
-                | (ax, _) <- tryInteractInertFam ops fam_tc work_args inert_args
-                , let -- given_co :: F work_args  ~ rhs
-                      -- inert_co :: F inert_args ~ rhs
-                      -- the_co :: F work_args ~ F inert_args
-                      inert_co    = ctEvCoercion inert_ev
-                      combined_co = given_co `mkTransCo` mkSymCo inert_co ]
+        inert_co = ctEvCoercion inert_ev
+        mk_ax_co (ax,_) = (Nominal, mkAxiomRuleCo ax [combined_co])
+          where
+            combined_co = given_co `mkTransCo` mkSymCo inert_co
+            -- given_co :: F work_args  ~ rhs
+            -- inert_co :: F inert_args ~ rhs
+            -- the_co :: F work_args ~ F inert_args
 
     do_one _  _ = return ()
 



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

-- 
This project does not include diff previews in email notifications.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a9123575f42bd1aa00d05bf5951f05976c655343
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/20240704/5e728de5/attachment-0001.html>