X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FInst.lhs;h=1e99572c5e8b809c5cf3a70a23c463d3b3fc4443;hb=7bb069508f094825ca136ed97606651f3e093123;hp=155ed13c4d2f07b21cd7f37d041996b70fe9d86c;hpb=69e14f75a4b031e489b7774914e5a176409cea78;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index 155ed13..1e99572 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -4,28 +4,35 @@
 \section[Inst]{The @Inst@ type: dictionaries or method instances}
 
 \begin{code}
-module Inst (
+module Inst ( 
 	LIE, emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE,
-	plusLIEs, mkLIE, isEmptyLIE,
+	plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
 
 	Inst, OverloadedLit(..),
 	pprInst, pprInsts, pprInstsInFull, tidyInst, tidyInsts,
 
-        InstanceMapper,
+	newDictFromOld, newDicts, newClassDicts, newDictsAtLoc,
+	newMethod, newMethodWithGivenTy, newOverloadedLit,
+	newIPDict, instOverloadedFun,
+	instantiateFdClassTys, instFunDeps, instFunDepsOfTheta,
+	newFunDepFromDict,
 
-	newDictFromOld, newDicts, newDictsAtLoc, 
-	newMethod, newMethodWithGivenTy, newOverloadedLit, instOverloadedFun,
-
-	tyVarsOfInst, instLoc, getDictClassTys,
+	tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, instLoc, getDictClassTys,
+	getDictPred_maybe, getMethodTheta_maybe,
+	getFunDeps, getFunDepsOfLIE,
+	getIPs, getIPsOfLIE,
+	getAllFunDeps, getAllFunDepsOfLIE,
 
 	lookupInst, lookupSimpleInst, LookupInstResult(..),
 
-	isDict, isTyVarDict, isStdClassTyVarDict, isMethodFor,
+	isDict, isClassDict, isMethod,
+	isTyVarDict, isStdClassTyVarDict, isMethodFor, notFunDep,
 	instBindingRequired, instCanBeGeneralised,
 
-	zonkInst, instToId, instToIdBndr,
+	zonkInst, zonkInsts, zonkFunDeps, zonkTvFunDeps,
+	instToId, instToIdBndr, ipToId,
 
-	InstOrigin(..), pprOrigin
+	InstOrigin(..), InstLoc, pprInstLoc
     ) where
 
 #include "HsVersions.h"
@@ -33,49 +40,54 @@ module Inst (
 import HsSyn	( HsLit(..), HsExpr(..) )
 import RnHsSyn	( RenamedArithSeqInfo, RenamedHsExpr, RenamedPat )
 import TcHsSyn	( TcExpr, TcId, 
-		  mkHsTyApp, mkHsDictApp, zonkId
+		  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,
-		  zonkTcType, zonkTcTypes, 
+		  zonkTcTyVars, zonkTcType, zonkTcTypes, 
 		  zonkTcThetaType
 		)
 import Bag
-import Class	( classInstEnv, Class )
+import Class	( Class, FunDep )
+import FunDeps	( instantiateFdClassTys )
 import Id	( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal )
-import VarSet	( elemVarSet )
 import PrelInfo	( isStandardClass, isCcallishClass, isNoDictClass )
-import Name	( OccName, Name, mkDictOcc, mkMethodOcc, getOccName )
-import PprType	( pprConstraint )	
-import InstEnv	( InstEnv, lookupInstEnv )
+import Name	( OccName, Name, mkDictOcc, mkMethodOcc, mkIPOcc,
+		  getOccName, nameUnique )
+import PprType	( pprPred )	
 import SrcLoc	( SrcLoc )
-import Type	( Type, ThetaType,
-		  mkTyVarTy, isTyVarTy, mkDictTy, splitForAllTys, splitSigmaTy,
-		  splitRhoTy, tyVarsOfType, tyVarsOfTypes,
+import Type	( Type, PredType(..), ThetaType,
+		  mkTyVarTy, isTyVarTy, mkDictTy, mkPredTy,
+		  splitForAllTys, splitSigmaTy,
+		  splitRhoTy, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
 		  mkSynTy, tidyOpenType, tidyOpenTypes
 		)
-import InstEnv	( InstEnv )
 import Subst	( emptyInScopeSet, mkSubst,
-		  substTy, substTheta, mkTyVarSubst, mkTopTyVarSubst
+		  substTy, substClasses, mkTyVarSubst, mkTopTyVarSubst
 		)
 import TyCon	( TyCon )
-import Subst	( mkTyVarSubst )
+import Literal	( inIntRange )
+import Var	( TyVar )
 import VarEnv	( lookupVarEnv, TidyEnv,
 		  lookupSubstEnv, SubstResult(..)
 		)
-import VarSet	( unionVarSet )
+import VarSet	( elemVarSet, emptyVarSet, unionVarSet )
 import TysPrim	  ( intPrimTy, floatPrimTy, doublePrimTy )
-import TysWiredIn ( intDataCon, isIntTy, inIntRange,
+import TysWiredIn ( intDataCon, isIntTy,
 		    floatDataCon, isFloatTy,
 		    doubleDataCon, isDoubleTy,
-		    integerTy, isIntegerTy
+		    integerTy, isIntegerTy,
+		    voidTy
 		  ) 
 import Unique	( fromRationalClassOpKey, rationalTyConKey,
 		  fromIntClassOpKey, fromIntegerClassOpKey, Unique
 		)
 import Maybes	( expectJust )
+import Maybe	( catMaybes )
 import Util	( thenCmp, zipWithEqual, mapAccumL )
 import Outputable
 \end{code}
@@ -96,6 +108,8 @@ mkLIE insts	  = listToBag insts
 plusLIE lie1 lie2 = lie1 `unionBags` lie2
 consLIE inst lie  = inst `consBag` lie
 plusLIEs lies	  = unionManyBags lies
+lieToList	  = bagToList
+listToLIE	  = listToBag
 
 zonkLIE :: LIE -> NF_TcM s LIE
 zonkLIE lie = mapBagNF_Tc zonkInst lie
@@ -107,7 +121,7 @@ pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
 pprInstsInFull insts
   = vcat (map go insts)
   where
-    go inst = quotes (ppr inst) <+> pprOrigin inst
+    go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
 \end{code}
 
 %************************************************************************
@@ -128,10 +142,8 @@ type Int, represented by
 data Inst
   = Dict
 	Unique
-	Class		-- The type of the dict is (c ts), where
-	[TcType]	-- c is the class and ts the types;
-	InstOrigin
-	SrcLoc
+	TcPredType
+	InstLoc
 
   | Method
 	Unique
@@ -152,8 +164,7 @@ data Inst
 
 	TcTauType	-- The type of the method
 
-	InstOrigin
-	SrcLoc
+	InstLoc
 
 	-- INVARIANT: in (Method u f tys theta tau loc)
 	--	type of (f tys dicts(from theta)) = tau
@@ -162,8 +173,13 @@ data Inst
 	Unique
 	OverloadedLit
 	TcType		-- The type at which the literal is used
-	InstOrigin	-- Always a literal; but more convenient to carry this around
-	SrcLoc
+	InstLoc
+
+  | FunDep
+	Unique
+	Class		-- the class from which this arises
+	[FunDep TcType]
+	InstLoc
 
 data OverloadedLit
   = OverloadedIntegral	 Integer	-- The number
@@ -185,23 +201,19 @@ instance Eq Inst where
 	         EQ    -> True
 		 other -> False
 
-cmpInst  (Dict _ clas1 tys1 _ _) (Dict _ clas2 tys2 _ _)
-  = (clas1 `compare` clas2) `thenCmp` (tys1 `compare` tys2)
-cmpInst (Dict _ _ _ _ _) other
-  = LT
+cmpInst (Dict _ pred1 _)     	  (Dict _ pred2 _)	    = (pred1 `compare` pred2)
+cmpInst (Dict _ _ _)	     	  other 		    = LT
 
+cmpInst (Method _ _ _ _ _ _) 	  (Dict _ _ _)	  	    = GT
+cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2)
+cmpInst (Method _ _ _ _ _ _)      other			    = LT
 
-cmpInst (Method _ _ _ _ _ _ _) (Dict _ _ _ _ _)
-  = GT
-cmpInst (Method _ id1 tys1 _ _ _ _) (Method _ id2 tys2 _ _ _ _)
-  = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2)
-cmpInst (Method _ _ _ _ _ _ _) other
-  = LT
+cmpInst (LitInst _ lit1 ty1 _)	  (LitInst _ lit2 ty2 _)    = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2)
+cmpInst (LitInst _ _ _ _)	  (FunDep _ _ _ _)	    = LT
+cmpInst (LitInst _ _ _ _)	  other 		    = GT
 
-cmpInst (LitInst _ lit1 ty1 _ _) (LitInst _ lit2 ty2 _ _)
-  = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2)
-cmpInst (LitInst _ _ _ _ _) other
-  = GT
+cmpInst (FunDep _ clas1 fds1 _)   (FunDep _ clas2 fds2 _)   = (clas1 `compare` clas2) `thenCmp` (fds1 `compare` fds2)
+cmpInst (FunDep _ _ _ _)	  other			    = GT
 
 cmpOverLit (OverloadedIntegral   i1) (OverloadedIntegral   i2) = i1 `compare` i2
 cmpOverLit (OverloadedFractional f1) (OverloadedFractional f2) = f1 `compare` f2
