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 <[email protected]> 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) _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
