[project @ 2000-07-07 12:13:43 by simonpj]

This commit moves the instance environment out of the Class data
structure, where it was immutable, to part of the type-checker
environment.  This change is absolutely essential as part of
our move to GHCi, and I think it's also going to be necessary
for Andrei's work on generic functions.

As part of this change, we can remove

  a) types/InstEnv.*	(thereby also removing a hi-boot loop)
  b) a tc-fixpoint-loop in TcModule

Both of these are worthwhile simplifications.

ghc/compiler/DEPEND-NOTES

@@ -12,7 +12,7 @@ then
 then
 	VarEnv, VarSet, ThinAir
 then
-	Class (loop TyCon.TyCon, loop Type.Type, loop InstEnv.InstEnv)
+	Class (loop TyCon.TyCon, loop Type.Type)
 then
 	TyCon (loop Type.Type, loop Type.Kind, loop DataCon.DataCon)
 then
@@ -23,8 +23,6 @@ then
 	Unify, PprType (PprEnv)
 then
 	Literal (TysPrim, PprType), DataCon
-then
-	InstEnv (Unify)
 then
 	TysWiredIn (DataCon.mkDataCon, loop MkId.mkDataConId)
 then

ghc/compiler/typecheck/Inst.lhs

@@ -11,8 +11,6 @@ module Inst (
 	Inst, OverloadedLit(..),
 	pprInst, pprInsts, pprInstsInFull, tidyInst, tidyInsts,
 
-        InstanceMapper,
-
 	newDictFromOld, newDicts, newClassDicts, newDictsAtLoc,
 	newMethod, newMethodWithGivenTy, newOverloadedLit,
 	newIPDict, instOverloadedFun,
@@ -45,21 +43,22 @@ import TcHsSyn	( TcExpr, TcId,
 		  mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
 		)
 import TcMonad
-import TcEnv	( TcIdSet, tcLookupValueByKey, tcLookupTyConByKey )
+import TcEnv	( TcIdSet, InstEnv, tcGetInstEnv, lookupInstEnv, InstLookupResult(..),
+		  tcLookupValueByKey, tcLookupTyConByKey
+		)
 import TcType	( TcThetaType,
 		  TcType, TcTauType, TcTyVarSet,
 		  zonkTcTyVars, zonkTcType, zonkTcTypes, 
 		  zonkTcThetaType
 		)
 import Bag
-import Class	( classInstEnv, Class, FunDep )
+import Class	( Class, FunDep )
 import FunDeps	( instantiateFdClassTys )
 import Id	( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal )
 import PrelInfo	( isStandardClass, isCcallishClass, isNoDictClass )
 import Name	( OccName, Name, mkDictOcc, mkMethodOcc, mkIPOcc,
 		  getOccName, nameUnique )
 import PprType	( pprPred )	
-import InstEnv	( InstEnv, lookupInstEnv, InstEnvResult(..) )
 import SrcLoc	( SrcLoc )
 import Type	( Type, PredType(..), ThetaType,
 		  mkTyVarTy, isTyVarTy, mkDictTy, mkPredTy,
@@ -67,7 +66,6 @@ import Type	( Type, PredType(..), ThetaType,
 		  splitRhoTy, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
 		  mkSynTy, tidyOpenType, tidyOpenTypes
 		)
-import InstEnv	( InstEnv )
 import Subst	( emptyInScopeSet, mkSubst,
 		  substTy, substClasses, mkTyVarSubst, mkTopTyVarSubst
 		)
@@ -285,6 +283,7 @@ Predicates
 isDict :: Inst -> Bool
 isDict (Dict _ _ _) = True
 isDict other	    = False
+
 isClassDict :: Inst -> Bool
 isClassDict (Dict _ (Class _ _) _) = True
 isClassDict other		   = False
@@ -294,10 +293,8 @@ isMethod (Method _ _ _ _ _ _) = True
 isMethod other		      = False
 
 isMethodFor :: TcIdSet -> Inst -> Bool
-isMethodFor ids (Method uniq id tys _ _ loc) 
-  = id `elemVarSet` ids
-isMethodFor ids inst 
-  = False
+isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
+isMethodFor ids inst			     = False
 
 isTyVarDict :: Inst -> Bool
 isTyVarDict (Dict _ (Class _ tys) _) = all isTyVarTy tys
@@ -628,25 +625,6 @@ show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 %*									*
 %************************************************************************
 
-\begin{code}
-type InstanceMapper = Class -> InstEnv
-\end{code}
-
-A @ClassInstEnv@ lives inside a class, and identifies all the instances
-of that class.  The @Id@ inside a ClassInstEnv mapping is the dfun for
-that instance.  
-
-There is an important consistency constraint between the @MatchEnv@s
-in and the dfun @Id@s inside them: the free type variables of the
-@Type@ key in the @MatchEnv@ must be a subset of the universally-quantified
-type variables of the dfun.  Thus, the @ClassInstEnv@ for @Eq@ might
-contain the following entry:
-@
-	[a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
-@
-The "a" in the pattern must be one of the forall'd variables in
-the dfun type.
-
 \begin{code}
 data LookupInstResult s
   = NoInstance
@@ -659,7 +637,8 @@ lookupInst :: Inst
 -- Dictionaries
 
 lookupInst dict@(Dict _ (Class clas tys) loc)
-  = case lookupInstEnv (classInstEnv clas) tys of
+  = tcGetInstEnv		`thenNF_Tc` \ inst_env ->
+    case lookupInstEnv inst_env clas tys of
 
       FoundInst tenv dfun_id
 	-> let
@@ -754,13 +733,13 @@ appropriate dictionary if it exists.  It is used only when resolving
 ambiguous dictionaries.
 
 \begin{code}
-lookupSimpleInst :: InstEnv
-		 -> Class
+lookupSimpleInst :: Class
 		 -> [Type]				-- Look up (c,t)
 	         -> NF_TcM s (Maybe [(Class,[Type])])	-- Here are the needed (c,t)s
 
-lookupSimpleInst class_inst_env clas tys
-  = case lookupInstEnv class_inst_env tys of
+lookupSimpleInst clas tys
+  = tcGetInstEnv		`thenNF_Tc` \ inst_env -> 
+    case lookupInstEnv inst_env clas tys of
       FoundInst tenv dfun
 	-> returnNF_Tc (Just (substClasses (mkSubst emptyInScopeSet tenv) theta'))
         where
@@ -769,3 +748,5 @@ lookupSimpleInst class_inst_env clas tys
 
       other  -> returnNF_Tc Nothing
 \end{code}
+
+

ghc/compiler/typecheck/TcClassDcl.lhs

@@ -140,7 +140,7 @@ kcClassDecl (ClassDecl	context class_name
 %************************************************************************
 
 \begin{code}
-tcClassDecl1 rec_env rec_inst_mapper rec_vrcs
+tcClassDecl1 rec_env rec_vrcs
       	     (ClassDecl context class_name
 			tyvar_names fundeps class_sigs def_methods pragmas 
 			tycon_name datacon_name datacon_wkr_name sc_sel_names src_loc)
@@ -166,11 +166,9 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs
 	-- MAKE THE CLASS OBJECT ITSELF
     let
 	(op_tys, op_items) = unzip sig_stuff
-	rec_class_inst_env = rec_inst_mapper rec_class
 	clas = mkClass class_name tyvars fds
 		       sc_theta sc_sel_ids op_items
 		       tycon
-		       rec_class_inst_env
 
 	dict_component_tys = sc_tys ++ op_tys
  	new_or_data = case dict_component_tys of

ghc/compiler/typecheck/TcDeriv.lhs

@@ -16,10 +16,9 @@ import RnHsSyn		( RenamedHsBinds, RenamedMonoBinds )
 import CmdLineOpts	( opt_D_dump_deriv )
 
 import TcMonad
-import Inst		( InstanceMapper )
-import TcEnv		( getEnvTyCons )
+import TcEnv		( InstEnv, getEnvTyCons, tcSetInstEnv )
 import TcGenDeriv	-- Deriv stuff
-import TcInstUtil	( InstInfo(..), buildInstanceEnvs )
+import TcInstUtil	( InstInfo(..), buildInstanceEnv )
 import TcSimplify	( tcSimplifyThetas )
 
 import RnBinds		( rnMethodBinds, rnTopMonoBinds )
@@ -422,15 +421,15 @@ solveDerivEqns inst_decl_infos_in orig_eqns
 	    -- with the current set of solutions, giving a
 
 	add_solns inst_decl_infos_in orig_eqns current_solns
-				`thenNF_Tc` \ (new_inst_infos, inst_mapper) ->
-	let
-	   class_to_inst_env cls = inst_mapper cls
-	in
+				`thenNF_Tc` \ (new_inst_infos, inst_env) ->
+
 	    -- Simplify each RHS
 
-	listTc [ tcAddErrCtxt (derivCtxt tc) $
-		 tcSimplifyThetas class_to_inst_env deriv_rhs
-	       | (_,tc,_,deriv_rhs) <- orig_eqns ]  `thenTc` \ next_solns ->
+	tcSetInstEnv inst_env (
+	  listTc [ tcAddErrCtxt (derivCtxt tc) $
+		   tcSimplifyThetas deriv_rhs
+	         | (_,tc,_,deriv_rhs) <- orig_eqns ]  
+	)						`thenTc` \ next_solns ->
 
 	    -- Canonicalise the solutions, so they compare nicely
 	let canonicalised_next_solns
@@ -443,18 +442,18 @@ solveDerivEqns inst_decl_infos_in orig_eqns
 add_solns :: Bag InstInfo			-- The global, non-derived ones
 	  -> [DerivEqn] -> [DerivSoln]
 	  -> NF_TcM s ([InstInfo], 		-- The new, derived ones
-		       InstanceMapper)
+		       InstEnv)
     -- the eqns and solns move "in lockstep"; we have the eqns
     -- because we need the LHS info for addClassInstance.
 
 add_solns inst_infos_in eqns solns
 
-  = discardErrsTc (buildInstanceEnvs all_inst_infos)	`thenNF_Tc` \ inst_mapper ->
+  = discardErrsTc (buildInstanceEnv all_inst_infos)	`thenNF_Tc` \ inst_env ->
 	-- We do the discard-errs so that we don't get repeated error messages
 	-- about duplicate instances.
-	-- They'll appear later, when we do the top-level buildInstanceEnvs.
+	-- They'll appear later, when we do the top-level buildInstanceEnv.
 
-    returnNF_Tc (new_inst_infos, inst_mapper)
+    returnNF_Tc (new_inst_infos, inst_env)
   where
     new_inst_infos = zipWithEqual "add_solns" mk_deriv_inst_info eqns solns
 

ghc/compiler/typecheck/TcImprove.lhs

@@ -4,17 +4,16 @@ module TcImprove ( tcImprove ) where
 #include "HsVersions.h"
 
 import Name		( Name )
-import Class		( Class, FunDep, className, classInstEnv, classExtraBigSig )
+import Class		( Class, FunDep, className, classExtraBigSig )
 import Unify		( unifyTyListsX, matchTys )
 import Subst		( mkSubst, substTy )
+import TcEnv		( tcGetInstEnv, classInstEnv )
 import TcMonad
 import TcType		( TcType, TcTyVar, TcTyVarSet, zonkTcType, zonkTcTypes )
 import TcUnify		( unifyTauTyLists )
 import Inst		( LIE, Inst, LookupInstResult(..),
 			  lookupInst, getFunDepsOfLIE, getIPsOfLIE,
 			  zonkLIE, zonkFunDeps {- for debugging -} )
-import InstEnv		( InstEnv )		-- Reqd for 4.02; InstEnv is a synonym, and
-						-- 4.02 doesn't "see" it soon enough
 import VarSet		( VarSet, emptyVarSet, unionVarSet )
 import VarEnv		( emptyVarEnv )
 import FunDeps		( instantiateFdClassTys )
@@ -26,44 +25,41 @@ import List		( elemIndex, nub )
 tcImprove :: LIE -> TcM s ()
 -- Do unifications based on functional dependencies in the LIE
 tcImprove lie 
-  | null nfdss = returnTc ()
-  | otherwise  = iterImprove nfdss
-  where
+  = tcGetInstEnv 	`thenNF_Tc` \ inst_env ->
+    let
 	nfdss, clas_nfdss, inst_nfdss, ip_nfdss :: [(TcTyVarSet, Name, [FunDep TcType])]
 	nfdss = ip_nfdss ++ clas_nfdss ++ inst_nfdss
 
 	cfdss :: [(Class, [FunDep TcType])]
-	cfdss = getFunDepsOfLIE lie
-	clas_nfdss = map (\(c, fds) -> (emptyVarSet, className c, fds)) cfdss
+	cfdss      = getFunDepsOfLIE lie
+	clas_nfdss = [(emptyVarSet, className c, fds) | (c,fds) <- cfdss]
+
+	classes    = nub (map fst cfdss)
+	inst_nfdss = [ (free, className c, instantiateFdClassTys c ts)
+		     | c <- classes,
+		       (free, ts, i) <- classInstEnv inst_env c
+		     ]
+
+	ip_nfdss = [(emptyVarSet, n, [([], [ty])]) | (n,ty) <- getIPsOfLIE lie]
+
+	{- Example: we have
+		class C a b c  |  a->b where ...
+		instance C Int Bool c 
+	
+	   Given the LIE 	FD C (Int->t)
+	   we get	clas_nfdss = [({}, C, [Int->t,     t->Int])
+			inst_nfdss = [({c}, C, [Int->Bool, Bool->Int])]
+	
+	   Another way would be to flatten a bit
+	   we get	clas_nfdss = [({}, C, Int->t), ({}, C, t->Int)]
+			inst_nfdss = [({c}, C, Int->Bool), ({c}, C, Bool->Int)]
+	
+	   iterImprove then matches up the C and Int, and unifies t <-> Bool
+	-}	
+
+    in
+    iterImprove nfdss
 
-	classes = nub (map fst cfdss)
-	inst_nfdss = concatMap getInstNfdssOf classes
-
-	ips = getIPsOfLIE lie
-	ip_nfdss = map (\(n, ty) -> (emptyVarSet, n, [([], [ty])])) ips
-
-{- Example: we have
-	class C a b c  |  a->b where ...
-	instance C Int Bool c 
-
-   Given the LIE 	FD C (Int->t)
-   we get	clas_nfdss = [({}, C, [Int->t,     t->Int])
-		inst_nfdss = [({c}, C, [Int->Bool, Bool->Int])]
-
-   Another way would be to flatten a bit
-   we get	clas_nfdss = [({}, C, Int->t), ({}, C, t->Int)]
-		inst_nfdss = [({c}, C, Int->Bool), ({c}, C, Bool->Int)]
-
-   iterImprove then matches up the C and Int, and unifies t <-> Bool
--}
-
-getInstNfdssOf :: Class -> [(TcTyVarSet, Name, [FunDep TcType])]
-getInstNfdssOf clas 
-  = [ (free, nm, instantiateFdClassTys clas ts)
-    | (free, ts, i) <- classInstEnv clas
-    ]
-  where
-	nm = className clas
 
 iterImprove :: [(VarSet, Name, [FunDep TcType])] -> TcM s ()
 iterImprove [] = returnTc ()

ghc/compiler/typecheck/TcInstUtil.lhs

@@ -8,7 +8,7 @@ The bits common to TcInstDcls and TcDeriv.
 \begin{code}
 module TcInstUtil (
 	InstInfo(..),
-	buildInstanceEnvs,
+	buildInstanceEnv,
 	classDataCon
     ) where
 
@@ -18,12 +18,10 @@ import RnHsSyn		( RenamedMonoBinds, RenamedSig )
 
 import CmdLineOpts	( opt_AllowOverlappingInstances )
 import TcMonad
-import Inst		( InstanceMapper )
-
+import TcEnv		( InstEnv, emptyInstEnv, addToInstEnv )
 import Bag		( bagToList, Bag )
 import Class		( Class )
 import Var		( TyVar, Id, idName )
-import InstEnv		( InstEnv, emptyInstEnv, addToInstEnv )
 import Maybes		( MaybeErr(..), mkLookupFunDef )
 import Name		( getSrcLoc, nameModule, isLocallyDefined )
 import SrcLoc		( SrcLoc )
@@ -77,32 +75,9 @@ classDataCon clas = case tyConDataCons (classTyCon clas) of
 %************************************************************************
 
 \begin{code}
-buildInstanceEnvs :: Bag InstInfo
-		  -> NF_TcM s InstanceMapper
-
-buildInstanceEnvs info
-  = let
-    	i_uniq :: InstInfo -> Unique
-    	i_uniq (InstInfo c _ _ _ _ _ _ _) = getUnique c
-
-	info_by_class = equivClassesByUniq i_uniq (bagToList info)
-    in
-    mapNF_Tc buildInstanceEnv info_by_class    `thenNF_Tc` \ inst_env_entries ->
-    let
-	class_lookup_fn = mkLookupFunDef (==) inst_env_entries emptyInstEnv
-    in
-    returnNF_Tc class_lookup_fn
-\end{code}
+buildInstanceEnv :: Bag InstInfo -> NF_TcM s InstEnv
 
-\begin{code}
-buildInstanceEnv :: [InstInfo]		-- Non-empty, and all for same class
-		 -> NF_TcM s (Class, InstEnv)
-
-buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _) : _)
-  = foldrNF_Tc addClassInstance
-	    emptyInstEnv
-	    inst_infos				`thenNF_Tc` \ class_inst_env ->
-    returnNF_Tc (clas, class_inst_env)
+buildInstanceEnv info = foldrNF_Tc addClassInstance emptyInstEnv (bagToList info)
 \end{code}
 
 @addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@
@@ -118,16 +93,16 @@ addClassInstance
 addClassInstance 
     (InstInfo clas inst_tyvars inst_tys _
 	      dfun_id _ src_loc _)
-    class_inst_env
+    inst_env
   = 	-- Add the instance to the class's instance environment
     case addToInstEnv opt_AllowOverlappingInstances 
-		      class_inst_env inst_tyvars inst_tys dfun_id of
+		      inst_env clas inst_tyvars inst_tys dfun_id of
 	Failed (tys', dfun_id')    -> addErrTc (dupInstErr clas (inst_tys, dfun_id) 
 							        (tys',     dfun_id'))
 						`thenNF_Tc_`
-				     returnNF_Tc class_inst_env
+				     returnNF_Tc inst_env
 
-	Succeeded class_inst_env' -> returnNF_Tc class_inst_env'
+	Succeeded inst_env' -> returnNF_Tc inst_env'
 \end{code}
 
 \begin{code}

ghc/compiler/typecheck/TcModule.lhs

@@ -27,7 +27,7 @@ import TcClassDcl	( tcClassDecls2, mkImplicitClassBinds )
 import TcDefaults	( tcDefaults )
 import TcEnv		( tcExtendGlobalValEnv, tcExtendTypeEnv,
 			  getEnvTyCons, getEnvClasses, tcLookupValueByKeyMaybe,
-			  explicitLookupValueByKey, tcSetValueEnv,
+			  explicitLookupValueByKey, tcSetValueEnv, tcSetInstEnv,
 			  initEnv, 
 			  ValueEnv, TcTyThing(..)
 			)
@@ -36,7 +36,7 @@ import TcRules		( tcRules )
 import TcForeign	( tcForeignImports, tcForeignExports )
 import TcIfaceSig	( tcInterfaceSigs )
 import TcInstDcls	( tcInstDecls1, tcInstDecls2 )
-import TcInstUtil	( buildInstanceEnvs, classDataCon, InstInfo )
+import TcInstUtil	( buildInstanceEnv, InstInfo )
 import TcSimplify	( tcSimplifyTop )
 import TcTyClsDecls	( tcTyAndClassDecls )
 import TcTyDecls	( mkImplicitDataBinds )
@@ -154,26 +154,19 @@ tcModule rn_name_supply fixities
 	-- unf_env is also used to get the pragam info
 	-- for imported dfuns and default methods
 
-    	    -- The knot for instance information.  This isn't used at all
-	    -- till we type-check value declarations
-    	fixTc ( \ ~(rec_inst_mapper, _, _, _) ->
-    
 		 -- Type-check the type and class decls
-		tcTyAndClassDecls unf_env rec_inst_mapper decls	`thenTc` \ env ->
+	tcTyAndClassDecls unf_env decls	`thenTc` \ env ->
     
 		    -- Typecheck the instance decls, includes deriving
-		tcSetEnv env (
-		tcInstDecls1 unf_env decls mod_name fixities rn_name_supply
-		)				`thenTc` \ (inst_info, deriv_binds) ->
-    
-    		buildInstanceEnvs inst_info	`thenNF_Tc` \ inst_mapper ->
-    
-		returnTc (inst_mapper, env, inst_info, deriv_binds)
-    
-    	-- End of inner fix loop
-    	) `thenTc` \ (_, env, inst_info, deriv_binds) ->
+	tcSetEnv env $
+
+	tcInstDecls1 unf_env decls 
+		     mod_name fixities 
+		     rn_name_supply	`thenTc` \ (inst_info, deriv_binds) ->
     
-    	tcSetEnv env 		(
+    	buildInstanceEnv inst_info	`thenNF_Tc` \ inst_env ->
+
+	tcSetInstEnv inst_env $
     	let
     	    tycons       = getEnvTyCons env
     	    classes      = getEnvClasses env
@@ -296,7 +289,6 @@ tcModule rn_name_supply fixities
 				tc_rules   = rules',
 				tc_env     = really_final_env
 		 }))
-	)
 
     -- End of outer fix loop
     ) `thenTc` \ (final_env, stuff) ->

ghc/compiler/typecheck/TcSimplify.lhs

@@ -143,18 +143,19 @@ import Inst		( lookupInst, lookupSimpleInst, LookupInstResult(..),
 			  mkLIE, emptyLIE, unitLIE, consLIE, plusLIE,
 			  lieToList, listToLIE
 			)
-import TcEnv		( tcGetGlobalTyVars )
+import TcEnv		( tcGetGlobalTyVars, tcGetInstEnv,
+			  InstEnv, lookupInstEnv, InstLookupResult(..) 
+			)
 import TcType		( TcType, TcTyVarSet, typeToTcType )
 import TcUnify		( unifyTauTy )
 import Id		( idType )
-import Class		( Class, classBigSig, classInstEnv )
+import Class		( Class, classBigSig )
 import PrelInfo		( isNumericClass, isCreturnableClass, isCcallishClass )
 
 import Type		( Type, ThetaType, TauType, ClassContext,
 			  mkTyVarTy, getTyVar,
 			  isTyVarTy, splitSigmaTy, tyVarsOfTypes
 			)
-import InstEnv		( InstEnv, lookupInstEnv, InstEnvResult(..) )
 import Subst		( mkTopTyVarSubst, substClasses )
 import PprType		( pprConstraint )
 import TysWiredIn	( unitTy )
@@ -840,12 +841,11 @@ a,b,c are type variables.  This is required for the context of
 instance declarations.
 
 \begin{code}
-tcSimplifyThetas :: (Class -> InstEnv)		-- How to find the InstEnv
-	       	 -> ClassContext		-- Wanted
+tcSimplifyThetas :: ClassContext		-- Wanted
 	       	 -> TcM s ClassContext		-- Needed
 
-tcSimplifyThetas inst_mapper wanteds
-  = reduceSimple inst_mapper [] wanteds		`thenNF_Tc` \ irreds ->
+tcSimplifyThetas wanteds
+  = 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
@@ -874,7 +874,7 @@ tcSimplifyCheckThetas :: ClassContext	-- Given
 		      -> TcM s ()
 
 tcSimplifyCheckThetas givens wanteds
-  = reduceSimple classInstEnv givens wanteds    `thenNF_Tc`	\ irreds ->
+  = reduceSimple givens wanteds    `thenNF_Tc`	\ irreds ->
     if null irreds then
        returnTc ()
     else
@@ -888,40 +888,38 @@ type AvailsSimple = FiniteMap (Class,[Type]) Bool
 		    -- True  => irreducible 
 		    -- False => given, or can be derived from a given or from an irreducible
 
-reduceSimple :: (Class -> InstEnv) 
-	     -> ClassContext			-- Given
+reduceSimple :: ClassContext			-- Given
 	     -> ClassContext			-- Wanted
 	     -> NF_TcM s ClassContext		-- Irreducible
 
-reduceSimple inst_mapper givens wanteds
-  = reduce_simple (0,[]) inst_mapper givens_fm wanteds	`thenNF_Tc` \ givens_fm' ->
+reduceSimple givens wanteds
+  = reduce_simple (0,[]) givens_fm wanteds	`thenNF_Tc` \ givens_fm' ->
     returnNF_Tc [ct | (ct,True) <- fmToList givens_fm']
   where
     givens_fm     = foldl addNonIrred emptyFM givens
 
 reduce_simple :: (Int,ClassContext)		-- Stack
-	      -> (Class -> InstEnv) 
 	      -> AvailsSimple
 	      -> ClassContext
 	      -> NF_TcM s AvailsSimple
 
-reduce_simple (n,stack) inst_mapper avails wanteds
+reduce_simple (n,stack) avails wanteds
   = go avails wanteds
   where
     go avails []     = returnNF_Tc avails
-    go avails (w:ws) = reduce_simple_help (n+1,w:stack) inst_mapper avails w	`thenNF_Tc` \ avails' ->
+    go avails (w:ws) = reduce_simple_help (n+1,w:stack) avails w	`thenNF_Tc` \ avails' ->
 		       go avails' ws
 
-reduce_simple_help stack inst_mapper givens wanted@(clas,tys)
+reduce_simple_help stack givens wanted@(clas,tys)
   | wanted `elemFM` givens
   = returnNF_Tc givens
 
   | otherwise
-  = lookupSimpleInst (inst_mapper clas) clas tys	`thenNF_Tc` \ maybe_theta ->
+  = lookupSimpleInst clas tys	`thenNF_Tc` \ maybe_theta ->
 
     case maybe_theta of
       Nothing ->    returnNF_Tc (addIrred givens wanted)
-      Just theta -> reduce_simple stack inst_mapper (addNonIrred givens wanted) theta
+      Just theta -> reduce_simple stack (addNonIrred givens wanted) theta
 
 addIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple
 addIrred givens ct@(clas,tys)
@@ -1265,45 +1263,52 @@ addTopInstanceErr dict
   where
     (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
 
+-- The error message when we don't find a suitable instance
+-- is complicated by the fact that sometimes this is because
+-- there is no instance, and sometimes it's because there are
+-- too many instances (overlap).  See the comments in TcEnv.lhs
+-- with the InstEnv stuff.
 addNoInstanceErr str givens dict
-  = addInstErrTcM (instLoc dict) (tidy_env, doc)
-  where
-    doc = vcat [herald <+> quotes (pprInst tidy_dict),
-	        nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens,
-		ambig_doc,
-		ptext SLIT("Probable fix:"),
-		nest 4 fix1,
-		nest 4 fix2]
-
-    herald = ptext SLIT("Could not") <+> unambig_doc <+> ptext SLIT("deduce")
-    unambig_doc | ambig_overlap = ptext SLIT("unambiguously")	
-		| otherwise     = empty
-
-    ambig_doc 
-	| not ambig_overlap = empty
-	| otherwise 	    
-	= vcat [ptext SLIT("The choice of (overlapping) instance declaration"),
-		nest 4 (ptext SLIT("depends on the instantiation of") <+> 
-		     	quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst tidy_dict))))]
-
-    fix1 = sep [ptext SLIT("Add") <+> quotes (pprInst tidy_dict),
-		ptext SLIT("to the") <+> str]
-
-    fix2 | isTyVarDict dict || ambig_overlap
-	   = empty
-	   | otherwise
-	   = ptext SLIT("Or add an instance declaration for") <+> quotes (pprInst tidy_dict)
-
-    (tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens)
-
-	-- Checks for the ambiguous case when we have overlapping instances
-    ambig_overlap | isClassDict dict
-		  = case lookupInstEnv (classInstEnv clas) tys of
-			NoMatch ambig -> ambig
-		      	other 	    -> False
-		  | otherwise = False
-	 	  where
-		    (clas,tys) = getDictClassTys dict
+  = tcGetInstEnv	`thenNF_Tc` \ inst_env ->
+    let
+    	doc = vcat [herald <+> quotes (pprInst tidy_dict),
+		    nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens,
+		    ambig_doc,
+		    ptext SLIT("Probable fix:"),
+		    nest 4 fix1,
+		    nest 4 fix2]
+    
+    	herald = ptext SLIT("Could not") <+> unambig_doc <+> ptext SLIT("deduce")
+    	unambig_doc | ambig_overlap = ptext SLIT("unambiguously")	
+		    | otherwise     = empty
+    
+    	ambig_doc 
+	    | not ambig_overlap = empty
+	    | otherwise 	    
+	    = vcat [ptext SLIT("The choice of (overlapping) instance declaration"),
+		    nest 4 (ptext SLIT("depends on the instantiation of") <+> 
+			    quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst tidy_dict))))]
+    
+    	fix1 = sep [ptext SLIT("Add") <+> quotes (pprInst tidy_dict),
+		    ptext SLIT("to the") <+> str]
+    
+    	fix2 | isTyVarDict dict || ambig_overlap
+	     = empty
+	     | otherwise
+	     = ptext SLIT("Or add an instance declaration for") <+> quotes (pprInst tidy_dict)
+    
+    	(tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens)
+    
+	    -- Checks for the ambiguous case when we have overlapping instances
+    	ambig_overlap | isClassDict dict
+		      = case lookupInstEnv inst_env clas tys of
+			    NoMatch ambig -> ambig
+			    other 	  -> False
+		      | otherwise = False
+		      where
+    			(clas,tys) = getDictClassTys dict
+    in
+    addInstErrTcM (instLoc dict) (tidy_env, doc)
 
 -- Used for the ...Thetas variants; all top level
 addNoInstErr (c,ts)

ghc/compiler/typecheck/TcTyClsDecls.lhs

@@ -20,7 +20,6 @@ import RnHsSyn		( RenamedHsDecl, RenamedTyClDecl, listTyCon_name )
 import BasicTypes	( RecFlag(..), NewOrData(..), Arity )
 
 import TcMonad