[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 edec045..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,7 +57,7 @@ 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
@@ -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,18 +281,19 @@ 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
-       other          -> notFound "tcLookupGlobal" name
+       other          -> notFound "tcLookupGlobal (id)" name
 
 tcLookupDataCon :: Name -> TcM DataCon
 tcLookupDataCon con_name
-  = tcLookupGlobalId con_name  `thenM` \ con_id ->
-    case isDataConWrapId_maybe con_id of
-       Just data_con -> returnM data_con
-       Nothing       -> failWithTc (badCon con_id)
+  = tcLookupGlobal_maybe con_name      `thenM` \ maybe_thing ->
+    case maybe_thing of
+       Just (ADataCon data_con) -> returnM data_con
+       other                    -> notFound "tcLookupDataCon" con_name
 
 tcLookupClass :: Name -> TcM Class
 tcLookupClass name
@@ -350,6 +350,7 @@ 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
@@ -358,6 +359,7 @@ tcLookupId name
        other             -> pprPanic "tcLookupId" (ppr name)
 
 tcLookupIdLvl :: Name -> TcM (Id, Level)
+-- DataCons dealt with separately
 tcLookupIdLvl name
   = tcLookup name      `thenM` \ thing -> 
     case thing of
@@ -549,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
@@ -612,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}