[commit: ghc] type-holes-branch: Improve unification of named holes if they are used more than 2 times. (b8174dd)

[Simon Peyton Jones]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : type-holes-branch

http://hackage.haskell.org/trac/ghc/changeset/b8174dd2c7467626d4a428bebaab226d18e1a5d7

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

commit b8174dd2c7467626d4a428bebaab226d18e1a5d7
Author: Thijs Alkemade <thijsalkemade at gmail.com>
Date:   Wed Feb 15 21:06:12 2012 +0100

    Improve unification of named holes if they are used more than 2 times.
    
    A hole constraint that got kicked out here wasn't returned properly.

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

 compiler/typecheck/TcCanonical.lhs |    5 +++++
 compiler/typecheck/TcInteract.lhs  |    2 +-
 compiler/typecheck/TcSMonad.lhs    |    3 +++
 3 files changed, 9 insertions(+), 1 deletions(-)

diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index 6129ce5..9edde94 100644
--- a/compiler/typecheck/TcCanonical.lhs
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -194,6 +194,11 @@ canonicalize (CIrredEvCan { cc_id = ev, cc_flavor = fl
                           , cc_depth = d
                           , cc_ty = xi })
   = canIrred d fl ev xi
+canonicalize (CHoleCan { cc_id = ev, cc_depth = d
+                       , cc_flavor = fl
+                       , cc_hole_nm = nm
+                       , cc_hole_ty = xi })
+  = canHole d fl ev nm xi
 
 
 canEvVar :: EvVar -> PredTree 
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index 9f05f5b..90bff82 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -425,7 +425,7 @@ kick_out_rewritable ct (IS { inert_eqs    = eqmap
     kicked_out = WorkList { wl_eqs    = []
                           , wl_funeqs = bagToList feqs_out
                           , wl_rest   = bagToList (fro_out `andCts` dicts_out 
-                                          `andCts` ips_out `andCts` irs_out) }
+                                          `andCts` ips_out `andCts` irs_out `andCts` holes_out) }
   
     remaining = IS { inert_eqs = emptyVarEnv
                    , inert_eq_tvs = inscope -- keep the same, safe and cheap
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index bf6e165..8f9cd54 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -329,6 +329,9 @@ data CCanMap a = CCanMap { cts_given   :: UniqFM Cts
                          , cts_wanted  :: UniqFM Cts } 
                                           -- Invariant: all Wanted
 
+instance Outputable (CCanMap a) where
+  ppr (CCanMap given derived wanted) = ptext (sLit "CCanMap") <+> (ppr given) <+> (ppr derived) <+> (ppr wanted)
+
 cCanMapToBag :: CCanMap a -> Cts 
 cCanMapToBag cmap = foldUFM unionBags rest_wder (cts_given cmap)
   where rest_wder = foldUFM unionBags rest_der  (cts_wanted cmap)