[project @ 2000-11-14 10:46:39 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index f16b34d..4976f41 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, opt_GlasgowExts, opt_WarnTypeDefaults )
 import HsSyn           ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
 import TcHsSyn         ( TcExpr, TcId, 
                          TcMonoBinds, TcDictBinds
@@ -143,9 +142,9 @@ import Inst         ( lookupInst, lookupSimpleInst, LookupInstResult(..),
                          mkLIE, emptyLIE, unitLIE, consLIE, plusLIE,
                          lieToList 
                        )
-import TcEnv           ( tcGetGlobalTyVars, tcGetInstEnv,
-                         lookupInstEnv, InstLookupResult(..) 
-                       )
+import TcEnv           ( tcGetGlobalTyVars, tcGetInstEnv )
+import InstEnv         ( lookupInstEnv, InstLookupResult(..) )
+
 import TcType          ( TcTyVarSet )
 import TcUnify         ( unifyTauTy )
 import Id              ( idType )
@@ -161,13 +160,13 @@ import PprType            ( pprConstraint )
 import TysWiredIn      ( unitTy )
 import VarSet
 import FiniteMap
-import CmdLineOpts     ( opt_GlasgowExts )
 import Outputable
 import ListSetOps      ( equivClasses )
 import Util            ( zipEqual, mapAccumL )
 import List            ( partition )
 import Maybe           ( fromJust )
 import Maybes          ( maybeToBool )
+import CmdLineOpts
 \end{code}
 
 
@@ -849,17 +848,18 @@ tcSimplifyThetas :: ClassContext          -- Wanted
                 -> TcM ClassContext            -- Needed
 
 tcSimplifyThetas wanteds
-  = reduceSimple [] wanteds            `thenNF_Tc` \ irreds ->
+  = doptsTc Opt_GlasgowExts            `thenNF_Tc` \ glaExts ->
+    reduceSimple [] wanteds            `thenNF_Tc` \ irreds ->
     let
        -- For multi-param Haskell, check that the returned dictionaries
        -- don't have any of the form (C Int Bool) for which
        -- we expect an instance here
        -- For Haskell 98, check that all the constraints are of the form C a,
        -- where a is a type variable
-       bad_guys | opt_GlasgowExts = [ct | ct@(clas,tys) <- irreds, 
-                                          isEmptyVarSet (tyVarsOfTypes tys)]
-                | otherwise       = [ct | ct@(clas,tys) <- irreds, 
-                                          not (all isTyVarTy tys)]
+       bad_guys | glaExts   = [ct | ct@(clas,tys) <- irreds, 
+                                    isEmptyVarSet (tyVarsOfTypes tys)]
+                | otherwise = [ct | ct@(clas,tys) <- irreds, 
+                                    not (all isTyVarTy tys)]
     in
     if null bad_guys then
        returnTc irreds
@@ -1073,7 +1073,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 ->
 
@@ -1226,21 +1225,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 +1270,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,