@@ -213,43 +225,89 @@ cmpOverLit (OverloadedFractional _)  (OverloadedIntegral _)    = GT
 Selection
 ~~~~~~~~~
 \begin{code}
-instOrigin (Dict   u clas tys    origin loc) = origin
-instOrigin (Method u clas ty _ _ origin loc) = origin
-instOrigin (LitInst u lit ty     origin loc) = origin
+instLoc (Dict   u pred      loc) = loc
+instLoc (Method u _ _ _ _   loc) = loc
+instLoc (LitInst u lit ty   loc) = loc
+instLoc (FunDep _ _ _	    loc) = loc
+
+getDictPred_maybe (Dict _ p _) = Just p
+getDictPred_maybe _	       = Nothing
+
+getMethodTheta_maybe (Method _ _ _ theta _ _) = Just theta
+getMethodTheta_maybe _			      = Nothing
+
+getDictClassTys (Dict u (Class clas tys) _) = (clas, tys)
+
+getFunDeps (FunDep _ clas fds _) = Just (clas, fds)
+getFunDeps _ = Nothing
+
+getFunDepsOfLIE lie = catMaybes (map getFunDeps (lieToList lie))
+
+getIPsOfPred (IParam n ty) = [(n, ty)]
+getIPsOfPred _             = []
+getIPsOfTheta theta = concatMap getIPsOfPred theta
+
+getIPs (Dict u (IParam n ty) loc) = [(n, ty)]
+getIPs (Method u id _ theta t loc) = getIPsOfTheta theta
+getIPs _ = []
 
