[commit: ghc] wip/redundant-constraints: Use a less fragile method for defaulting (e4c7531)

[git at git.haskell.org]

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

On branch  : wip/redundant-constraints
Link       : http://ghc.haskell.org/trac/ghc/changeset/e4c7531db4d0999fe815fdb85e1a9069017a5492/ghc

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

commit e4c7531db4d0999fe815fdb85e1a9069017a5492
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Mon Jan 5 10:53:37 2015 +0000

    Use a less fragile method for defaulting
    
    When doing top-level defaulting, in TcSimplify.applyDefaultingRules, we
    were temporarily making a unification variable equal to the default type
    (Integer, say, or Float), as a 'given', and trying to solve. But this
    relied on the unification variable being untouchable, which seems
    complicated.  It's much simpler just to generate a new set of
    constraints to solve, using newWantedEvVarNC in disambigGroup.
    
    (I tripped over an ASSERT failure, and this solved it in a robust way.)


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

e4c7531db4d0999fe815fdb85e1a9069017a5492
 compiler/typecheck/TcSimplify.hs | 60 +++++++++++++++++++++++-----------------
 1 file changed, 34 insertions(+), 26 deletions(-)

diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs
index 0c9b093..61fd591 100644
--- a/compiler/typecheck/TcSimplify.hs
+++ b/compiler/typecheck/TcSimplify.hs
@@ -101,7 +101,7 @@ simpl_top wanteds
       | isEmptyWC wc
       = return wc
       | otherwise  -- See Note [When to do type-class defaulting]
-      = do { something_happened <- applyDefaultingRules (approximateWC wc)
+      = do { something_happened <- applyDefaultingRules wc
                                    -- See Note [Top-level Defaulting Plan]
            ; if something_happened
              then do { wc_residual <- nestTcS (solveWantedsAndDrop wc)
@@ -1337,13 +1337,13 @@ to beta[1], and that means the (a ~ beta[1]) will be stuck, as it should be.
 *********************************************************************************
 -}
 
-applyDefaultingRules :: Cts -> TcS Bool
+applyDefaultingRules :: WantedConstraints -> TcS Bool
   -- True <=> I did some defaulting, reflected in ty_binds
 
 -- Return some extra derived equalities, which express the
 -- type-class default choice.
 applyDefaultingRules wanteds
-  | isEmptyBag wanteds
+  | isEmptyWC wanteds
   = return False
   | otherwise
   = do { traceTcS "applyDefaultingRules { " $
@@ -1351,8 +1351,10 @@ applyDefaultingRules wanteds
 
        ; info@(default_tys, _) <- getDefaultInfo
        ; let groups = findDefaultableGroups info wanteds
+
        ; traceTcS "findDefaultableGroups" $ vcat [ text "groups=" <+> ppr groups
                                                  , text "info=" <+> ppr info ]
+
        ; something_happeneds <- mapM (disambigGroup default_tys) groups
 
        ; traceTcS "applyDefaultingRules }" (ppr something_happeneds)
@@ -1361,19 +1363,27 @@ applyDefaultingRules wanteds
 
 findDefaultableGroups
     :: ( [Type]
-       , (Bool,Bool) )  -- (Overloaded strings, extended default rules)
-    -> Cts              -- Unsolved (wanted or derived)
-    -> [[(Ct,Class,TcTyVar)]]
+       , (Bool,Bool) )     -- (Overloaded strings, extended default rules)
+    -> WantedConstraints   -- Unsolved (wanted or derived)
+    -> [(TyVar, [Class], Cts)]
 findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds
-  | null default_tys = []
-  | otherwise        = defaultable_groups
+  | null default_tys
+  = []
+  | otherwise
+  = [ (tv, clss, listToBag (map fstOf3 group))
+    | group@((_,_,tv):_) <- groups
+    , let clss = map sndOf3 group
+    , defaultable_tyvar tv
+    , defaultable_classes clss ]
   where
-    defaultable_groups = filter is_defaultable_group groups
-    groups             = equivClasses cmp_tv unaries
-    unaries     :: [(Ct, Class, TcTyVar)]  -- (C tv) constraints
-    non_unaries :: [Ct]             -- and *other* constraints
+    simples                = approximateWC wanteds
+    (unaries, non_unaries) = partitionWith find_unary (bagToList simples)
+    groups                 = equivClasses cmp_tv unaries
+
+    groups      :: [[(Ct, Class, TcTyVar)]]  -- (C tv) constraints
+    unaries     ::  [(Ct, Class, TcTyVar)]   -- (C tv) constraints
+    non_unaries :: [Ct]                      -- and *other* constraints
 
-    (unaries, non_unaries) = partitionWith find_unary (bagToList wanteds)
         -- Finds unary type-class constraints
         -- But take account of polykinded classes like Typeable,
         -- which may look like (Typeable * (a:*))   (Trac #8931)
@@ -1392,12 +1402,10 @@ findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds
 
     cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2
 
-    is_defaultable_group ds@((_,_,tv):_)
+    defaultable_tyvar tv
         = let b1 = isTyConableTyVar tv  -- Note [Avoiding spurious errors]
               b2 = not (tv `elemVarSet` bad_tvs)
-              b4 = defaultable_classes [cls | (_,cls,_) <- ds]
-          in (b1 && b2 && b4)
-    is_defaultable_group [] = panic "defaultable_group"
+          in b1 && b2
 
     defaultable_classes clss
         | extended_defaults = any isInteractiveClass clss
@@ -1417,20 +1425,22 @@ findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds
 
 ------------------------------
 disambigGroup :: [Type]                  -- The default types
-              -> [(Ct, Class, TcTyVar)]  -- All classes of the form (C a)
+              -> (TcTyVar, [Class], Cts) -- All classes of the form (C a)
                                          --  sharing same type variable
               -> TcS Bool   -- True <=> something happened, reflected in ty_binds
 
-disambigGroup []  _grp
+disambigGroup [] _
   = return False
-disambigGroup (default_ty:default_tys) group
-  = do { traceTcS "disambigGroup {" (ppr group $$ ppr default_ty)
+disambigGroup (default_ty:default_tys) group@(the_tv, clss, wanteds)
+  = do { traceTcS "disambigGroup {" (vcat [ ppr default_ty, ppr the_tv, ppr wanteds ])
        ; fake_ev_binds_var <- TcS.newTcEvBinds
-       ; given_ev_var      <- TcS.newEvVar (mkTcEqPred (mkTyVarTy the_tv) default_ty)
        ; tclvl             <- TcS.getTcLevel
        ; success <- nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) $
-                    do { solveSimpleGivens loc [given_ev_var]
-                       ; residual_wanted <- solveSimpleWanteds wanteds
+                    do { wanted_evs <- mapM (newWantedEvVarNC loc)
+                                            [ mkClassPred cls [default_ty]
+                                            | cls <- clss ]
+                       ; residual_wanted <- solveSimpleWanteds $ listToBag $
+                                            map mkNonCanonical wanted_evs
                        ; return (isEmptyWC residual_wanted) }
 
        ; if success then
@@ -1445,8 +1455,6 @@ disambigGroup (default_ty:default_tys) group
                            (ppr default_ty)
                 ; disambigGroup default_tys group } }
   where
-    wanteds          = listToBag (map fstOf3 group)
-    ((_,_,the_tv):_) = group
     loc = CtLoc { ctl_origin = GivenOrigin UnkSkol
                 , ctl_env = panic "disambigGroup:env"
                 , ctl_depth = initialSubGoalDepth }