[project @ 2000-12-07 08:28:05 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 020d139..6342259 100644 (file)
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -43,25 +43,25 @@ import TcHsSyn      ( TcExpr, TcId,
                  mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
                )
 import TcMonad
-import TcEnv   ( TcIdSet, tcGetInstEnv, lookupInstEnv, InstLookupResult(..),
-                 tcLookupValue, tcLookupGlobalValue
-               )
+import TcEnv   ( TcIdSet, tcGetInstEnv, tcLookupGlobalId )
+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,
+                 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
                  tidyOpenType, tidyOpenTypes
                )
 import Subst   ( emptyInScopeSet, mkSubst, mkInScopeSet,
@@ -75,9 +75,10 @@ import TysWiredIn ( isIntTy,
                    doubleDataCon, isDoubleTy,
                    isIntegerTy, voidTy
                  ) 
-import PrelNames( Unique, hasKey, fromIntClassOpKey, fromIntegerClassOpKey )
+import PrelNames( Unique, hasKey, fromIntName, fromIntegerClassOpKey )
 import Maybe   ( catMaybes )
 import Util    ( thenCmp, zipWithEqual, mapAccumL )
+import Bag
 import Outputable
 \end{code}
 
@@ -355,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
@@ -553,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) -}]
 
@@ -663,7 +665,7 @@ lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
                                                        -- (i.e. no funny business with user-defined
                                                        --  packages of numeric classes)
   =    -- So we can use the Prelude fromInt 
-    tcLookupGlobalId fromIntClassOpName        `thenNF_Tc` \ from_int ->
+    tcLookupGlobalId fromIntName               `thenNF_Tc` \ from_int ->
     newMethodAtLoc loc from_int [ty]           `thenNF_Tc` \ (method_inst, method_id) ->
     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
 
@@ -685,7 +687,7 @@ lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
   | isDoubleTy ty   = returnNF_Tc (GenInst [] double_lit)
 
   | otherwise 
-  = tcLookupGlobalValue from_rat_name          `thenNF_Tc` \ from_rational ->
+  = tcLookupGlobalId from_rat_name             `thenNF_Tc` \ from_rational ->
     newMethodAtLoc loc from_rational [ty]      `thenNF_Tc` \ (method_inst, method_id) ->
     let
        rational_ty  = funArgTy (idType method_id)