[project @ 1998-10-06 14:36:27 by simonm]

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

diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs
index 28abdaf..d84bf54 100644 (file)
--- a/ghc/compiler/typecheck/TcInstUtil.lhs
+++ b/ghc/compiler/typecheck/TcInstUtil.lhs
@@ -15,14 +15,16 @@ module TcInstUtil (
 
 #include "HsVersions.h"
 
-import RnHsSyn         ( RenamedMonoBinds, RenamedSig(..) )
+import RnHsSyn         ( RenamedMonoBinds, RenamedSig )
 
+import CmdLineOpts     ( opt_AllowOverlappingInstances )
 import TcMonad
 import Inst            ( InstanceMapper )
 
 import Bag             ( bagToList, Bag )
 import Class           ( ClassInstEnv, Class, classBigSig )
-import Id              ( mkDictFunId, Id )
+import MkId            ( mkDictFunId )
+import Id              ( Id )
 import SpecEnv         ( emptySpecEnv, addToSpecEnv )
 import Maybes          ( MaybeErr(..), mkLookupFunDef )
 import Name            ( getSrcLoc, Name )
@@ -37,6 +39,7 @@ import TyVar          ( TyVar, zipTyVarEnv )
 import Unique          ( Unique )
 import Util            ( equivClasses, panic, assertPanic )
 import Outputable
+import List            ( nub )
 \end{code}
 
     instance c => k (t tvs) where b
@@ -96,13 +99,19 @@ mkInstanceRelatedIds dfun_name clas inst_tyvars inst_tys inst_decl_theta
     sc_theta' = instantiateThetaTy (zipTyVarEnv class_tyvars inst_tys) sc_theta
 
     dfun_theta = case inst_decl_theta of
-                       []    -> []     -- If inst_decl_theta is empty, then we don't
+                  []    -> []  -- If inst_decl_theta is empty, then we don't
                                        -- want to have any dict arguments, so that we can
                                        -- expose the constant methods.
 
-                       other -> inst_decl_theta ++ sc_theta'
-                                       -- Otherwise we pass the superclass dictionaries to
-                                       -- the dictionary function; the Mark Jones optimisation.
+                  other -> nub (inst_decl_theta ++ sc_theta')
+                               -- Otherwise we pass the superclass dictionaries to
+                               -- the dictionary function; the Mark Jones optimisation.
+                               --
+                               -- NOTE the "nub".  I got caught by this one:
+                               --   class Monad m => MonadT t m where ...
+                               --   instance Monad m => MonadT (EnvT env) m where ...
+                               -- Here, the inst_decl_theta has (Monad m); but so
+                               -- does the sc_theta'!
 
     dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
 
@@ -161,7 +170,8 @@ addClassInstance
              dfun_id _ src_loc _)
     class_inst_env
   =    -- Add the instance to the class's instance environment
-    case addToSpecEnv class_inst_env inst_tys dfun_id of
+    case addToSpecEnv opt_AllowOverlappingInstances 
+                     class_inst_env inst_tyvars inst_tys dfun_id of
        Failed (ty', dfun_id')    -> addErrTc (dupInstErr clas (inst_tys, src_loc) 
                                                               (ty', getSrcLoc dfun_id'))
                                                `thenNF_Tc_`