[project @ 2000-03-02 22:51:30 by lewie]

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

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index d3ede0e..ecc9a2f 100644 (file)
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -18,10 +18,10 @@ module Inst (
        newIPDict, instOverloadedFun,
 
        tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, instLoc, getDictClassTys,
+       getDictPred_maybe, getMethodTheta_maybe,
        getFunDeps, getFunDepsOfLIE,
        getIPs, getIPsOfLIE,
        getAllFunDeps, getAllFunDepsOfLIE,
-       partitionLIEbyMeth,
 
        lookupInst, lookupSimpleInst, LookupInstResult(..),
 
@@ -39,7 +39,7 @@ module Inst (
 import HsSyn   ( HsLit(..), HsExpr(..) )
 import RnHsSyn ( RenamedArithSeqInfo, RenamedHsExpr, RenamedPat )
 import TcHsSyn ( TcExpr, TcId, 
-                 mkHsTyApp, mkHsDictApp, zonkId
+                 mkHsTyApp, mkHsDictApp, mkHsDictLam, zonkId
                )
 import TcMonad
 import TcEnv   ( TcIdSet, tcLookupValueByKey, tcLookupTyConByKey )
@@ -84,7 +84,6 @@ import Unique ( fromRationalClassOpKey, rationalTyConKey,
                  fromIntClassOpKey, fromIntegerClassOpKey, Unique
                )
 import Maybes  ( expectJust )
-import List    ( partition )
 import Maybe   ( catMaybes )
 import Util    ( thenCmp, zipWithEqual, mapAccumL )
 import Outputable
@@ -250,6 +249,12 @@ 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)
@@ -272,25 +277,6 @@ getAllFunDeps inst = map (\(n,ty) -> ([], [ty])) (getIPs inst)
 
 getAllFunDepsOfLIE lie = concat (map getAllFunDeps (lieToList lie))
 
-partitionLIEbyMeth pred lie
-  = foldlTc (partMethod pred) (emptyLIE, emptyLIE) insts
-  where insts = lieToList lie
-
-partMethod pred (ips, lie) m@(Method u id tys theta tau loc)
-  = if null ips_ then
-       returnTc (ips, consLIE m lie)
-    else if null theta_ then
-       returnTc (consLIE m ips, lie)
-    else
-       newMethodWith id tys theta_ tau loc         `thenTc` \ new_m2 ->
-       let id_m1 = instToIdBndr new_m2
-           new_m1 = Method u id_m1 {- tys -} [] ips_ tau loc in
-       -- newMethodWith id_m1 tys ips_ tau loc     `thenTc` \ new_m1 ->
-       returnTc (consLIE new_m1 ips, consLIE new_m2 lie)
-  where (ips_, theta_) = partition pred theta
-partMethod pred (ips, lie) inst@(LitInst u lit ty loc)
-  = returnTc (ips, consLIE inst lie)
-
 tyVarsOfInst :: Inst -> TcTyVarSet
 tyVarsOfInst (Dict _ pred _)         = tyVarsOfPred pred
 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
@@ -547,6 +533,7 @@ zonkInst (FunDep clas fds loc)
   = zonkFunDeps fds                    `thenNF_Tc` \ fds' ->
     returnNF_Tc (FunDep clas fds' loc)
 
+zonkPreds preds = mapNF_Tc zonkPred preds
 zonkInsts insts = mapNF_Tc zonkInst insts
 
 zonkFunDeps fds = mapNF_Tc zonkFd fds
@@ -584,10 +571,12 @@ pprInst (LitInst u lit ty loc)
 
 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
 
-pprInst (Method u id tys _ _ loc)
+pprInst m@(Method u id tys theta tau loc)
   = hsep [ppr id, ptext SLIT("at"), 
          brackets (interppSP tys),
-         show_uniq u]
+         ppr theta, ppr tau,
+         show_uniq u,
+         ppr (instToId m)]
 
 pprInst (FunDep clas fds loc)
   = hsep [ppr clas, ppr fds]