[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 ad7df46..ecc9a2f 100644 (file)
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -18,17 +18,18 @@ module Inst (
        newIPDict, instOverloadedFun,
 
        tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, instLoc, getDictClassTys,
+       getDictPred_maybe, getMethodTheta_maybe,
        getFunDeps, getFunDepsOfLIE,
        getIPs, getIPsOfLIE,
        getAllFunDeps, getAllFunDepsOfLIE,
-       partitionLIEbyMeth,
 
        lookupInst, lookupSimpleInst, LookupInstResult(..),
 
-       isDict, isTyVarDict, isStdClassTyVarDict, isMethodFor, notFunDep,
+       isDict, isClassDict, isTyVarDict, isStdClassTyVarDict, isMethodFor, notFunDep,
        instBindingRequired, instCanBeGeneralised,
 
-       zonkInst, zonkFunDeps, zonkTvFunDeps, instToId, instToIdBndr,
+       zonkInst, zonkInsts, zonkFunDeps, zonkTvFunDeps,
+       instToId, instToIdBndr, ipToId,
 
        InstOrigin(..), InstLoc, pprInstLoc
     ) where
@@ -38,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 )
@@ -52,7 +53,8 @@ import Class  ( classInstEnv, Class )
 import FunDeps ( instantiateFdClassTys )
 import Id      ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal )
 import PrelInfo        ( isStandardClass, isCcallishClass, isNoDictClass )
-import Name    ( OccName, Name, mkDictOcc, mkMethodOcc, getOccName, nameUnique )
+import Name    ( OccName, Name, mkDictOcc, mkMethodOcc, mkIPOcc,
+                 getOccName, nameUnique )
 import PprType ( pprPred )     
 import InstEnv ( InstEnv, lookupInstEnv )
 import SrcLoc  ( SrcLoc )
@@ -82,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
@@ -248,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)
@@ -270,23 +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
-
 tyVarsOfInst :: Inst -> TcTyVarSet
 tyVarsOfInst (Dict _ pred _)         = tyVarsOfPred pred
 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
@@ -310,8 +300,11 @@ Predicates
 ~~~~~~~~~~
 \begin{code}
 isDict :: Inst -> Bool
-isDict (Dict _ (Class _ _) _) = True
+isDict (Dict _ _ _) = True
 isDict other         = False
+isClassDict :: Inst -> Bool
+isClassDict (Dict _ (Class _ _) _) = True
+isClassDict other            = False
 
 isMethodFor :: TcIdSet -> Inst -> Bool
 isMethodFor ids (Method uniq id tys _ _ loc) 
@@ -485,9 +478,7 @@ instToIdBndr :: Inst -> TcId
 instToIdBndr (Dict u (Class clas ty) (_,loc,_))
   = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas ty) loc
 instToIdBndr (Dict u (IParam n ty) (_,loc,_))
---  = mkUserLocal (mkIPOcc (getOccName n)) u (mkPredTy (IParam n ty)) loc
-  = mkUserLocal (getOccName n) (nameUnique n) (mkPredTy (IParam n ty)) loc
---  = mkVanillaId n ty
+  = ipToId n ty loc
 
 instToIdBndr (Method u id tys theta tau (_,loc,_))
   = mkUserLocal (mkMethodOcc (getOccName id)) u tau loc
@@ -497,6 +488,9 @@ instToIdBndr (LitInst u list ty loc)
 
 instToIdBndr (FunDep clas fds _)
   = panic "FunDep escaped!!!"
+
+ipToId n ty loc
+  = mkUserLocal (mkIPOcc (getOccName n)) (nameUnique n) (mkPredTy (IParam n ty)) loc
 \end{code}
 
 
@@ -539,6 +533,9 @@ 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
   where
   zonkFd (ts1, ts2)
@@ -574,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]