[project @ 2001-01-09 17:43:57 by rrt]

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

diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index 336eeb6..4748e9d 100644 (file)
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -123,7 +123,6 @@ module TcSimplify (
 
 #include "HsVersions.h"
 
-import CmdLineOpts     ( opt_MaxContextReductionDepth, dopt_GlasgowExts, opt_WarnTypeDefaults )
 import HsSyn           ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
 import TcHsSyn         ( TcExpr, TcId, 
                          TcMonoBinds, TcDictBinds
@@ -144,7 +143,7 @@ import Inst         ( lookupInst, lookupSimpleInst, LookupInstResult(..),
                          lieToList 
                        )
 import TcEnv           ( tcGetGlobalTyVars, tcGetInstEnv )
-import TcInstUtil      ( lookupInstEnv, InstLookupResult(..) )
+import InstEnv         ( lookupInstEnv, InstLookupResult(..) )
 
 import TcType          ( TcTyVarSet )
 import TcUnify         ( unifyTauTy )
@@ -167,6 +166,7 @@ import Util         ( zipEqual, mapAccumL )
 import List            ( partition )
 import Maybe           ( fromJust )
 import Maybes          ( maybeToBool )
+import CmdLineOpts
 \end{code}
 
 
@@ -760,10 +760,7 @@ addGiven avails given
         -- This assertion isn't necessarily true.  It's permitted
         -- to given a redundant context in a type signature (eg (Ord a, Eq a) => ...)
         -- and when typechecking instance decls we generate redundant "givens" too.
-    -- addAvail avails given avail
-    addAvail avails given avail `thenNF_Tc` \av ->
-    zonkInst given `thenNF_Tc` \given' ->
-    returnNF_Tc av     
+    addAvail avails given avail
   where
     avail = Avail (instToId given) NoRhs []
 
@@ -848,7 +845,7 @@ tcSimplifyThetas :: ClassContext            -- Wanted
                 -> TcM ClassContext            -- Needed
 
 tcSimplifyThetas wanteds
-  = doptsTc dopt_GlasgowExts           `thenNF_Tc` \ glaExts ->
+  = doptsTc Opt_GlasgowExts            `thenNF_Tc` \ glaExts ->
     reduceSimple [] wanteds            `thenNF_Tc` \ irreds ->
     let
        -- For multi-param Haskell, check that the returned dictionaries
@@ -1073,7 +1070,6 @@ tcSimplifyTop wanted_lie
                -- Collect together all the bad guys
        bad_guys = non_stds ++ concat std_bads
     in
-
        -- Disambiguate the ones that look feasible
     mapTc disambigGroup std_oks                `thenTc` \ binds_ambig ->
 
@@ -1149,7 +1145,7 @@ disambigGroup dicts
     unifyTauTy chosen_default_ty (mkTyVarTy tyvar)     `thenTc_`
     reduceContext (text "disambig" <+> ppr dicts)
                  try_me [] dicts                       `thenTc` \ (binds, frees, ambigs) ->
-    ASSERT( null frees && null ambigs )
+    WARN( not (null frees && null ambigs), ppr frees $$ ppr ambigs )
     warnDefault dicts chosen_default_ty                        `thenTc_`
     returnTc binds
 
@@ -1226,21 +1222,28 @@ addAmbigErr ambig_tv_fn dict
     (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
 
 warnDefault dicts default_ty
-  | not opt_WarnTypeDefaults
-  = returnNF_Tc ()
+  = doptsTc Opt_WarnTypeDefaults  `thenTc` \ warn_flag ->
+    if warn_flag 
+       then mapNF_Tc warn groups  `thenNF_Tc_`  returnNF_Tc ()
+       else returnNF_Tc ()
 
-  | otherwise
-  = warnTc True msg
   where
-    msg | length dicts > 1 
-       = (ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty))
-         $$ pprInstsInFull tidy_dicts
-       | otherwise
-       = ptext SLIT("Defaulting") <+> quotes (pprInst (head tidy_dicts)) <+> 
-         ptext SLIT("to type") <+> quotes (ppr default_ty)
-
+       -- Tidy them first
     (_, tidy_dicts) = mapAccumL tidyInst emptyTidyEnv 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])
+
 addTopIPErr dict
   = addInstErrTcM (instLoc dict) 
        (tidy_env, 
@@ -1264,8 +1267,8 @@ addTopInstanceErr dict
 addNoInstanceErr str givens dict
   = tcGetInstEnv       `thenNF_Tc` \ inst_env ->
     let
-       doc = vcat [herald <+> quotes (pprInst tidy_dict),
-                   nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens,
+       doc = vcat [sep [herald <+> quotes (pprInst tidy_dict),
+                        nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens],
                    ambig_doc,
                    ptext SLIT("Probable fix:"),
                    nest 4 fix1,