X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcEnv.lhs;h=f8ad79cc6aeee51d03b108ed5ba7208a10a7481d;hb=8a86866e9e382c1d4d06cad722ddbe965d09997c;hp=edec045a2ccb11d6ab8f1df0a6c7faa7fb0565a5;hpb=e6d004928bcd0e71ba58c034b6fe4c870e6a70cb;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index edec045..f8ad79c 100644
--- 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}