[project @ 2003-02-04 12:28:22 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 201a93f..cd189a5 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,
@@ -31,7 +31,7 @@ module Inst (
        zonkInst, zonkInsts,
        instToId, instName,
 
-       InstOrigin(..), InstLoc, pprInstLoc
+       InstOrigin(..), InstLoc(..), pprInstLoc
     ) where
 
 #include "HsVersions.h"
@@ -43,7 +43,7 @@ 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
@@ -74,7 +74,6 @@ import VarEnv ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) )
 import VarSet  ( elemVarSet, emptyVarSet, unionVarSet )
 import TysWiredIn ( floatDataCon, doubleDataCon )
 import PrelNames( fromIntegerName, fromRationalName, rationalTyConName )
-import Util    ( equalLength )
 import BasicTypes( IPName(..), mapIPName, ipNameName )
 import UniqSupply( uniqsFromSupply )
 import Outputable
@@ -224,11 +223,13 @@ newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
 newDictsAtLoc :: InstLoc
              -> TcThetaType
              -> TcM [Inst]
-newDictsAtLoc inst_loc@(_,loc,_) theta
+newDictsAtLoc inst_loc theta
   = newUniqueSupply            `thenM` \ us ->
     returnM (zipWith mk_dict (uniqsFromSupply us) theta)
   where
-    mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred inst_loc
+    mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred))
+                            pred inst_loc
+    loc = instLocSrcLoc inst_loc
 
 -- For vanilla implicit parameters, there is only one in scope
 -- at any time, so we used to use the name of the implicit parameter itself
@@ -237,7 +238,7 @@ newDictsAtLoc inst_loc@(_,loc,_) theta
 newIPDict :: InstOrigin -> IPName Name -> Type 
          -> TcM (IPName Id, Inst)
 newIPDict orig ip_name ty
-  = getInstLoc orig                    `thenM` \ inst_loc@(_,loc,_) ->
+  = getInstLoc orig                    `thenM` \ inst_loc@(InstLoc _ loc _) ->
     newUnique                          `thenM` \ uniq ->
     let
        pred = IParam ip_name ty
@@ -322,30 +323,22 @@ 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@(_,loc,_) id tys theta tau
+newMethod inst_loc id tys theta tau
   = newUnique          `thenM` \ new_uniq ->
     let
        meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
        inst    = Method meth_id id tys theta tau inst_loc
+       loc     = instLocSrcLoc inst_loc
     in
     returnM inst
 \end{code}
@@ -478,7 +471,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]
@@ -538,7 +531,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
@@ -549,6 +542,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
@@ -614,28 +611,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}
 
 
 %************************************************************************