[project @ 2001-04-12 21:29:43 by lewie]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcSimplify.lhs

diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index c6317ce..a4f6af4 100644 (file)
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -7,7 +7,8 @@
 
 \begin{code}
 module TcSimplify (
-       tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyCheck, 
+       tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyCheck,
+       tcSimplifyRestricted,
        tcSimplifyToDicts, tcSimplifyIPs, tcSimplifyTop, 
 
        tcSimplifyThetas, tcSimplifyCheckThetas,
@@ -479,33 +480,45 @@ tcSimplifyCheck
                 TcDictBinds)   -- Bindings
 
 tcSimplifyCheck doc qtvs givens wanted_lie
-  = checkLoop doc qtvs givens (lieToList wanted_lie)   `thenTc` \ (frees, binds, irreds) ->
+  = checkLoop doc qtvs givens (lieToList wanted_lie) try `thenTc` \ (frees, binds, irreds) ->
 
        -- Complain about any irreducible ones
     complainCheck doc givens irreds            `thenNF_Tc_`
 
        -- Done
     returnTc (mkLIE frees, binds)
+  where
+       -- When checking against a given signature we always reduce
+       -- until we find a match against something given, or can't reduce
+    try qtvs inst | isFree qtvs inst  = Free
+                 | otherwise         = ReduceMe 
 
-checkLoop doc qtvs givens wanteds
-  =    -- Step 1
+tcSimplifyRestricted doc qtvs givens wanted_lie
+  = checkLoop doc qtvs givens (lieToList wanted_lie) try `thenTc` \ (frees, binds, irreds) ->
+
+       -- Complain about any irreducible ones
+    complainCheck doc givens irreds            `thenNF_Tc_`
+
+       -- Done
+    returnTc (mkLIE frees, binds)
+  where
+    try qtvs inst | not (tyVarsOfInst inst `intersectsVarSet` qtvs) = Free
+                 | otherwise                                       = ReduceMe
+
+checkLoop doc qtvs givens wanteds try_me
+  =            -- Step 1
     zonkTcTyVarsAndFV qtvs             `thenNF_Tc` \ qtvs' ->
     mapNF_Tc zonkInst givens           `thenNF_Tc` \ givens' ->
     mapNF_Tc zonkInst wanteds          `thenNF_Tc` \ wanteds' ->
-    let
-             -- When checking against a given signature we always reduce
-             -- until we find a match against something given, or can't reduce
-       try_me inst | isFree qtvs' inst  = Free
-                   | otherwise          = ReduceMe 
-    in
+
                -- Step 2
-    reduceContext doc try_me givens' wanteds'    `thenTc` \ (no_improvement, frees, binds, irreds) ->
+    reduceContext doc (try_me qtvs') givens' wanteds'          `thenTc` \ (no_improvement, frees, binds, irreds) ->
        
                -- Step 3
     if no_improvement then
        returnTc (frees, binds, irreds)
     else
-       checkLoop doc qtvs givens' (irreds ++ frees)    `thenTc` \ (frees1, binds1, irreds1) ->
+       checkLoop doc qtvs givens' (irreds ++ frees) try_me     `thenTc` \ (frees1, binds1, irreds1) ->
        returnTc (frees1, binds `AndMonoBinds` binds1, irreds1)
 
 complainCheck doc givens irreds
@@ -1526,26 +1539,14 @@ addAmbigErr tidy_env tidy_dict
 
 warnDefault dicts default_ty
   = doptsTc Opt_WarnTypeDefaults  `thenTc` \ warn_flag ->
-    if warn_flag 
-       then mapNF_Tc warn groups  `thenNF_Tc_`  returnNF_Tc ()
-       else returnNF_Tc ()
-
+    tcAddSrcLoc (get_loc (head dicts)) (warnTc warn_flag warn_msg)
   where
        -- Tidy them first
     (_, tidy_dicts) = tidyInsts dicts
-
-       -- Group the dictionaries by source location
-    groups      = equivClasses cmp tidy_dicts
-    i1 `cmp` i2 = get_loc i1 `compare` get_loc i2
-    get_loc i   = case instLoc i of { (_,loc,_) -> loc }
-
-    warn [dict] = tcAddSrcLoc (get_loc dict) $
-                 warnTc True (ptext SLIT("Defaulting") <+> quotes (pprInst dict) <+> 
-                              ptext SLIT("to type") <+> quotes (ppr default_ty))
-
-    warn dicts  = tcAddSrcLoc (get_loc (head dicts)) $
-                 warnTc True (vcat [ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty),
-                                    pprInstsInFull dicts])
+    get_loc i = case instLoc i of { (_,loc,_) -> loc }
+    warn_msg  = vcat [ptext SLIT("Defaulting the following constraint(s) to type") <+> 
+                               quotes (ppr default_ty),
+                     pprInstsInFull tidy_dicts]
 
 -- The error message when we don't find a suitable instance
 -- is complicated by the fact that sometimes this is because