From: sewardj <unknown>
Date: Mon, 16 Oct 2000 10:05:01 +0000 (+0000)
Subject: [project @ 2000-10-16 10:05:00 by sewardj]
X-Git-Tag: Approximately_9120_patches~3583
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=ecd5cb36ad575939b04f40d1b3a7255741f294a2;p=ghc-hetmet.git

[project @ 2000-10-16 10:05:00 by sewardj]
Mostly typechecker stuff.
---

diff --git a/ghc/compiler/ghci/CmCompile.lhs b/ghc/compiler/ghci/CmCompile.lhs
index 0a78637..f06b793 100644
--- a/ghc/compiler/ghci/CmCompile.lhs
+++ b/ghc/compiler/ghci/CmCompile.lhs
@@ -99,24 +99,10 @@ type HomeInterfaceTable = ModuleEnv ModIFace
 
 A @ModDetails@ summarises everything we know about a compiled module
 
-\begin{code}
-data ModDetails
-   = ModDetails {
-        moduleExports :: Avails,		-- What it exports
-        moduleEnv     :: GlobalRdrEnv,		-- Its top level environment
-
-        fixityEnv     :: NameEnv Fixity,
-	deprecEnv     :: NameEnv DeprecTxt,
-        typeEnv       :: NameEnv TcEnv.TyThing,
-
-        instEnv       :: InstEnv,
-        ruleEnv       :: IdEnv [CoreRule]	-- Domain includes Ids from other modules
-     }
-\end{code}
-
 Auxiliary definitions
 
 \begin{code}
+{- I DONT think this should be here -- should be in HscTypes 
 type DeprecationEnv = NameEnv DeprecTxt		-- Give reason for deprecation
 
 type GlobalRdrEnv = RdrNameEnv [Name]	-- The list is because there may be name clashes
@@ -136,6 +122,7 @@ type AvailEnv	  = NameEnv AvailInfo	-- Maps a Name to the AvailInfo that contain
 type AvailInfo    = GenAvailInfo Name
 type RdrAvailInfo = GenAvailInfo OccName
 type Avails	  = [AvailInfo]
+-}
 \end{code}
 
 
diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs
index 2138d48..6426da4 100644
--- a/ghc/compiler/main/HscTypes.lhs
+++ b/ghc/compiler/main/HscTypes.lhs
@@ -36,7 +36,7 @@ import UniqFM 		( UniqFM )
 import FiniteMap	( FiniteMap, emptyFM, addToFM, lookupFM, foldFM )
 import Bag		( Bag )
 import Id		( Id )
-import VarEnv		( IdEnv )
+import VarEnv		( IdEnv, emptyVarEnv )
 import BasicTypes	( Version, Fixity, defaultFixity )
 import TyCon		( TyCon )
 import ErrUtils		( ErrMsg, WarnMsg )
@@ -49,8 +49,6 @@ import CoreSyn		( CoreRule )
 import NameSet		( NameSet )
 import Type		( Type )
 import VarSet		( TyVarSet )
