[commit: ghc] wip/impredicativity: Convert InstanceOf constraints to eqs. in RULES (1065f0d)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/impredicativity
Link       : http://ghc.haskell.org/trac/ghc/changeset/1065f0d539f79b4f01386d9cc7db495b6932116a/ghc

>---------------------------------------------------------------

commit 1065f0d539f79b4f01386d9cc7db495b6932116a
Author: Alejandro Serrano <trupill at gmail.com>
Date:   Fri Jun 26 10:54:59 2015 +0200

    Convert InstanceOf constraints to eqs. in RULES
    
    When type checking RULES, constraints are gathered for both
    the left-hand side and the right-hand side. In most cases, this
    leads to a bunch of InstanceOf constraints in both sides.
    Later, the constraints for the left-hand side are taken as givens
    for solving the right-hand ones. Alas, we do not know yet how to
    treat InstanceOf constraints in givens. The best solution is
    to convert them to equalities as we do for generalization prior
    to the solving.


>---------------------------------------------------------------

1065f0d539f79b4f01386d9cc7db495b6932116a
 compiler/typecheck/TcCanonical.hs |  1 +
 compiler/typecheck/TcRules.hs     | 10 ++++++++--
 compiler/typecheck/TcSimplify.hs  |  4 ++--
 3 files changed, 11 insertions(+), 4 deletions(-)

diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs
index 05d564e..5701963 100644
--- a/compiler/typecheck/TcCanonical.hs
+++ b/compiler/typecheck/TcCanonical.hs
@@ -1707,6 +1707,7 @@ can_instance_of (CInstanceOfCan { cc_ev = ev, cc_lhs = lhs, cc_rhs = rhs })
            ; traceTcS "can_instance_of/INST" (vcat [ ppr new_ev_ty, ppr new_ev_qs ])
            ; canInstanceOfNC new_ev_ty }
       _ -> stopWith ev "Given/Derived instanceOf instantiation"
+    -- case InstanceOf ty (forall qvars. Q => ty)
   | Just _ <- splitForAllTy_maybe rhs
   = case ev of
       CtWanted { ctev_evar = evar, ctev_loc = loc } ->
diff --git a/compiler/typecheck/TcRules.hs b/compiler/typecheck/TcRules.hs
index 80db8c8..9972af0 100644
--- a/compiler/typecheck/TcRules.hs
+++ b/compiler/typecheck/TcRules.hs
@@ -303,11 +303,16 @@ simplifyRule name lhs_wanted rhs_wanted
              do { -- First solve the LHS and *then* solve the RHS
                   -- See Note [Solve order for RULES]
                   lhs_resid <- solveWanteds lhs_wanted
+                ; lhs_inst <- fmap andManyCts $
+                    mapM instantiateWC (bagToList (wc_simple lhs_resid))
+                ; lhs_inst_resid <- solveWanteds lhs_resid { wc_simple = lhs_inst }
                 ; rhs_resid <- solveWanteds rhs_wanted
-                ; return (insolubleWC lhs_resid || insolubleWC rhs_resid) }
+                ; return (insolubleWC lhs_inst_resid || insolubleWC rhs_resid) }
 
        ; zonked_lhs_simples <- zonkSimples (wc_simple lhs_wanted)
-       ; let (q_cts, non_q_cts) = partitionBag quantify_me zonked_lhs_simples
+       ; (zonked_lhs_inst, _) <- runTcS $ fmap andManyCts $
+           mapM instantiateWC (bagToList zonked_lhs_simples)
+       ; let (q_cts, non_q_cts) = partitionBag quantify_me zonked_lhs_inst
              quantify_me  -- Note [RULE quantification over equalities]
                | insoluble = quantify_insol
                | otherwise = quantify_normal
@@ -325,6 +330,7 @@ simplifyRule name lhs_wanted rhs_wanted
               , text "lhs_wantd" <+> ppr lhs_wanted
               , text "rhs_wantd" <+> ppr rhs_wanted
               , text "zonked_lhs_simples" <+> ppr zonked_lhs_simples
+              , text "zonked_lhs_inst" <+> ppr zonked_lhs_inst
               , text "q_cts"      <+> ppr q_cts
               , text "non_q_cts"  <+> ppr non_q_cts ]
 
diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs
index 94b5e2f..64b6e57 100644
--- a/compiler/typecheck/TcSimplify.hs
+++ b/compiler/typecheck/TcSimplify.hs
@@ -8,8 +8,8 @@ module TcSimplify(
        simplifyTop, simplifyInteractive,
        solveWantedsTcM,
 
-       -- For Rules we need these twoo
-       solveWanteds, runTcS
+       -- For Rules we need these three
+       solveWanteds, runTcS, instantiateWC
   ) where
 
 #include "HsVersions.h"