[commit: ghc] wip/impredicativity: Add defaulting of <~ constraints (4355551)

[git at git.haskell.org]

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

On branch  : wip/impredicativity
Link       : http://ghc.haskell.org/trac/ghc/changeset/435555107bdf62990862e6e12d33e6143c7fd53f/ghc

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

commit 435555107bdf62990862e6e12d33e6143c7fd53f
Author: Alejandro Serrano <trupill at gmail.com>
Date:   Tue Jul 21 12:45:06 2015 +0200

    Add defaulting of <~ constraints


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

435555107bdf62990862e6e12d33e6143c7fd53f
 compiler/typecheck/TcSimplify.hs | 22 ++++++++++++++++++++--
 1 file changed, 20 insertions(+), 2 deletions(-)

diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs
index 34207c5..1bc3701 100644
--- a/compiler/typecheck/TcSimplify.hs
+++ b/compiler/typecheck/TcSimplify.hs
@@ -121,10 +121,28 @@ simpl_top wanteds
            ; meta_tvs' <- mapM defaultTyVar meta_tvs   -- Has unification side effects
            ; if meta_tvs' == meta_tvs   -- No defaulting took place;
                                         -- (defaulting returns fresh vars)
-             then try_class_defaulting wc
+             then try_instance_of_defaulting wc
              else do { wc_residual <- nestTcS (solveWantedsAndDrop wc)
                             -- See Note [Must simplify after defaulting]
-                     ; try_class_defaulting wc_residual } }
+                     ; try_instance_of_defaulting wc_residual } }
+
+    try_instance_of_defaulting :: WantedConstraints -> TcS WantedConstraints
+    try_instance_of_defaulting wc
+      | isEmptyWC wc
+      = return wc
+      | otherwise
+      = do { let approx = bagToList (approximateWC_ wc)
+           ; something_happened <- foldlM (\something ct ->
+               case (isWantedCt ct, classifyPredType (ctPred ct)) of
+                 (True, InstanceOfPred lhs rhs)
+                   | Just v <- tcGetTyVar_maybe rhs
+                   -> do { unifyTyVar v lhs
+                         ; return True }
+                 _ -> return something) False approx
+           ; if something_happened
+             then do { wc_residual <- nestTcS (solveWantedsAndDrop wc)
+                     ; try_class_defaulting wc_residual }
+             else try_class_defaulting wc }
 
     try_class_defaulting :: WantedConstraints -> TcS WantedConstraints
     try_class_defaulting wc