projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[project @ 2000-11-24 09:51:38 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 3acc71c..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}
 
 
@@ -190,7 +189,7 @@ tcSimplify
        -> TcTyVarSet                   -- ``Local''  type variables
                                        -- ASSERT: this tyvar set is already zonked
        -> LIE                          -- Wanted
-       -> TcM s (LIE,                  -- Free
+       -> TcM (LIE,                    -- Free
                  TcDictBinds,          -- Bindings
                  LIE)                  -- Remaining wanteds; no dups
 
@@ -262,7 +261,7 @@ tcSimplifyAndCheck
                                -- ASSERT: this tyvar set is already zonked
         -> LIE                 -- Given; constrain only local tyvars
         -> LIE                 -- Wanted
-        -> TcM s (LIE,         -- Free
+        -> TcM (LIE,           -- Free
                   TcDictBinds) -- Bindings
 
 tcSimplifyAndCheck str local_tvs given_lie wanted_lie
@@ -323,7 +322,7 @@ But that means that we must simplify the Method for f to (f Int dNumInt)!
 So tcSimplifyToDicts squeezes out all Methods.
 
 \begin{code}
-tcSimplifyToDicts :: LIE -> TcM s (LIE, TcDictBinds)
+tcSimplifyToDicts :: LIE -> TcM (LIE, TcDictBinds)
 tcSimplifyToDicts wanted_lie
   = reduceContext (text "tcSimplifyToDicts") try_me [] wanteds `thenTc` \ (binds, frees, irreds) ->
     ASSERT( null frees )
@@ -499,7 +498,7 @@ The main entry point for context reduction is @reduceContext@:
 reduceContext :: SDoc -> (Inst -> WhatToDo)
              -> [Inst] -- Given
              -> [Inst] -- Wanted
-             -> TcM s (TcDictBinds, 
+             -> TcM (TcDictBinds, 
                        [Inst],         -- Free
                        [Inst])         -- Irreducible
 
@@ -569,7 +568,7 @@ reduceList :: (Int,[Inst])          -- Stack (for err msgs)
                   -> (Inst -> WhatToDo)
                   -> [Inst]
                   -> RedState s
-                  -> TcM s (RedState s)
+                  -> TcM (RedState s)
 \end{code}
 
 @reduce@ is passed
@@ -755,7 +754,7 @@ addFree avails free
   | isDict free = addToFM avails free (Avail (instToId free) NoRhs [])
   | otherwise   = avails
 
-addGiven :: Avails s -> Inst -> NF_TcM s (Avails s)
+addGiven :: Avails s -> Inst -> NF_TcM (Avails s)
 addGiven avails given
   =     -- ASSERT( not (given `elemFM` avails) )
         -- This assertion isn't necessarily true.  It's permitted
@@ -771,7 +770,7 @@ addGiven avails given
 addAvail avails wanted avail
   = addSuperClasses (addToFM avails wanted avail) wanted
 
-addSuperClasses :: Avails s -> Inst -> NF_TcM s (Avails s)
+addSuperClasses :: Avails s -> Inst -> NF_TcM (Avails s)
                -- Add all the superclasses of the Inst to Avails
                -- Invariant: the Inst is already in Avails.
 
@@ -817,7 +816,7 @@ addSuperClasses avails dict
                                  (PassiveScSel sc_sel_rhs [dict])
                                  []
 
-addFunDeps :: Avails s -> Inst -> NF_TcM s (Avails s)
+addFunDeps :: Avails s -> Inst -> NF_TcM (Avails s)
           -- Add in the functional dependencies generated by the inst
 addFunDeps avails inst
   = newFunDepFromDict inst     `thenNF_Tc` \ fdInst_maybe ->
@@ -846,20 +845,21 @@ instance declarations.
 
 \begin{code}
 tcSimplifyThetas :: ClassContext               -- Wanted
-                -> TcM s ClassContext          -- Needed
+                -> 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
@@ -875,7 +875,7 @@ whether it worked or not.
 \begin{code}
 tcSimplifyCheckThetas :: ClassContext  -- Given
                      -> ClassContext   -- Wanted
-                     -> TcM s ()
+                     -> TcM ()
 
 tcSimplifyCheckThetas givens wanteds
   = reduceSimple givens wanteds    `thenNF_Tc` \ irreds ->
@@ -894,7 +894,7 @@ type AvailsSimple = FiniteMap (Class,[Type]) Bool
 
 reduceSimple :: ClassContext                   -- Given
             -> ClassContext                    -- Wanted
-            -> NF_TcM s ClassContext           -- Irreducible
+            -> NF_TcM ClassContext             -- Irreducible
 
 reduceSimple givens wanteds
   = reduce_simple (0,[]) givens_fm wanteds     `thenNF_Tc` \ givens_fm' ->
@@ -905,7 +905,7 @@ reduceSimple givens wanteds
 reduce_simple :: (Int,ClassContext)            -- Stack
              -> AvailsSimple
              -> ClassContext
-             -> NF_TcM s AvailsSimple
+             -> NF_TcM AvailsSimple
 
 reduce_simple (n,stack) avails wanteds
   = go avails wanteds
@@ -978,7 +978,7 @@ For each method @Inst@ in the @init_lie@ that mentions one of the
 @LIE@), as well as the @HsBinds@ generated.
 
 \begin{code}
-bindInstsOfLocalFuns ::        LIE -> [TcId] -> TcM s (LIE, TcMonoBinds)
+bindInstsOfLocalFuns ::        LIE -> [TcId] -> TcM (LIE, TcMonoBinds)
 
 bindInstsOfLocalFuns init_lie local_ids
   | null overloaded_ids || null lie_for_here
@@ -1049,7 +1049,7 @@ variable, and using @disambigOne@ to do the real business.
 all the constant and ambiguous Insts.
 
 \begin{code}
-tcSimplifyTop :: LIE -> TcM s TcDictBinds
+tcSimplifyTop :: LIE -> TcM TcDictBinds
 tcSimplifyTop wanted_lie
   = reduceContext (text "tcSimplTop") try_me [] wanteds        `thenTc` \ (binds1, frees, irreds) ->
     ASSERT( null frees )
@@ -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 ->
 
@@ -1111,7 +1110,7 @@ Since we're not using the result of @foo@, the result if (presumably)
 
 \begin{code}
 disambigGroup :: [Inst]        -- All standard classes of form (C a)
-             -> TcM s TcDictBinds
+             -> TcM TcDictBinds
 
 disambigGroup dicts
   |   any isNumericClass classes       -- Guaranteed all standard classes
@@ -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,
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)