[project @ 2002-01-22 13:35:36 by simonmar]

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

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index 6144532..23eab62 100644 (file)
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -17,7 +17,7 @@ module Inst (
 
        tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, 
        ipNamesOfInst, ipNamesOfInsts, predsOfInst, predsOfInsts,
-       instLoc, getDictClassTys, 
+       instLoc, getDictClassTys, dictPred,
 
        lookupInst, lookupSimpleInst, LookupInstResult(..),
 
@@ -205,6 +205,9 @@ instLoc (Dict _ _         loc) = loc
 instLoc (Method _ _ _ _ _ loc) = loc
 instLoc (LitInst _ _ _    loc) = loc
 
+dictPred (Dict _ pred _ ) = pred
+dictPred inst            = pprPanic "dictPred" (ppr inst)
+
 getDictClassTys (Dict _ pred _) = getClassPredTys pred
 
 predsOfInsts :: [Inst] -> [PredType]
@@ -592,8 +595,9 @@ lookupInst :: Inst
 -- Dictionaries
 
 lookupInst dict@(Dict _ (ClassP clas tys) loc)
-  = tcGetInstEnv               `thenNF_Tc` \ inst_env ->
-    case lookupInstEnv inst_env clas tys of
+  = getDOptsTc                 `thenNF_Tc` \ dflags ->
+    tcGetInstEnv               `thenNF_Tc` \ inst_env ->
+    case lookupInstEnv dflags inst_env clas tys of
 
       FoundInst tenv dfun_id
        -> let
@@ -603,12 +607,16 @@ lookupInst dict@(Dict _ (ClassP clas tys) loc)
                                   Nothing          -> tcInstTyVar tv   `thenNF_Tc` \ tc_tv ->
                                                       returnTc (mkTyVarTy tc_tv)
           in
+               -- It's possible that not all the tyvars are in
+               -- the substitution, tenv. For example:
+               --      instance C X a => D X where ...
+               -- (presumably there's a functional dependency in class C)
+               -- Hence the mk_ty_arg to instantiate any un-substituted tyvars.        
           mapNF_Tc mk_ty_arg tyvars    `thenNF_Tc` \ ty_args ->
           let
-               subst         = mkTyVarSubst tyvars ty_args
-               dfun_rho      = substTy subst rho
-               (theta, _)    = tcSplitRhoTy dfun_rho
-               ty_app        = mkHsTyApp (HsVar dfun_id) ty_args
+               dfun_rho   = substTy (mkTyVarSubst tyvars ty_args) rho
+               (theta, _) = tcSplitRhoTy dfun_rho
+               ty_app     = mkHsTyApp (HsVar dfun_id) ty_args
           in
           if null theta then
                returnNF_Tc (SimpleInst ty_app)
@@ -670,8 +678,9 @@ lookupSimpleInst :: Class
                 -> NF_TcM (Maybe ThetaType)    -- Here are the needed (c,t)s
 
 lookupSimpleInst clas tys
-  = tcGetInstEnv               `thenNF_Tc` \ inst_env -> 
-    case lookupInstEnv inst_env clas tys of
+  = getDOptsTc                 `thenNF_Tc` \ dflags ->
+    tcGetInstEnv               `thenNF_Tc` \ inst_env -> 
+    case lookupInstEnv dflags inst_env clas tys of
       FoundInst tenv dfun
        -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
         where