-instLoc (Dict   u clas tys    origin loc) = loc
-instLoc (Method u clas ty _ _ origin loc) = loc
-instLoc (LitInst u lit ty     origin loc) = loc
+getIPsOfLIE lie = concatMap getIPs (lieToList lie)
 
-getDictClassTys (Dict u clas tys _ _) = (clas, tys)
+getAllFunDeps (FunDep _ clas fds _) = fds
+getAllFunDeps inst = map (\(n,ty) -> ([], [ty])) (getIPs inst)
+
+getAllFunDepsOfLIE lie = concat (map getAllFunDeps (lieToList lie))
 
 tyVarsOfInst :: Inst -> TcTyVarSet
-tyVarsOfInst (Dict _ _ tys _ _)        = tyVarsOfTypes  tys
-tyVarsOfInst (Method _ id tys _ _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
+tyVarsOfInst (Dict _ pred _)         = tyVarsOfPred pred
+tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
 					 -- The id might have free type variables; in the case of
 					 -- locally-overloaded class methods, for example
-tyVarsOfInst (LitInst _ _ ty _ _)     = tyVarsOfType  ty
+tyVarsOfInst (LitInst _ _ ty _)      = tyVarsOfType  ty
+tyVarsOfInst (FunDep _ _ fds _)
+  = foldr unionVarSet emptyVarSet (map tyVarsOfFd fds)
+  where tyVarsOfFd (ts1, ts2) =
+	    tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts2
+
+tyVarsOfInsts insts
+  = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts)
+
+tyVarsOfLIE lie
+  = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts)
+  where insts = lieToList lie
 \end{code}
 
 Predicates
 ~~~~~~~~~~
 \begin{code}
 isDict :: Inst -> Bool
-isDict (Dict _ _ _ _ _) = True
-isDict other	        = False
+isDict (Dict _ _ _) = True
+isDict other	    = False
+
+isClassDict :: Inst -> Bool
+isClassDict (Dict _ (Class _ _) _) = True
+isClassDict other		   = False
+
+isMethod :: Inst -> Bool
+isMethod (Method _ _ _ _ _ _) = True
+isMethod other		      = False
 
 isMethodFor :: TcIdSet -> Inst -> Bool
-isMethodFor ids (Method uniq id tys _ _ orig 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 _ _ tys _ _) = all isTyVarTy tys
-isTyVarDict other 	       = False
+isTyVarDict (Dict _ (Class _ tys) _) = all isTyVarTy tys
+isTyVarDict other		     = False
+
+isStdClassTyVarDict (Dict _ (Class clas [ty]) _)
+  = isStandardClass clas && isTyVarTy ty
+isStdClassTyVarDict other
+  = False
 
-isStdClassTyVarDict (Dict _ clas [ty] _ _) = isStandardClass clas && isTyVarTy ty
-isStdClassTyVarDict other		   = False
+notFunDep :: Inst -> Bool
+notFunDep (FunDep _ _ _ _) = False
+notFunDep other		   = True
 \end{code}
 
 Two predicates which deal with the case where class constraints don't
@@ -259,12 +317,13 @@ must be witnessed by an actual binding; the second tells whether an
 
 \begin{code}
 instBindingRequired :: Inst -> Bool
-instBindingRequired (Dict _ clas _ _ _) = not (isNoDictClass clas)
-instBindingRequired other		= True
+instBindingRequired (Dict _ (Class clas _) _) = not (isNoDictClass clas)
+instBindingRequired (Dict _ (IParam _ _) _)   = False
+instBindingRequired other		      = True
 
 instCanBeGeneralised :: Inst -> Bool
-instCanBeGeneralised (Dict _ clas _ _ _) = not (isCcallishClass clas)
-instCanBeGeneralised other		 = True
+instCanBeGeneralised (Dict _ (Class clas _) _) = not (isCcallishClass clas)
+instCanBeGeneralised other		       = True
 \end{code}
 
 
