[commit: ghc] wip/redundant-constraints: wibble to robustify-defaulting (191b889)

[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/191b889ae569aebbcadd50a662e9bb8bfcd56c24/ghc

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

commit 191b889ae569aebbcadd50a662e9bb8bfcd56c24
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Mon Jan 5 11:46:49 2015 +0000

    wibble to robustify-defaulting


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

191b889ae569aebbcadd50a662e9bb8bfcd56c24
 compiler/typecheck/TcSimplify.hs | 54 ++++++++++++++++++++++++----------------
 1 file changed, 32 insertions(+), 22 deletions(-)

diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs
index 61fd591..68978df 100644
--- a/compiler/typecheck/TcSimplify.hs
+++ b/compiler/typecheck/TcSimplify.hs
@@ -20,6 +20,7 @@ import TcSMonad as TcS
 import TcInteract
 import Kind     ( isKind, isSubKind, defaultKind_maybe )
 import Inst
+import Unify    ( tcMatchTy )
 import Type     ( classifyPredType, isIPClass, PredTree(..)
                 , getClassPredTys_maybe, EqRel(..) )
 import TyCon    ( isTypeFamilyTyCon )
@@ -1365,32 +1366,31 @@ findDefaultableGroups
     :: ( [Type]
        , (Bool,Bool) )     -- (Overloaded strings, extended default rules)
     -> WantedConstraints   -- Unsolved (wanted or derived)
-    -> [(TyVar, [Class], Cts)]
+    -> [(TyVar, [Ct])]
 findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds
   | null default_tys
   = []
   | otherwise
-  = [ (tv, clss, listToBag (map fstOf3 group))
-    | group@((_,_,tv):_) <- groups
-    , let clss = map sndOf3 group
+  = [ (tv, map fstOf3 group)
+    | group@((_,_,tv):_) <- unary_groups
     , defaultable_tyvar tv
-    , defaultable_classes clss ]
+    , defaultable_classes (map sndOf3 group) ]
   where
     simples                = approximateWC wanteds
     (unaries, non_unaries) = partitionWith find_unary (bagToList simples)
-    groups                 = equivClasses cmp_tv unaries
+    unary_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
+    unary_groups :: [[(Ct, Class, TcTyVar)]]  -- (C tv) constraints
+    unaries      ::  [(Ct, Class, TcTyVar)]   -- (C tv) constraints
+    non_unaries  :: [Ct]                      -- and *other* constraints
 
         -- Finds unary type-class constraints
         -- But take account of polykinded classes like Typeable,
         -- which may look like (Typeable * (a:*))   (Trac #8931)
     find_unary cc
         | Just (cls,tys)   <- getClassPredTys_maybe (ctPred cc)
-        , Just (kinds, ty) <- snocView tys
-        , all isKind kinds
+        , Just (kinds, ty) <- snocView tys   -- Ignore kind arguments
+        , all isKind kinds                   -- for this purpose
         , Just tv <- tcGetTyVar_maybe ty
         , isMetaTyVar tv  -- We might have runtime-skolems in GHCi, and
                           -- we definitely don't want to try to assign to those!
@@ -1424,24 +1424,19 @@ findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds
     -- Similarly is_std_class
 
 ------------------------------
-disambigGroup :: [Type]                  -- The default types
-              -> (TcTyVar, [Class], Cts) -- All classes of the form (C a)
-                                         --  sharing same type variable
+disambigGroup :: [Type]            -- The default types
+              -> (TcTyVar, [Ct])   -- All classes of the form (C a)
+                                   --  sharing same type variable
               -> TcS Bool   -- True <=> something happened, reflected in ty_binds
 
 disambigGroup [] _
   = return False
-disambigGroup (default_ty:default_tys) group@(the_tv, clss, wanteds)
+disambigGroup (default_ty:default_tys) group@(the_tv, wanteds)
   = do { traceTcS "disambigGroup {" (vcat [ ppr default_ty, ppr the_tv, ppr wanteds ])
        ; fake_ev_binds_var <- TcS.newTcEvBinds
        ; tclvl             <- TcS.getTcLevel
-       ; success <- nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) $
-                    do { wanted_evs <- mapM (newWantedEvVarNC loc)
-                                            [ mkClassPred cls [default_ty]
-                                            | cls <- clss ]
-                       ; residual_wanted <- solveSimpleWanteds $ listToBag $
-                                            map mkNonCanonical wanted_evs
-                       ; return (isEmptyWC residual_wanted) }
+       ; success <- nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl)
+                    try_group
 
        ; if success then
              -- Success: record the type variable binding, and return
@@ -1455,6 +1450,21 @@ disambigGroup (default_ty:default_tys) group@(the_tv, clss, wanteds)
                            (ppr default_ty)
                 ; disambigGroup default_tys group } }
   where
+    try_group
+      | Just subst <- mb_subst
+      = do { wanted_evs <- mapM (newWantedEvVarNC loc . substTy subst . ctPred)
+                                wanteds
+           ; residual_wanted <- solveSimpleWanteds $ listToBag $
+                                map mkNonCanonical wanted_evs
+           ; return (isEmptyWC residual_wanted) }
+      | otherwise
+      = return False
+
+    tmpl_tvs = extendVarSet (tyVarsOfType (tyVarKind the_tv)) the_tv
+    mb_subst = tcMatchTy tmpl_tvs (mkTyVarTy the_tv) default_ty
+      -- Make sure the kinds match too; hence this call to tcMatchTy
+      -- E.g. suppose the only constraint was (Typeable k (a::k))
+
     loc = CtLoc { ctl_origin = GivenOrigin UnkSkol
                 , ctl_env = panic "disambigGroup:env"
                 , ctl_depth = initialSubGoalDepth }