[project @ 2000-12-19 08:37:18 by simonpj]

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

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index 307d49e..d0d44cf 100644 (file)
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -44,23 +44,24 @@ import TcHsSyn      ( TcExpr, TcId,
                )
 import TcMonad
 import TcEnv   ( TcIdSet, tcGetInstEnv, tcLookupGlobalId )
-import TcInstUtil ( InstLookupResult(..), lookupInstEnv )
+import InstEnv ( InstLookupResult(..), lookupInstEnv )
 import TcType  ( TcThetaType,
                  TcType, TcTauType, TcTyVarSet,
                  zonkTcTyVars, zonkTcType, zonkTcTypes, 
                  zonkTcThetaType
                )
-import Bag
+import CoreFVs ( idFreeTyVars )
 import Class   ( Class, FunDep )
 import FunDeps ( instantiateFdClassTys )
-import Id      ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal )
+import Id      ( Id, idType, mkUserLocal, mkSysLocal )
 import PrelInfo        ( isStandardClass, isCcallishClass, isNoDictClass )
 import Name    ( mkDictOcc, mkMethodOcc, mkIPOcc, getOccName, nameUnique )
 import PprType ( pprPred )     
 import Type    ( Type, PredType(..), 
                  isTyVarTy, mkDictTy, mkPredTy,
                  splitForAllTys, splitSigmaTy, funArgTy,
-                 splitRhoTy, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
+                 splitMethodTy, splitRhoTy, classesOfPreds,
+                 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
                  tidyOpenType, tidyOpenTypes
                )
 import Subst   ( emptyInScopeSet, mkSubst, mkInScopeSet,
@@ -77,6 +78,7 @@ import TysWiredIn ( isIntTy,
 import PrelNames( Unique, hasKey, fromIntName, fromIntegerClassOpKey )
 import Maybe   ( catMaybes )
 import Util    ( thenCmp, zipWithEqual, mapAccumL )
+import Bag
 import Outputable
 \end{code}
 
@@ -354,9 +356,9 @@ newMethod orig id tys
     let
        (tyvars, rho) = splitForAllTys (idType id)
        rho_ty        = substTy (mkTyVarSubst tyvars tys) rho
-       (theta, tau)  = splitRhoTy rho_ty
+       (pred, tau)  = splitMethodTy rho_ty
     in
-    newMethodWithGivenTy orig id tys theta tau `thenNF_Tc` \ meth_inst ->
+    newMethodWithGivenTy orig id tys [pred] tau        `thenNF_Tc` \ meth_inst ->
     returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
 
 instOverloadedFun orig v arg_tys theta tau
@@ -552,7 +554,8 @@ pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
 pprInst m@(Method u id tys theta tau loc)
   = hsep [ppr id, ptext SLIT("at"), 
          brackets (interppSP tys) {- ,
-         ppr theta, ppr tau,
+         ptext SLIT("theta"), ppr theta,
+         ptext SLIT("tau"), ppr tau
          show_uniq u,
          ppr (instToId m) -}]
 
@@ -721,7 +724,7 @@ lookupSimpleInst clas tys
        -> returnNF_Tc (Just (substClasses (mkSubst emptyInScopeSet tenv) theta'))
         where
           (_, theta, _) = splitSigmaTy (idType dfun)
-          theta' = map (\(Class clas tys) -> (clas,tys)) theta
+          theta'        = classesOfPreds theta
 
       other  -> returnNF_Tc Nothing
 \end{code}