@@ -276,28 +335,33 @@ newDicts :: InstOrigin
 	 -> TcThetaType
 	 -> NF_TcM s (LIE, [TcId])
 newDicts orig theta
-  = tcGetSrcLoc				`thenNF_Tc` \ loc ->
-    newDictsAtLoc orig loc theta        `thenNF_Tc` \ (dicts, ids) ->
+  = tcGetInstLoc orig		`thenNF_Tc` \ loc ->
+    newDictsAtLoc loc theta	`thenNF_Tc` \ (dicts, ids) ->
     returnNF_Tc (listToBag dicts, ids)
 
+newClassDicts :: InstOrigin
+	      -> [(Class,[TcType])]
+	      -> NF_TcM s (LIE, [TcId])
+newClassDicts orig theta
+  = newDicts orig (map (uncurry Class) theta)
+
 -- Local function, similar to newDicts, 
 -- but with slightly different interface
-newDictsAtLoc :: InstOrigin
-              -> SrcLoc
+newDictsAtLoc :: InstLoc
  	      -> TcThetaType
 	      -> NF_TcM s ([Inst], [TcId])
-newDictsAtLoc orig loc theta =
+newDictsAtLoc loc theta =
  tcGetUniques (length theta)		`thenNF_Tc` \ new_uniqs ->
  let
-  mk_dict u (clas, tys) = Dict u clas tys orig loc
+  mk_dict u pred = Dict u pred loc
   dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
  in
  returnNF_Tc (dicts, map instToId dicts)
 
 newDictFromOld :: Inst -> Class -> [TcType] -> NF_TcM s Inst
-newDictFromOld (Dict _ _ _ orig loc) clas tys
+newDictFromOld (Dict _ _ loc) clas tys
   = tcGetUnique	      `thenNF_Tc` \ uniq ->
-    returnNF_Tc (Dict uniq clas tys orig loc)
+    returnNF_Tc (Dict uniq (Class clas tys) loc)
 
 
 newMethod :: InstOrigin
@@ -314,22 +378,38 @@ newMethod orig id tys
     newMethodWithGivenTy orig id tys theta tau	`thenNF_Tc` \ meth_inst ->
     returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
 
-instOverloadedFun orig (HsVar v) arg_tys theta tau
+instOverloadedFun orig v arg_tys theta tau
+-- This is where we introduce new functional dependencies into the LIE
   = newMethodWithGivenTy orig v arg_tys theta tau	`thenNF_Tc` \ inst ->
-    returnNF_Tc (HsVar (instToId inst), unitLIE inst)
+    instFunDeps orig theta				`thenNF_Tc` \ fds ->
+    returnNF_Tc (instToId inst, mkLIE (inst : fds))
+
+instFunDeps orig theta
+  = tcGetUnique		`thenNF_Tc` \ uniq ->
+    tcGetInstLoc orig	`thenNF_Tc` \ loc ->
+    let ifd (Class clas tys) =
+	    let fds = instantiateFdClassTys clas tys in
+	    if null fds then Nothing else Just (FunDep uniq clas fds loc)
+	ifd _ = Nothing
+    in returnNF_Tc (catMaybes (map ifd theta))
+
+instFunDepsOfTheta theta
+  = let ifd (Class clas tys) = instantiateFdClassTys clas tys
+	ifd (IParam n ty)    = [([], [ty])]
+    in concat (map ifd theta)
 
 newMethodWithGivenTy orig id tys theta tau
-  = tcGetSrcLoc		`thenNF_Tc` \ loc ->
-    tcGetUnique		`thenNF_Tc` \ new_uniq ->
-    let
-	meth_inst = Method new_uniq id tys theta tau orig loc
-    in
-    returnNF_Tc meth_inst
+  = tcGetInstLoc orig	`thenNF_Tc` \ loc ->
+    newMethodWith id tys theta tau loc
 
-newMethodAtLoc :: InstOrigin -> SrcLoc
+newMethodWith id tys theta tau loc
+  = tcGetUnique		`thenNF_Tc` \ new_uniq ->
+    returnNF_Tc (Method new_uniq id tys theta tau loc)
+
+newMethodAtLoc :: InstLoc
 	       -> Id -> [TcType]
 	       -> NF_TcM s (Inst, TcId)
-newMethodAtLoc orig loc real_id tys	-- Local function, similar to newMethod but with 
+newMethodAtLoc loc real_id tys		-- Local function, similar to newMethod but with 
 					-- slightly different interface
   =   	-- Get the Id type and instantiate it at the specified types
     tcGetUnique					`thenNF_Tc` \ new_uniq ->
@@ -338,7 +418,7 @@ newMethodAtLoc orig loc real_id tys	-- Local function, similar to newMethod but
 	rho_ty	      = ASSERT( length tyvars == length tys )
 			substTy (mkTopTyVarSubst tyvars tys) rho
 	(theta, tau)  = splitRhoTy rho_ty
