[commit: ghc] wip/T11067: Wibbles (54f42f7)

[git at git.haskell.org]

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

On branch  : wip/T11067
Link       : http://ghc.haskell.org/trac/ghc/changeset/54f42f77a02f492976554a81dc922d86b5127de5/ghc

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

commit 54f42f77a02f492976554a81dc922d86b5127de5
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Dec 8 16:49:22 2015 +0000

    Wibbles


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

54f42f77a02f492976554a81dc922d86b5127de5
 compiler/typecheck/TcCanonical.hs | 12 +++++++-----
 compiler/typecheck/TcSimplify.hs  | 22 +++++++++++-----------
 compiler/utils/Bag.hs             |  2 +-
 3 files changed, 19 insertions(+), 17 deletions(-)

diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs
index 427ecfe..10e29fb 100644
--- a/compiler/typecheck/TcCanonical.hs
+++ b/compiler/typecheck/TcCanonical.hs
@@ -3,7 +3,7 @@
 module TcCanonical(
      canonicalize,
      unifyDerived,
-     makeSuperClasses, addSuperClasses,
+     makeSuperClasses, mkGivenWithSuperClasses,
      StopOrContinue(..), stopWith, continueWith
   ) where
 
@@ -360,10 +360,12 @@ Mind you, now that Wanteds cannot rewrite Derived, I think this particular
 situation can't happen.
   -}
 
-addSuperClasses :: CtEvidence -> TcS [Ct]
--- Make a Ct from this CtEvidence, but add its superclasses
--- if it's a class constraint
-addSuperClasses ev = mk_superclasses emptyNameSet ev
+mkGivenWithSuperClasses :: CtLoc -> EvId -> TcS [Ct]
+-- From a given EvId, make its Ct, plus the Ct's of its superclasses
+mkGivenWithSuperClasses loc ev_id
+  = mk_superclasses emptyNameSet (CtGiven { ctev_evar = ev_id
+                                          , ctev_pred = evVarPred ev_id
+                                          , ctev_loc  = loc })
 
 makeSuperClasses :: Ct -> TcS [Ct]
 -- Returns superclasses, transitively, see Note [The superclasses story]
diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs
index 2eb26f8..e14589f 100644
--- a/compiler/typecheck/TcSimplify.hs
+++ b/compiler/typecheck/TcSimplify.hs
@@ -33,7 +33,7 @@ import PrelNames
 import TcErrors
 import TcEvidence
 import TcInteract
-import TcCanonical   ( makeSuperClasses, addSuperClasses )
+import TcCanonical   ( makeSuperClasses, mkGivenWithSuperClasses )
 import TcMType   as TcM
 import TcRnMonad as TcRn
 import TcSMonad  as TcS
@@ -368,10 +368,14 @@ tcCheckSatisfiability :: Bag EvVar -> TcM Bool
 tcCheckSatisfiability givens
   = do { lcl_env <- TcRn.getLclEnv
        ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env
+             given_cts = [ mkNonCanonical (CtGiven { ctev_evar = ev_id
+                                                   , ctev_pred = evVarPred ev_id
+                                                   , ctev_loc  = given_loc })
+                         | ev_id <- bagToList givens ]
        ; traceTc "checkSatisfiabilty {" (ppr givens)
        ; (res, _ev_binds) <- runTcS $
-             do { cts <- solveSimpleGivens given_loc (bagToList givens)
-                ; return (not (isEmptyBag cts)) }
+             do { insols <- solveSimpleGivens given_cts
+                ; return (not (isEmptyBag insols)) }
        ; traceTc "checkSatisfiabilty }" (ppr res)
        ; return (not res) }
 
@@ -1071,7 +1075,7 @@ solveImplication :: Implication    -- Wanted
 solveImplication imp@(Implic { ic_tclvl  = tclvl
                              , ic_binds  = ev_binds
                              , ic_skols  = skols
-                             , ic_given  = givens
+                             , ic_given  = given_ids
                              , ic_wanted = wanteds
                              , ic_info   = info
                              , ic_status = status
@@ -1088,8 +1092,9 @@ solveImplication imp@(Implic { ic_tclvl  = tclvl
 
          -- Solve the nested constraints
        ; (no_given_eqs, given_insols, residual_wanted)
-             <- nestImplicTcS ev_binds tclvl $
-               do { givens_w_scs <- concatMapM (addSuperClasses . mk_given_ev) givens
+            <- nestImplicTcS ev_binds tclvl $
+               do { let loc = mkGivenLoc tclvl info env
+                  ; givens_w_scs <- concatMapM (mkGivenWithSuperClasses loc) given_ids
                   ; given_insols <- solveSimpleGivens givens_w_scs
 
                   ; residual_wanted <- solveWanteds wanteds
@@ -1121,11 +1126,6 @@ solveImplication imp@(Implic { ic_tclvl  = tclvl
              , text "implication evbinds = " <+> ppr (evBindMapBinds evbinds) ]
 
        ; return (floated_eqs, res_implic) }
-  where
-    given_loc = mkGivenLoc tclvl info env
-    mk_given_ev ev_id = CtGiven { ctev_evar = ev_id
-                                , ctev_pred = evVarPred ev_id
-                                , ctev_loc  = given_loc }
 
 ----------------------
 setImplicationStatus :: Implication -> TcS (Maybe Implication)
diff --git a/compiler/utils/Bag.hs b/compiler/utils/Bag.hs
index 357399b..d959709 100644
--- a/compiler/utils/Bag.hs
+++ b/compiler/utils/Bag.hs
@@ -20,7 +20,7 @@ module Bag (
         listToBag, bagToList, mapAccumBagL,
         foldrBagM, foldlBagM, mapBagM, mapBagM_,
         flatMapBagM, flatMapBagPairM,
-        mapAndUnzipBagM, mapAccumBagL, mapAccumBagLM
+        mapAndUnzipBagM, mapAccumBagL, mapAccumBagLM,
         mapAndUnzipBagM, mapAccumBagLM,
         anyBagM, filterBagM
     ) where