-import {-# SOURCE #-} 
-       TcInstUtil ( emptyInstEnv )
 import Panic		( panic )
 \end{code}
 
@@ -65,29 +63,29 @@ A @ModDetails@ summarises everything we know about a compiled module.
 \begin{code}
 data ModDetails
    = ModDetails {
-	moduleId      :: Module,
-        moduleExports :: Avails,		-- What it exports
-	mdVersion     :: VersionInfo,
-        moduleEnv     :: GlobalRdrEnv,		-- Its top level environment
+	md_id       :: Module,
+        md_exports  :: Avails,		-- What it exports
+	md_version  :: VersionInfo,
+        md_globals  :: GlobalRdrEnv,	-- Its top level environment
 
-        fixityEnv     :: NameEnv Fixity,
-	deprecEnv     :: NameEnv DeprecTxt,
-        typeEnv       :: TypeEnv,
+        md_fixities :: NameEnv Fixity,
+	md_deprecs  :: NameEnv DeprecTxt,
+        md_types    :: TypeEnv,
 
-        mdInsts       :: [DFunId],	-- Dfun-ids for the instances in this module
-        mdRules       :: RuleEnv	-- Domain may include Id from other modules
+        md_insts    :: [DFunId],	-- Dfun-ids for the instances in this module
+        md_rules    :: RuleEnv		-- Domain may include Id from other modules
      }
 
 emptyModDetails :: Module -> ModDetails
 emptyModDetails mod
-  = ModDetails { moduleId      = mod,
-		 moduleExports = [],
-		 moduleEnv     = emptyRdrEnv,
-		 fixityEnv     = emptyNameEnv,
-		 deprecEnv     = emptyNameEnv,
-		 typeEnv       = emptyNameEnv,
-		 mdInsts       = [],
-    		 mdRules       = emptyRuleEnv
+  = ModDetails { md_id       = mod,
+		 md_exports  = [],
+		 md_globals  = emptyRdrEnv,
+		 md_fixities = emptyNameEnv,
+		 md_deprecs  = emptyNameEnv,
+		 md_types    = emptyNameEnv,
+		 md_insts    = [],
+    		 md_rules    = emptyRuleEnv
     }		
 \end{code}
 
@@ -108,7 +106,7 @@ lookupFixityEnv :: SymbolTable -> Name -> Maybe Fixity
 lookupFixityEnv tbl name
   = case lookupModuleEnv tbl (nameModule name) of
 	Nothing	     -> Nothing
-	Just details -> lookupNameEnv (fixityEnv details) name
+	Just details -> lookupNameEnv (md_fixities details) name
 \end{code}
 
 
@@ -136,7 +134,7 @@ instance NamedThing TyThing where
 lookupTypeEnv :: SymbolTable -> Name -> Maybe TyThing
 lookupTypeEnv tbl name
   = case lookupModuleEnv tbl (nameModule name) of
-	Just details -> lookupNameEnv (typeEnv details) name
+	Just details -> lookupNameEnv (md_types details) name
 	Nothing	     -> Nothing
 
 
@@ -163,8 +161,8 @@ extendTypeEnv tbl things
 	where
 	  new_details 
              = case lookupModuleEnv tbl mod of
-                  Nothing      -> (emptyModDetails mod) {typeEnv = type_env}
-                  Just details -> details {typeEnv = typeEnv details 
+                  Nothing      -> (emptyModDetails mod) {md_types = type_env}
+                  Just details -> details {md_types = md_types details 
                                                      `plusNameEnv` type_env}
 \end{code}
 
diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index 6d212cc..bf91943 100644
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -20,14 +20,14 @@ import HscTypes		( pprNameProvenance )
 import RnMonad
 import Name		( Name, Provenance(..), ExportFlag(..), NamedThing(..),
 			  ImportReason(..), getSrcLoc, 
-			  mkLocalName, mkImportedLocalName, mkGlobalName, mkUnboundName,
+			  mkLocalName, mkImportedLocalName, mkGlobalName,
 			  mkIPName, hasBetterProv, isLocallyDefined, 
 			  nameOccName, setNameModule, nameModule,
 			  extendNameEnv_C, plusNameEnv_C, nameEnvElts
 			)
 import NameSet
 import OccName		( OccName, occNameUserString, occNameFlavour )
-import Module		( ModuleName, moduleName, mkVanillaModule, pprModuleName )
+import Module		( ModuleName, moduleName, mkVanillaModule )
 import FiniteMap
 import Unique		( Unique )
 import UniqSupply
@@ -36,6 +36,7 @@ import Outputable
 import ListSetOps	( removeDups, equivClasses )
 import Util		( thenCmp, sortLt )
 import List		( nub )
+import PrelNames	( mkUnboundName )
 \end{code}
 
 
@@ -682,7 +683,7 @@ warnUnusedModules mods
   | not opt_WarnUnusedImports = returnRn ()
   | otherwise 		      = mapRn_ (addWarnRn . unused_mod . moduleName) mods
   where
-    unused_mod m = vcat [ptext SLIT("Module") <+> quotes (pprModuleName m) <+> 
+    unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+> 
 			   text "is imported, but nothing from it is used",
 			 parens (ptext SLIT("except perhaps to re-export instances visible in") <+>
 				   quotes (pprModuleName m))]
diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index 10adbac..97b01fc 100644
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -110,8 +110,8 @@ type RnMG r  = RnM ()    r		-- Getting global names etc
 	-- Common part
 data RnDown
   = RnDown {
-	rn_mod     :: Module,			-- This module
-	rn_loc     :: SrcLoc,			-- Current locn
+	rn_mod     :: Module,		-- This module
+	rn_loc     :: SrcLoc,		-- Current locn
 
 	rn_finder  :: Finder,
 	rn_dflags  :: DynFlags,
diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index 3eaca26..307d49e 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -43,9 +43,8 @@ import TcHsSyn	( TcExpr, TcId,
 		  mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
 		)
 import TcMonad
-import TcEnv	( TcIdSet, tcGetInstEnv, lookupInstEnv, InstLookupResult(..),
-		  tcLookupGlobalId
-		)
+import TcEnv	( TcIdSet, tcGetInstEnv, tcLookupGlobalId )
+import TcInstUtil ( InstLookupResult(..), lookupInstEnv )
 import TcType	( TcThetaType,
 		  TcType, TcTauType, TcTyVarSet,
 		  zonkTcTyVars, zonkTcType, zonkTcTypes, 
@@ -75,7 +74,7 @@ import TysWiredIn ( isIntTy,
 		    doubleDataCon, isDoubleTy,
 		    isIntegerTy, voidTy
 		  ) 
-import PrelNames( Unique, hasKey, fromIntClassOpKey, fromIntegerClassOpKey )
+import PrelNames( Unique, hasKey, fromIntName, fromIntegerClassOpKey )
 import Maybe	( catMaybes )
 import Util	( thenCmp, zipWithEqual, mapAccumL )
 import Outputable
@@ -663,7 +662,7 @@ lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
 							-- (i.e. no funny business with user-defined
 							--  packages of numeric classes)
   =	-- So we can use the Prelude fromInt 
-    tcLookupGlobalId fromIntClassOpName	`thenNF_Tc` \ from_int ->
+    tcLookupGlobalId fromIntName		`thenNF_Tc` \ from_int ->
     newMethodAtLoc loc from_int [ty]		`thenNF_Tc` \ (method_inst, method_id) ->
     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
 
diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 5282dea..edfd1f2 100644
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -1,11 +1,11 @@
 \begin{code}
 module TcEnv(
 	TcId, TcIdSet, 
-	TyThing(..), TyThingDetails(..),
+	TyThing(..), TyThingDetails(..), TcTyThing(..),
 
 	-- Getting stuff from the environment
 	TcEnv, initTcEnv, 
-	tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds,
+	tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds, tcEnvTyVars,
 	
 	-- Instance environment
 	tcGetInstEnv, tcSetInstEnv, 
diff --git a/ghc/compiler/typecheck/TcImprove.lhs b/ghc/compiler/typecheck/TcImprove.lhs
index fff161b..8a66a7d 100644
--- a/ghc/compiler/typecheck/TcImprove.lhs
+++ b/ghc/compiler/typecheck/TcImprove.lhs
@@ -7,7 +7,8 @@ import Name		( Name )
 import Class		( Class, FunDep, className )
 import Unify		( unifyTyListsX )
 import Subst		( mkSubst, emptyInScopeSet, substTy )
-import TcEnv		( tcGetInstEnv, classInstEnv )
+import TcEnv		( tcGetInstEnv )
+import TcInstUtil	( classInstEnv )
 import TcMonad
 import TcType		( TcType, TcTyVarSet, zonkTcType )
 import TcUnify		( unifyTauTyLists )
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index e2dd2b0..26616bc 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -193,7 +193,7 @@ tcInstDecls1 pcs hst unf_env this_mod decls mod
 	generic_inst_info = concat generic_inst_infos	-- All local
 
 	imported_dfuns	 = map (tcAddImportedIdInfo unf_env . instInfoDFun) imported_inst_info
-	hst_dfuns	 = foldModuleEnv ((++) . mdInsts) [] hst
+	hst_dfuns	 = foldModuleEnv ((++) . md_insts) [] hst
     in
     addInstDFuns (pcsInsts pcs) imported_dfuns	`thenNF_Tc` \ inst_env1 ->
     addInstDFuns inst_env1 hst_dfuns		`thenNF_Tc` \ inst_env2 ->
diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs
index bc30d93..41cdafb 100644
--- a/ghc/compiler/typecheck/TcInstUtil.lhs
+++ b/ghc/compiler/typecheck/TcInstUtil.lhs
@@ -21,21 +21,27 @@ module TcInstUtil (
 import RnHsSyn		( RenamedMonoBinds, RenamedSig )
 import HsTypes		( toHsType )
 
-import CmdLineOpts	( opt_AllowOverlappingInstances )
+import CmdLineOpts	( dopt_AllowOverlappingInstances )
 import TcMonad
 --import TcEnv		( InstEnv, emptyInstEnv, addToInstEnv )
 import Bag		( bagToList, Bag )
 import Class		( Class )
 import Var		( TyVar, Id, idName )
-import Maybes		( MaybeErr(..) )
+import VarSet		( unionVarSet, mkVarSet )
+import VarEnv		( TyVarSubstEnv )
+import Maybes		( MaybeErr(..), returnMaB, failMaB, thenMaB, maybeToBool )
 import Name		( getSrcLoc, nameModule, isLocallyDefined, toRdrName )
 import SrcLoc		( SrcLoc )
-import Type		( Type, ThetaType, splitTyConApp_maybe, mkSigmaTy, mkDictTy )
+import Type		( Type, ThetaType, splitTyConApp_maybe, 
+			  mkSigmaTy, mkDictTy, tyVarsOfTypes )
 import PprType		( pprConstraint )
 import Class		( classTyCon )
 import DataCon		( DataCon )
 import TyCon		( TyCon, tyConDataCons )
 import Outputable
+import HscTypes		( InstEnv, ClsInstEnv )
+import Unify		( matchTys, unifyTyListsX )
+import UniqFM		( lookupWithDefaultUFM, addToUFM, emptyUFM )
 \end{code}
 
 
diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs
index 21a8d89..d71810c 100644
--- a/ghc/compiler/typecheck/TcMonad.lhs
+++ b/ghc/compiler/typecheck/TcMonad.lhs
@@ -27,6 +27,7 @@ module TcMonad(
 	tcGetEnv, tcSetEnv,
 	tcGetDefaultTys, tcSetDefaultTys,
 	tcGetUnique, tcGetUniques, tcGetDFunUniq,
+	doptsTc,
 
 	tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
 	tcAddErrCtxtM, tcSetErrCtxtM,
@@ -49,7 +50,7 @@ import RnHsSyn		( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr, RenamedHsOverL
 import Type		( Type, Kind, PredType, ThetaType, RhoType, TauType,
 			)
 import ErrUtils		( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
-import CmdLineOpts      ( opt_PprStyle_Debug )
+import CmdLineOpts      ( DynFlags, opt_PprStyle_Debug )
 
 import Bag		( Bag, emptyBag, isEmptyBag,
 			  foldBag, unitBag, unionBags, snocBag )
@@ -123,12 +124,24 @@ type TcRef a = IORef a
 \end{code}
 
 \begin{code}
+<<<<<<< TcMonad.lhs
+-- initEnv is passed in to avoid module recursion between TcEnv & TcMonad.
+
+initTc :: DynFlags
+       -> UniqSupply
+       -> (TcRef (UniqFM a) -> TcEnv)
+=======
 initTc :: TcEnv
        -> SrcLoc
+>>>>>>> 1.44
        -> TcM r
        -> IO (Maybe r, (Bag ErrMsg, Bag WarnMsg))
 
+<<<<<<< TcMonad.lhs
+initTc dflags us initenv do_this
+=======
 initTc tc_env src_loc do_this
+>>>>>>> 1.44
   = do {
       us       <- mkSplitUniqSupply 'a' ;
       us_var   <- newIORef us ;
@@ -137,8 +150,13 @@ initTc tc_env src_loc do_this
       tvs_var  <- newIORef emptyUFM ;
 
       let
+<<<<<<< TcMonad.lhs
+          init_down = TcDown dflags [] us_var dfun_var
+			     noSrcLoc
+=======
           init_down = TcDown [] us_var dfun_var
 			     src_loc
+>>>>>>> 1.44
 			     [] errs_var
       ;
 
@@ -252,7 +270,7 @@ We throw away any error messages!
 
 \begin{code}
 forkNF_Tc :: NF_TcM r -> NF_TcM r
-forkNF_Tc m (TcDown deflts u_var df_var src_loc err_cxt err_var) env
+forkNF_Tc m (TcDown dflags deflts u_var df_var src_loc err_cxt err_var) env
   = do
 	-- Get a fresh unique supply
     	us <- readIORef u_var
@@ -263,7 +281,7 @@ forkNF_Tc m (TcDown deflts u_var df_var src_loc err_cxt err_var) env
 		us_var'  <- newIORef us2 ;
 	      	err_var' <- newIORef (emptyBag,emptyBag) ;
       		tv_var'  <- newIORef emptyUFM ;
-		let { down' = TcDown deflts us_var' df_var src_loc err_cxt err_var' } ;
+		let { down' = TcDown dflags deflts us_var' df_var src_loc err_cxt err_var' } ;
 		m down' env
 			-- ToDo: optionally dump any error messages
 		})
@@ -583,15 +601,18 @@ tcGetDFunUniq key down env
 
 \begin{code}
 data TcDown
-  = TcDown
-	[Type]			-- Types used for defaulting
+   = TcDown {
+        tc_dflags :: DynFlags,
+	tc_def    :: [Type],			-- Types used for defaulting
 
-	(TcRef UniqSupply)	-- Unique supply
-	(TcRef DFunNameSupply)	-- Name supply for dictionary function names
+	tc_us     :: (TcRef UniqSupply),	-- Unique supply
+	tc_ds	  :: (TcRef DFunNameSupply),	-- Name supply for 
+						-- dictionary function names
 
-	SrcLoc			-- Source location
-	ErrCtxt			-- Error context
-	(TcRef (Bag WarnMsg, Bag ErrMsg))
+	tc_loc    :: SrcLoc,			-- Source location
+	tc_ctxt   :: ErrCtxt,			-- Error context
+	tc_errs   :: (TcRef (Bag WarnMsg, Bag ErrMsg))
+   }
 
 type ErrCtxt = [TidyEnv -> NF_TcM (TidyEnv, Message)]	
 			-- Innermost first.  Monadic so that we have a chance
@@ -615,21 +636,25 @@ type DFunNameSupply = FiniteMap String Int
 -- These selectors are *local* to TcMonad.lhs
 
 \begin{code}
-getTcErrs (TcDown def us ds loc ctxt errs)      = errs
-setTcErrs (TcDown def us ds loc ctxt _   ) errs = TcDown def us ds loc ctxt errs
+getTcErrs (TcDown{tc_errs=errs}) = errs
+setTcErrs down errs = down{tc_errs=errs}
+
+getDefaultTys (TcDown{tc_def=def}) = def
+setDefaultTys down def = down{tc_def=def}
 
-getDefaultTys (TcDown def us ds loc ctxt errs)     = def
-setDefaultTys (TcDown _   us ds loc ctxt errs) def = TcDown def us ds loc ctxt errs
+getLoc (TcDown{tc_loc=loc}) = loc
+setLoc down loc = down{tc_loc=loc}
 
-getLoc (TcDown def us ds loc ctxt errs)     = loc
-setLoc (TcDown def us ds _   ctxt errs) loc = TcDown def us ds loc ctxt errs
+getUniqSupplyVar (TcDown{tc_us=us}) = us
+getDFunSupplyVar (TcDown{tc_ds=ds}) = ds
 
-getUniqSupplyVar (TcDown def us ds loc ctxt errs) = us
-getDFunSupplyVar (TcDown def us ds loc ctxt errs) = ds
+getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt
+setErrCtxt down msg = down{tc_ctxt=[msg]}
+addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
 
-setErrCtxt (TcDown def us ds loc ctxt errs) msg = TcDown def us ds loc [msg]      errs
-addErrCtxt (TcDown def us ds loc ctxt errs) msg = TcDown def us ds loc (msg:ctxt) errs
-getErrCtxt (TcDown def us ds loc ctxt errs)     = ctxt
+doptsTc :: (DynFlags -> Bool) -> TcM Bool
+doptsTc dopt (TcDown{tc_dflags=dflags}) env_down
+   = return (dopt dflags)
 \end{code}
 
 
diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index 38e4cbf..41838df 100644
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -25,10 +25,10 @@ import TcHsSyn		( TcId )
 
 import TcMonad
 import TcEnv		( tcExtendTyVarEnv, tcExtendKindEnv, 
-			  tcLookup, tcLookupGlobal,
-			  tcGetEnv, tcEnvTyVars, tcEnvTcIds,
+			  --tcLookup, tcLookupGlobal,
+			  tcEnvTcIds, tcEnvTyVars,
 			  tcGetGlobalTyVars, 
-		 	  TyThing(..)
+		 	  TyThing(..), TcTyThing(..)
 			)
 import TcType		( TcType, TcKind, TcTyVar, TcThetaType, TcTauType,
 			  newKindVar, tcInstSigVar,
@@ -65,7 +65,7 @@ import BasicTypes	( Boxity(..) )
 import SrcLoc		( SrcLoc )
 import Util		( mapAccumL, isSingleton )
 import Outputable
-
+import HscTypes		( TyThing(..) )
 \end{code}
 
 
diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index f16b34d..336eeb6 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -123,7 +123,7 @@ module TcSimplify (
 
 #include "HsVersions.h"
 
-import CmdLineOpts	( opt_MaxContextReductionDepth, opt_GlasgowExts, opt_WarnTypeDefaults )
+import CmdLineOpts	( opt_MaxContextReductionDepth, dopt_GlasgowExts, opt_WarnTypeDefaults )
 import HsSyn		( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
 import TcHsSyn		( TcExpr, TcId, 
 			  TcMonoBinds, TcDictBinds
@@ -143,9 +143,9 @@ import Inst		( lookupInst, lookupSimpleInst, LookupInstResult(..),
 			  mkLIE, emptyLIE, unitLIE, consLIE, plusLIE,
 			  lieToList 
 			)
-import TcEnv		( tcGetGlobalTyVars, tcGetInstEnv,
-			  lookupInstEnv, InstLookupResult(..) 
-			)
+import TcEnv		( tcGetGlobalTyVars, tcGetInstEnv )
+import TcInstUtil	( lookupInstEnv, InstLookupResult(..) )
+
 import TcType		( TcTyVarSet )
 import TcUnify		( unifyTauTy )
 import Id		( idType )
@@ -161,7 +161,6 @@ import PprType		( pprConstraint )
 import TysWiredIn	( unitTy )
 import VarSet
 import FiniteMap
-import CmdLineOpts	( opt_GlasgowExts )
 import Outputable
 import ListSetOps	( equivClasses )
 import Util		( zipEqual, mapAccumL )
@@ -849,17 +848,18 @@ tcSimplifyThetas :: ClassContext		-- Wanted
 	       	 -> TcM ClassContext		-- Needed
 
 tcSimplifyThetas wanteds
-  = reduceSimple [] wanteds		`thenNF_Tc` \ irreds ->
+  = doptsTc dopt_GlasgowExts 		`thenNF_Tc` \ glaExts ->
+    reduceSimple [] wanteds		`thenNF_Tc` \ irreds ->
     let
 	-- For multi-param Haskell, check that the returned dictionaries
  	-- don't have any of the form (C Int Bool) for which
 	-- we expect an instance here
 	-- For Haskell 98, check that all the constraints are of the form C a,
 	-- where a is a type variable
-    	bad_guys | opt_GlasgowExts = [ct | ct@(clas,tys) <- irreds, 
-					   isEmptyVarSet (tyVarsOfTypes tys)]
-		 | otherwise       = [ct | ct@(clas,tys) <- irreds, 
-					   not (all isTyVarTy tys)]
+    	bad_guys | glaExts   = [ct | ct@(clas,tys) <- irreds, 
+				     isEmptyVarSet (tyVarsOfTypes tys)]
+		 | otherwise = [ct | ct@(clas,tys) <- irreds, 
+				     not (all isTyVarTy tys)]
     in
     if null bad_guys then
 	returnTc irreds
diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index a3fd008..183b6c1 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -694,7 +694,7 @@ splitDictTy (NoteTy _ ty) = splitDictTy ty
 splitDictTy (PredTy (Class clas tys)) = (clas, tys)
 
 splitDictTy_maybe :: Type -> Maybe (Class, [Type])
-splitDictTy_maybe (NoteTy _ ty) = splitDictTy ty
+splitDictTy_maybe (NoteTy _ ty) = Just (splitDictTy ty)
 splitDictTy_maybe (PredTy (Class clas tys)) = Just (clas, tys)
 splitDictTy_maybe other			    = Nothing