-	meth_inst     = Method new_uniq real_id tys theta tau orig loc
+	meth_inst     = Method new_uniq real_id tys theta tau loc
     in
     returnNF_Tc (meth_inst, instToId meth_inst)
 \end{code}
@@ -363,31 +443,55 @@ newOverloadedLit orig (OverloadedIntegral i) ty
   where
     intprim_lit    = HsLitOut (HsIntPrim i) intPrimTy
     integer_lit    = HsLitOut (HsInt i) integerTy
-    int_lit        = HsCon intDataCon [] [intprim_lit]
+    int_lit        = mkHsConApp intDataCon [] [intprim_lit]
 
 newOverloadedLit orig lit ty		-- The general case
-  = tcGetSrcLoc			`thenNF_Tc` \ loc ->
+  = tcGetInstLoc orig		`thenNF_Tc` \ loc ->
     tcGetUnique			`thenNF_Tc` \ new_uniq ->
     let
-	lit_inst = LitInst new_uniq lit ty orig loc
+	lit_inst = LitInst new_uniq lit ty loc
     in
     returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
 \end{code}
 
+\begin{code}
+newFunDepFromDict dict
+  = tcGetUnique		`thenNF_Tc` \ uniq ->
+    let (clas, tys) = getDictClassTys dict
+	fds = instantiateFdClassTys clas tys
+	inst = FunDep uniq clas fds (instLoc dict)
+    in
+	if null fds then returnNF_Tc Nothing else returnNF_Tc (Just inst)
+\end{code}
+
+\begin{code}
+newIPDict name ty loc
+  = tcGetUnique		`thenNF_Tc` \ new_uniq ->
+    let d = Dict new_uniq (IParam name ty) loc in
+    returnNF_Tc d
+\end{code}
 
 \begin{code}
 instToId :: Inst -> TcId
 instToId inst = instToIdBndr inst
 
 instToIdBndr :: Inst -> TcId
-instToIdBndr (Dict u clas ty orig loc)
-  = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas ty) loc
+instToIdBndr (Dict u (Class clas tys) (_,loc,_))
+  = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas tys) loc
+instToIdBndr (Dict u (IParam n ty) (_,loc,_))
+  = ipToId n ty loc
 
-instToIdBndr (Method u id tys theta tau orig loc)
+instToIdBndr (Method u id tys theta tau (_,loc,_))
   = mkUserLocal (mkMethodOcc (getOccName id)) u tau loc
-    
-instToIdBndr (LitInst u list ty orig loc)
+
+instToIdBndr (LitInst u list ty loc)
   = mkSysLocal SLIT("lit") u ty
+
+instToIdBndr (FunDep u clas fds _)
+  = mkSysLocal SLIT("FunDep") u voidTy
+
+ipToId n ty loc
+  = mkUserLocal (mkIPOcc (getOccName n)) (nameUnique n) (mkPredTy (IParam n ty)) loc
 \end{code}
 
 
@@ -398,12 +502,20 @@ but doesn't do the same for the Id in a Method.  There's no
 need, and it's a lot of extra work.
 
 \begin{code}
+zonkPred :: TcPredType -> NF_TcM s TcPredType
+zonkPred (Class clas tys)
+  = zonkTcTypes tys			`thenNF_Tc` \ new_tys ->
+    returnNF_Tc (Class clas new_tys)
+zonkPred (IParam n ty)
+  = zonkTcType ty			`thenNF_Tc` \ new_ty ->
+    returnNF_Tc (IParam n new_ty)
+
 zonkInst :: Inst -> NF_TcM s Inst
-zonkInst (Dict u clas tys orig loc)
-  = zonkTcTypes	tys			`thenNF_Tc` \ new_tys ->
-    returnNF_Tc (Dict u clas new_tys orig loc)
+zonkInst (Dict u pred loc)
+  = zonkPred pred			`thenNF_Tc` \ new_pred ->
+    returnNF_Tc (Dict u new_pred loc)
 
-zonkInst (Method u id tys theta tau orig loc) 
+zonkInst (Method u id tys theta tau loc) 
   = zonkId id			`thenNF_Tc` \ new_id ->
 	-- Essential to zonk the id in case it's a local variable
 	-- Can't use zonkIdOcc because the id might itself be
@@ -412,11 +524,32 @@ zonkInst (Method u id tys theta tau orig loc)
     zonkTcTypes tys		`thenNF_Tc` \ new_tys ->
     zonkTcThetaType theta	`thenNF_Tc` \ new_theta ->
     zonkTcType tau		`thenNF_Tc` \ new_tau ->
-    returnNF_Tc (Method u new_id new_tys new_theta new_tau orig loc)
+    returnNF_Tc (Method u new_id new_tys new_theta new_tau loc)
 
-zonkInst (LitInst u lit ty orig loc)
+zonkInst (LitInst u lit ty loc)
   = zonkTcType ty			`thenNF_Tc` \ new_ty ->
