[project @ 2003-04-08 11:27:30 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 0f1f088..f8ad79c 100644 (file)
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -3,7 +3,7 @@ module TcEnv(
        TyThing(..), TyThingDetails(..), TcTyThing(..), TcId,
 
        -- Instance environment, and InstInfo type
-       tcGetInstEnv, tcSetInstEnv, 
+       tcGetInstEnv, 
        InstInfo(..), pprInstInfo, pprInstInfoDetails,
        simpleInstInfoTy, simpleInstInfoTyCon, 
        InstBindings(..),
@@ -25,7 +25,7 @@ module TcEnv(
        lclEnvElts, getInLocalScope, findGlobals, 
 
        -- Instance environment
-       tcExtendLocalInstEnv, tcExtendInstEnv, 
+       tcExtendLocalInstEnv, tcExtendInstEnv, tcExtendTempInstEnv, tcWithTempInstEnv,
 
        -- Rules
        tcExtendRules,
@@ -57,12 +57,12 @@ import TcType               ( Type, ThetaType, TcKind, TcTyVar, TcTyVarSet,
                        )
 import qualified Type  ( getTyVar_maybe )
 import Rules           ( extendRuleBase )
-import Id              ( idName, isLocalId, isDataConWrapId_maybe )
+import Id              ( idName, isLocalId )
 import Var             ( TyVar, Id, idType )
 import VarSet
 import VarEnv
 import CoreSyn         ( IdCoreRule )
-import DataCon         ( DataCon, dataConWrapId )
+import DataCon         ( DataCon )
 import TyCon           ( TyCon, DataConDetails )
 import Class           ( Class, ClassOpItem )
 import Name            ( Name, NamedThing(..), 
@@ -76,7 +76,6 @@ import Rules          ( RuleBase )
 import BasicTypes      ( EP )
 import Module          ( Module )
 import InstEnv         ( InstEnv, extendInstEnv )
-import Maybes          ( seqMaybe )
 import SrcLoc          ( SrcLoc )
 import Outputable
 import Maybe           ( isJust )
@@ -282,17 +281,12 @@ tcLookupGlobal name
        other      -> notFound "tcLookupGlobal" name
 
 tcLookupGlobalId :: Name -> TcM Id
+-- Never used for Haskell-source DataCons, hence no ADataCon case
 tcLookupGlobalId name
   = tcLookupGlobal_maybe name  `thenM` \ maybe_thing ->
     case maybe_thing of
-       Just (AnId id)     -> returnM id
-
-       -- When typechecking Haskell source, occurrences of
-       -- data constructors use the "source name", which maps
-       -- to ADataCon; we want the wrapper instead
-       Just (ADataCon dc) -> returnM (dataConWrapId dc)
-
-       other              -> notFound "tcLookupGlobal (id)" name
+       Just (AnId id) -> returnM id
+       other          -> notFound "tcLookupGlobal (id)" name
 
 tcLookupDataCon :: Name -> TcM DataCon
 tcLookupDataCon con_name
@@ -356,22 +350,21 @@ tcLookup name
 
 tcLookupId :: Name -> TcM Id
 -- Used when we aren't interested in the binding level
+-- Never a DataCon. (Why does that matter? see TcExpr.tcId)
 tcLookupId name
   = tcLookup name      `thenM` \ thing -> 
     case thing of
-       ATcId tc_id lvl       -> returnM tc_id
-       AGlobal (AnId id)     -> returnM id
-       AGlobal (ADataCon dc) -> returnM (dataConWrapId dc)
-               -- C.f. tcLookupGlobalId
-       other                 -> pprPanic "tcLookupId" (ppr name)
+       ATcId tc_id lvl   -> returnM tc_id
+       AGlobal (AnId id) -> returnM id
+       other             -> pprPanic "tcLookupId" (ppr name)
 
 tcLookupIdLvl :: Name -> TcM (Id, Level)
+-- DataCons dealt with separately
 tcLookupIdLvl name
   = tcLookup name      `thenM` \ thing -> 
     case thing of
-       ATcId tc_id lvl       -> returnM (tc_id, lvl)
-       AGlobal (AnId id)     -> returnM (id, topIdLvl id)
-       AGlobal (ADataCon dc) -> returnM (dataConWrapId dc, impLevel)
+       ATcId tc_id lvl   -> returnM (tc_id, lvl)
+       AGlobal (AnId id) -> returnM (id, topIdLvl id)
        other             -> pprPanic "tcLookupIdLvl" (ppr name)
 
 tcLookupLocalIds :: [Name] -> TcM [TcId]
@@ -558,23 +551,7 @@ from this module
 
 \begin{code}
 tcGetInstEnv :: TcM InstEnv
-tcGetInstEnv = getGblEnv       `thenM` \ env -> 
-              readMutVar (tcg_inst_env env)
-
-tcSetInstEnv :: InstEnv -> TcM a -> TcM a
--- Horribly imperative; 
--- but used only when temporarily enhancing the instance
--- envt during 'deriving' context inference
-tcSetInstEnv ie thing_inside
-  = getGblEnv  `thenM` \ env ->
-    let 
-       ie_var = tcg_inst_env env
-    in
-    readMutVar  ie_var         `thenM` \ old_ie ->
-    writeMutVar ie_var ie      `thenM_`
-    thing_inside               `thenM` \ result ->
-    writeMutVar ie_var old_ie  `thenM_`    
-    returnM result
+tcGetInstEnv = do { env <- getGblEnv; readMutVar (tcg_inst_env env) }
 
 tcExtendInstEnv :: [DFunId] -> TcM a -> TcM a
        -- Add instances from local or imported
@@ -621,10 +598,38 @@ tcExtendLocalInstEnv infos thing_inside
       ; writeMutVar ie_var inst_env'
       ; setGblEnv env' thing_inside }
 
+tcExtendTempInstEnv :: [DFunId] -> TcM a -> TcM a
+  -- Extend the instance envt, but with *no* permanent 
+  -- effect on mutable variables; also ignore errors
+  -- Used during 'deriving' stuff
+tcExtendTempInstEnv dfuns thing_inside
+ = do { dflags <- getDOpts
+      ; env <- getGblEnv
+      ; let ie_var = tcg_inst_env env
+      ; inst_env <- readMutVar ie_var
+      ; let (inst_env', errs) = extendInstEnv dflags inst_env dfuns
+       -- Ignore the errors about duplicate instances.
+       -- We don't want repeated error messages
+       -- They'll appear later, when we do the top-level extendInstEnvs
+      ; writeMutVar ie_var inst_env'
+      ; result <- thing_inside 
+      ; writeMutVar ie_var inst_env    -- Restore!
+      ; return result }
+
+tcWithTempInstEnv :: TcM a -> TcM a
+-- Run thing_inside, discarding any effects on the instance environment
+tcWithTempInstEnv thing_inside
+   = do { env <- getGblEnv
+       ; let ie_var = tcg_inst_env env
+       ; old_ie <- readMutVar  ie_var
+       ; result <- thing_inside
+       ; writeMutVar ie_var old_ie     -- Restore
+       ; return result }
+
 traceDFuns dfuns
   = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
   where
-    pp dfun   = ppr dfun <+> dcolon <+> ppr (idType dfun)
+    pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
 \end{code}