[project @ 2003-02-21 13:27:53 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 8b045ad..981731c 100644 (file)
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -21,7 +21,7 @@ module Inst (
        ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
        instLoc, getDictClassTys, dictPred,
 
-       lookupInst, lookupSimpleInst, LookupInstResult(..),
+       lookupInst, LookupInstResult(..),
 
        isDict, isClassDict, isMethod, 
        isLinearInst, linearInstType, isIPDict, isInheritableInst,
@@ -43,13 +43,13 @@ import TcHsSyn      ( TcExpr, TcId, TcIdSet, TypecheckedHsExpr,
                  mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
                )
 import TcRnMonad
-import TcEnv   ( tcGetInstEnv, tcLookupId, tcLookupTyCon )
+import TcEnv   ( tcGetInstEnv, tcLookupId, tcLookupTyCon, checkWellStaged, topIdLvl )
 import InstEnv ( InstLookupResult(..), lookupInstEnv )
 import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zapToType,
                  zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
                )
 import TcType  ( Type, TcType, TcThetaType, TcTyVarSet,
-                 SourceType(..), PredType, ThetaType, TyVarDetails(VanillaTv),
+                 SourceType(..), PredType, TyVarDetails(VanillaTv),
                  tcSplitForAllTys, tcSplitForAllTys, mkTyConApp,
                  tcSplitMethodTy, tcSplitPhiTy, mkGenTyConApp,
                  isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
@@ -61,13 +61,12 @@ import TcType       ( Type, TcType, TcThetaType, TcTyVarSet,
                  tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy
                )
 import CoreFVs ( idFreeTyVars )
-import Class   ( Class )
 import DataCon ( DataCon,dataConSig )
 import Id      ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
 import PrelInfo        ( isStandardClass, isCcallishClass, isNoDictClass )
 import Name    ( Name, mkMethodOcc, getOccName )
 import PprType ( pprPred, pprParendType )      
-import Subst   ( emptyInScopeSet, mkSubst, substTy, substTyWith, substTheta, mkTyVarSubst )
+import Subst   ( substTy, substTyWith, substTheta, mkTyVarSubst )
 import Literal ( inIntRange )
 import Var     ( TyVar )
 import VarEnv  ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) )
@@ -323,23 +322,14 @@ newMethodWithGivenTy orig id tys theta tau
 -- to simplify Insts
 
 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
-  -- Instantiate the specified class op, but *only* with the main
-  -- class dictionary. For example, given 'op' defined thus:
-  --   class Foo a where
-  --     op :: (?x :: String) => a -> a
-  -- (tcInstClassOp op T) should return an Inst with type
-  --   (?x :: String) => T -> T
-  -- That is, the class-op's context is still there.  
-  -- This is really important in the use of tcInstClassOp in TcClassDcls.mkMethodBind
 tcInstClassOp inst_loc sel_id tys
   = let
        (tyvars,rho) = tcSplitForAllTys (idType sel_id)
-       rho_ty       = substTyWith tyvars tys rho
-       (pred,tau)   = tcSplitMethodTy rho_ty
-               -- Split off exactly one predicate (see the example above)
+       rho_ty       = ASSERT( length tyvars == length tys )
+                      substTyWith tyvars tys rho
+       (preds,tau)  = tcSplitPhiTy rho_ty
     in
-    ASSERT( isClassPred pred )
-    newMethod inst_loc sel_id tys [pred] tau
+    newMethod inst_loc sel_id tys preds tau
 
 ---------------------------
 newMethod inst_loc id tys theta tau
@@ -480,7 +470,7 @@ pprInsts insts  = parens (sep (punctuate comma (map pprInst insts)))
 pprInstsInFull insts
   = vcat (map go insts)
   where
-    go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
+    go inst = sep [quotes (ppr inst), nest 2 (pprInstLoc (instLoc inst))]
 
 pprInst (LitInst u lit ty loc)
   = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
@@ -513,11 +503,11 @@ tidyMoreInsts env insts
 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
 
-showLIE :: String -> TcM ()    -- Debugging
+showLIE :: SDoc -> TcM ()      -- Debugging
 showLIE str
   = do { lie_var <- getLIEVar ;
         lie <- readMutVar lie_var ;
-        traceTc (text str <+> pprInstsInFull (lieToList lie)) }
+        traceTc (str <+> pprInstsInFull (lieToList lie)) }
 \end{code}
 
 
@@ -540,7 +530,7 @@ lookupInst :: Inst -> TcM (LookupInstResult s)
 
 
 -- Dictionaries
-lookupInst dict@(Dict _ (ClassP clas tys) loc)
+lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
   = getDOpts                   `thenM` \ dflags ->
     tcGetInstEnv               `thenM` \ inst_env ->
     case lookupInstEnv dflags inst_env clas tys of
@@ -551,6 +541,10 @@ lookupInst dict@(Dict _ (ClassP clas tys) loc)
                --      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.        
+          getStage                                             `thenM` \ use_stage ->
+          checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
+                          (topIdLvl dfun_id) use_stage         `thenM_`
+          traceTc (text "lookupInst" <+> ppr dfun_id <+> ppr (topIdLvl dfun_id) <+> ppr use_stage) `thenM_`
           let
                (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
                mk_ty_arg tv  = case lookupSubstEnv tenv tv of
@@ -616,28 +610,6 @@ lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
     returnM (GenInst [method_inst] (HsApp (HsVar (instToId method_inst)) rat_lit))
 \end{code}
 
-There is a second, simpler interface, when you want an instance of a
-class at a given nullary type constructor.  It just returns the
-appropriate dictionary if it exists.  It is used only when resolving
-ambiguous dictionaries.
-
-\begin{code}
-lookupSimpleInst :: Class
-                -> [Type]                      -- Look up (c,t)
-                -> TcM (Maybe ThetaType)       -- Here are the needed (c,t)s
-
-lookupSimpleInst clas tys
-  = getDOpts                   `thenM` \ dflags ->
-    tcGetInstEnv               `thenM` \ inst_env -> 
-    case lookupInstEnv dflags inst_env clas tys of
-      FoundInst tenv dfun
-       -> returnM (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
-        where
-          (_, rho)  = tcSplitForAllTys (idType dfun)
-          (theta,_) = tcSplitPhiTy rho
-
-      other  -> returnM Nothing
-\end{code}
 
 
 %************************************************************************