-    returnNF_Tc (LitInst u lit new_ty orig loc)
+    returnNF_Tc (LitInst u lit new_ty loc)
+
+zonkInst (FunDep u clas fds loc)
+  = zonkFunDeps fds			`thenNF_Tc` \ fds' ->
+    returnNF_Tc (FunDep u clas fds' loc)
+
+zonkPreds preds = mapNF_Tc zonkPred preds
+zonkInsts insts = mapNF_Tc zonkInst insts
+
+zonkFunDeps fds = mapNF_Tc zonkFd fds
+  where
+  zonkFd (ts1, ts2)
+    = zonkTcTypes ts1			`thenNF_Tc` \ ts1' ->
+      zonkTcTypes ts2			`thenNF_Tc` \ ts2' ->
+      returnNF_Tc (ts1', ts2')
+
+zonkTvFunDeps fds = mapNF_Tc zonkFd fds
+  where
+  zonkFd (tvs1, tvs2)
+    = zonkTcTyVars tvs1			`thenNF_Tc` \ tvs1' ->
+      zonkTcTyVars tvs2			`thenNF_Tc` \ tvs2' ->
+      returnNF_Tc (tvs1', tvs2')
 \end{code}
 
 
@@ -429,7 +562,7 @@ relevant in error messages.
 instance Outputable Inst where
     ppr inst = pprInst inst
 
-pprInst (LitInst u lit ty orig loc)
+pprInst (LitInst u lit ty loc)
   = hsep [case lit of
 	      OverloadedIntegral   i -> integer i
 	      OverloadedFractional f -> rational f,
@@ -437,30 +570,49 @@ pprInst (LitInst u lit ty orig loc)
 	   ppr ty,
 	   show_uniq u]
 
-pprInst (Dict u clas tys orig loc) = pprConstraint clas tys <+> show_uniq u
+pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
 
-pprInst (Method u id tys _ _ orig loc)
+pprInst m@(Method u id tys theta tau loc)
   = hsep [ppr id, ptext SLIT("at"), 
-	  brackets (interppSP tys),
-	  show_uniq u]
+	  brackets (interppSP tys) {- ,
+	  ppr theta, ppr tau,
+	  show_uniq u,
+	  ppr (instToId m) -}]
+
+pprInst (FunDep _ clas fds loc)
+  = hsep [ppr clas, ppr fds]
+
+tidyPred :: TidyEnv -> TcPredType -> (TidyEnv, TcPredType)
+tidyPred env (Class clas tys)
+  = (env', Class clas tys')
+  where
+    (env', tys') = tidyOpenTypes env tys
+tidyPred env (IParam n ty)
+  = (env', IParam n ty')
+  where
+    (env', ty') = tidyOpenType env ty
 
 tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst)
-tidyInst env (LitInst u lit ty orig loc)
-  = (env', LitInst u lit ty' orig loc)
+tidyInst env (LitInst u lit ty loc)
+  = (env', LitInst u lit ty' loc)
   where
     (env', ty') = tidyOpenType env ty
 
-tidyInst env (Dict u clas tys orig loc)
-  = (env', Dict u clas tys' orig loc)
+tidyInst env (Dict u pred loc)
+  = (env', Dict u pred' loc)
   where
-    (env', tys') = tidyOpenTypes env tys
+    (env', pred') = tidyPred env pred
 
-tidyInst env (Method u id tys theta tau orig loc)
-  = (env', Method u id tys' theta tau orig loc)
+tidyInst env (Method u id tys theta tau loc)
+  = (env', Method u id tys' theta tau loc)
 		-- Leave theta, tau alone cos we don't print them
   where
     (env', tys') = tidyOpenTypes env tys
-    
+
+-- this case shouldn't arise... (we never print fundeps)
+tidyInst env fd@(FunDep _ clas fds loc)
+  = (env, fd)
+
 tidyInsts env insts = mapAccumL tidyInst env insts
 
 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
@@ -474,25 +626,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
   | SimpleInst TcExpr		-- Just a variable, type application, or literal
@@ -503,10 +636,11 @@ lookupInst :: Inst
 
 -- Dictionaries
 
-lookupInst dict@(Dict _ clas tys orig loc)
-  = case lookupInstEnv (ppr clas) (classInstEnv clas) tys of
+lookupInst dict@(Dict _ (Class clas tys) loc)
+  = tcGetInstEnv		`thenNF_Tc` \ inst_env ->
+    case lookupInstEnv inst_env clas tys of
 
-      Just (tenv, dfun_id)
+      FoundInst tenv dfun_id
 	-> let
 		subst	      = mkSubst (tyVarsOfTypes tys) tenv
 		(tyvars, rho) = splitForAllTys (idType dfun_id)
@@ -521,23 +655,24 @@ lookupInst dict@(Dict _ clas tys orig loc)
 	   if null theta then
 		returnNF_Tc (SimpleInst ty_app)
 	   else
-	   newDictsAtLoc orig loc theta	`thenNF_Tc` \ (dicts, dict_ids) ->
+	   newDictsAtLoc loc theta	`thenNF_Tc` \ (dicts, dict_ids) ->
 	   let 
 		rhs = mkHsDictApp ty_app dict_ids
 	   in
 	   returnNF_Tc (GenInst dicts rhs)
-			     
-      Nothing	-> returnNF_Tc NoInstance
+
+      other	-> returnNF_Tc NoInstance
+lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
 
 -- Methods
 
-lookupInst inst@(Method _ id tys theta _ orig loc)
-  = newDictsAtLoc orig loc theta	`thenNF_Tc` \ (dicts, dict_ids) ->
+lookupInst inst@(Method _ id tys theta _ loc)
+  = newDictsAtLoc loc theta		`thenNF_Tc` \ (dicts, dict_ids) ->
     returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
 
 -- Literals
 
-lookupInst inst@(LitInst u (OverloadedIntegral i) ty orig loc)
+lookupInst inst@(LitInst u (OverloadedIntegral i) ty loc)
   | isIntTy ty && in_int_range			-- Short cut for Int
   = returnNF_Tc (GenInst [] int_lit)
 	-- GenInst, not SimpleInst, because int_lit is actually a constructor application
@@ -547,29 +682,29 @@ lookupInst inst@(LitInst u (OverloadedIntegral i) ty orig loc)
 
   | in_int_range				-- It's overloaded but small enough to fit into an Int
   = tcLookupValueByKey fromIntClassOpKey	`thenNF_Tc` \ from_int ->
-    newMethodAtLoc orig loc from_int [ty]	`thenNF_Tc` \ (method_inst, method_id) ->
+    newMethodAtLoc loc from_int [ty]		`thenNF_Tc` \ (method_inst, method_id) ->
     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
 
   | otherwise   				-- Alas, it is overloaded and a big literal!
   = tcLookupValueByKey fromIntegerClassOpKey	`thenNF_Tc` \ from_integer ->
-    newMethodAtLoc orig loc from_integer [ty]		`thenNF_Tc` \ (method_inst, method_id) ->
+    newMethodAtLoc loc from_integer [ty]	`thenNF_Tc` \ (method_inst, method_id) ->
     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
   where
     in_int_range   = inIntRange i
     intprim_lit    = HsLitOut (HsIntPrim i) intPrimTy
     integer_lit    = HsLitOut (HsInt i) integerTy
-    int_lit        = HsCon intDataCon [] [intprim_lit]
+    int_lit        = mkHsConApp intDataCon [] [intprim_lit]
 
 -- similar idea for overloaded floating point literals: if the literal is
 -- *definitely* a float or a double, generate the real thing here.
 -- This is essential  (see nofib/spectral/nucleic).
 
-lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc)
+lookupInst inst@(LitInst u (OverloadedFractional f) ty loc)
   | isFloatTy ty    = returnNF_Tc (GenInst [] float_lit)
   | isDoubleTy ty   = returnNF_Tc (GenInst [] double_lit)
 
   | otherwise 
-	  = tcLookupValueByKey fromRationalClassOpKey	`thenNF_Tc` \ from_rational ->
+  = tcLookupValueByKey fromRationalClassOpKey	`thenNF_Tc` \ from_rational ->
 
 	-- The type Rational isn't wired in so we have to conjure it up
     tcLookupTyConByKey rationalTyConKey	`thenNF_Tc` \ rational_tycon ->
@@ -577,14 +712,18 @@ lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc)
 	rational_ty  = mkSynTy rational_tycon []
 	rational_lit = HsLitOut (HsFrac f) rational_ty
     in
-    newMethodAtLoc orig loc from_rational [ty]		`thenNF_Tc` \ (method_inst, method_id) ->
+    newMethodAtLoc loc from_rational [ty]		`thenNF_Tc` \ (method_inst, method_id) ->
     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
 
   where
     floatprim_lit  = HsLitOut (HsFloatPrim f) floatPrimTy
-    float_lit      = HsCon floatDataCon [] [floatprim_lit]
+    float_lit      = mkHsConApp floatDataCon [] [floatprim_lit]
     doubleprim_lit = HsLitOut (HsDoublePrim f) doublePrimTy
-    double_lit     = HsCon doubleDataCon [] [doubleprim_lit]
+    double_lit     = mkHsConApp doubleDataCon [] [doubleprim_lit]
+
+-- there are no `instances' of functional dependencies or implicit params
+
+lookupInst _  = returnNF_Tc NoInstance
 
 \end{code}
 
@@ -594,124 +733,20 @@ appropriate dictionary if it exists.  It is used only when resolving
 ambiguous dictionaries.
 
 \begin{code}
-lookupSimpleInst :: InstEnv
-		 -> Class
-		 -> [Type]			-- Look up (c,t)
-	         -> NF_TcM s (Maybe ThetaType)		-- Here are the needed (c,t)s
-
-lookupSimpleInst class_inst_env clas tys
-  = case lookupInstEnv (ppr clas) class_inst_env tys of
-      Nothing	 -> returnNF_Tc Nothing
-
-      Just (tenv, dfun)
-	-> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
+lookupSimpleInst :: Class
+		 -> [Type]				-- Look up (c,t)
+	         -> NF_TcM s (Maybe [(Class,[Type])])	-- Here are the needed (c,t)s
+
+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
 	   (_, theta, _) = splitSigmaTy (idType dfun)
-\end{code}
-
-
-
-%************************************************************************
-%*									*
-\subsection[Inst-origin]{The @InstOrigin@ type}
-%*									*
-%************************************************************************
-
-The @InstOrigin@ type gives information about where a dictionary came from.
-This is important for decent error message reporting because dictionaries
-don't appear in the original source code.  Doubtless this type will evolve...
+	   theta' = map (\(Class clas tys) -> (clas,tys)) theta
 
-\begin{code}
-data InstOrigin
-  = OccurrenceOf TcId	-- Occurrence of an overloaded identifier
-  | OccurrenceOfCon Id		-- Occurrence of a data constructor
-
-  | RecordUpdOrigin
-
-  | DataDeclOrigin		-- Typechecking a data declaration
-
-  | InstanceDeclOrigin		-- Typechecking an instance decl
-
-  | LiteralOrigin	HsLit	-- Occurrence of a literal
-
-  | PatOrigin RenamedPat
-
-  | ArithSeqOrigin	RenamedArithSeqInfo -- [x..], [x..y] etc
-
-  | SignatureOrigin		-- A dict created from a type signature
-  | Rank2Origin			-- A dict created when typechecking the argument
-				-- of a rank-2 typed function
-
-  | DoOrigin			-- The monad for a do expression
-
-  | ClassDeclOrigin		-- Manufactured during a class decl
-
-  | InstanceSpecOrigin	Class	-- in a SPECIALIZE instance pragma
-			Type
-
-	-- When specialising instances the instance info attached to
-	-- each class is not yet ready, so we record it inside the
-	-- origin information.  This is a bit of a hack, but it works
-	-- fine.  (Patrick is to blame [WDP].)
-
-  | ValSpecOrigin	Name	-- in a SPECIALIZE pragma for a value
-
-	-- Argument or result of a ccall
-	-- Dictionaries with this origin aren't actually mentioned in the
-	-- translated term, and so need not be bound.  Nor should they
-	-- be abstracted over.
-
-  | CCallOrigin		String			-- CCall label
-			(Maybe RenamedHsExpr)	-- Nothing if it's the result
-						-- Just arg, for an argument
-
-  | LitLitOrigin	String	-- the litlit
-
-  | UnknownOrigin	-- Help! I give up...
+      other  -> returnNF_Tc Nothing
 \end{code}
 
-\begin{code}
-pprOrigin :: Inst -> SDoc
-pprOrigin inst
-  = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
-  where
-    (orig, locn) = case inst of
-			Dict _ _ _       orig loc -> (orig,loc)
-			Method _ _ _ _ _ orig loc -> (orig,loc)
-			LitInst _ _ _    orig loc -> (orig,loc)
-			
-    pp_orig (OccurrenceOf id)
-      	= hsep [ptext SLIT("use of"), quotes (ppr id)]
-    pp_orig (OccurrenceOfCon id)
-	= hsep [ptext SLIT("use of"), quotes (ppr id)]
-    pp_orig (LiteralOrigin lit)
-	= hsep [ptext SLIT("the literal"), quotes (ppr lit)]
-    pp_orig (PatOrigin pat)
-	= hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
-    pp_orig (InstanceDeclOrigin)
-	=  ptext SLIT("an instance declaration")
-    pp_orig (ArithSeqOrigin seq)
-	= hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
-    pp_orig (SignatureOrigin)
-	=  ptext SLIT("a type signature")
-    pp_orig (Rank2Origin)
-	=  ptext SLIT("a function with an overloaded argument type")
-    pp_orig (DoOrigin)
-	=  ptext SLIT("a do statement")
-    pp_orig (ClassDeclOrigin)
-	=  ptext SLIT("a class declaration")
-    pp_orig (InstanceSpecOrigin clas ty)
-	= hsep [text "a SPECIALIZE instance pragma; class",
-	        quotes (ppr clas), text "type:", ppr ty]
-    pp_orig (ValSpecOrigin name)
-	= hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
-    pp_orig (CCallOrigin clabel Nothing{-ccall result-})
-	= hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
-    pp_orig (CCallOrigin clabel (Just arg_expr))
-	= hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma, 
-		text "namely", quotes (ppr arg_expr)]
-    pp_orig (LitLitOrigin s)
-	= hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
-    pp_orig (UnknownOrigin)
-	= ptext SLIT("...oops -- I don't know where the overloading came from!")
-\end{code}
+