[project @ 2000-10-17 10:27:58 by sewardj]

typechecker burbles

ghc/compiler/main/ErrUtils.lhs

@@ -11,7 +11,7 @@ module ErrUtils (
 	dontAddErrLoc,
 	printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings,
 	ghcExit,
-	doIfSet, dumpIfSet
+	doIfSet, dumpIfSet, dumpIfSet_dyn
     ) where
 
 #include "HsVersions.h"
@@ -99,14 +99,21 @@ doIfSet flag action | flag      = action
 \end{code}
 
 \begin{code}
-dumpIfSet :: DynFlags -> (DynFlags -> Bool) -> String -> SDoc -> IO ()
-dumpIfSet dflags flag hdr doc
+dumpIfSet :: Bool -> String -> SDoc -> IO ()
+dumpIfSet flag hdr doc
+  | not flag   = return ()
+  | otherwise  = printDump (dump hdr doc)
+
+dumpIfSet_dyn :: DynFlags -> (DynFlags -> Bool) -> String -> SDoc -> IO ()
+dumpIfSet_dyn dflags flag hdr doc
   | not (flag dflags)  = return ()
-  | otherwise          = printDump dump
-  where
-    dump = vcat [text "", 
-		 line <+> text hdr <+> line,
-		 doc,
-		 text ""]
-    line = text (take 20 (repeat '='))
+  | otherwise          = printDump (dump hdr doc)
+
+dump hdr doc 
+   = vcat [text "", 
+	   line <+> text hdr <+> line,
+	   doc,
+	   text ""]
+     where 
+        line = text (take 20 (repeat '='))
 \end{code}

ghc/compiler/main/HscTypes.lhs

@@ -91,12 +91,29 @@ data ModDetails
         md_rules    :: RuleEnv		-- Domain may include Ids from other modules
      }
 
+-- ModIFace is nearly the same as RnMonad.ParsedIface.
+-- Right now it's identical :)
+data ModIFace 
+   = ModIFace {
+        mi_mod       :: Module,                   -- Complete with package info
+        mi_vers      :: Version,                  -- Module version number
+        mi_orphan    :: WhetherHasOrphans,        -- Whether this module has orphans
+        mi_usages    :: [ImportVersion OccName],  -- Usages
+        mi_exports   :: [ExportItem],             -- Exports
+        mi_insts     :: [RdrNameInstDecl],        -- Local instance declarations
+        mi_decls     :: [(Version, RdrNameHsDecl)],    -- Local definitions
+        mi_fixity    :: (Version, [RdrNameFixitySig]), -- Local fixity declarations, 
+                                                       -- with their version
+        mi_rules     :: (Version, [RdrNameRuleDecl]),  -- Rules, with their version
+        mi_deprecs   :: [RdrNameDeprecation]           -- Deprecations
+     }
+
 \end{code}
 
 \begin{code}
 emptyModDetails :: Module -> ModDetails
 emptyModDetails mod
-  = ModDetails { md_id       = mod,
+  = ModDetails { md_module   = mod,
 		 md_exports  = [],
 		 md_globals  = emptyRdrEnv,
 		 md_fixities = emptyNameEnv,

ghc/compiler/typecheck/TcClassDcl.lhs

@@ -39,7 +39,7 @@ import PrelInfo		( nO_METHOD_BINDING_ERROR_ID )
 import Class		( classTyVars, classBigSig, classSelIds, classTyCon, Class, ClassOpItem,
 			  DefMeth (..) )
 import Bag		( bagToList )
-import CmdLineOpts      ( opt_GlasgowExts, opt_WarnMissingMethods, opt_PprStyle_Debug )
+import CmdLineOpts      ( dopt_GlasgowExts, opt_WarnMissingMethods, opt_PprStyle_Debug )
 import MkId		( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
 import DataCon		( mkDataCon, notMarkedStrict )
 import Id		( Id, idType, idName )
@@ -105,7 +105,8 @@ tcClassDecl1 rec_env
 			tyvar_names fundeps class_sigs def_methods pragmas 
 			sys_names src_loc)
   = 	-- CHECK ARITY 1 FOR HASKELL 1.4
-    checkTc (opt_GlasgowExts || length tyvar_names == 1)
+    doptsTc dopt_GlasgowExts				`thenTc` \ glaExts ->
+    checkTc (glaExts || length tyvar_names == 1)
 	    (classArityErr class_name)			`thenTc_`
 
 	-- LOOK THINGS UP IN THE ENVIRONMENT
@@ -210,11 +211,12 @@ tcSuperClasses clas context sc_sel_names
 	-- only the type variable of the class decl.
 
 	-- For std Haskell check that the context constrains only tyvars
-    (if opt_GlasgowExts then
+    doptsTc dopt_GlasgowExts			`thenTc` \ glaExts ->
+    (if glaExts then
 	returnTc ()
      else
 	mapTc_ check_constraint context
-    )					`thenTc_`
+    )						`thenTc_`
 
 	-- Context is already kind-checked
     tcClassContext context			`thenTc` \ sc_theta ->
@@ -576,7 +578,7 @@ mkDefMethRhs is_inst_decl clas inst_tys sel_id loc GenDefMeth
 	-- 	(checkTc, so False provokes the error)
      checkTc (not is_inst_decl || simple_inst)
 	     (badGenericInstance sel_id clas)			`thenTc_`
-		
+
      ioToTc (dumpIfSet opt_PprStyle_Debug "Generic RHS" stuff)	`thenNF_Tc_`
      returnTc rhs
   where

ghc/compiler/typecheck/TcEnv.lhs

@@ -34,46 +34,48 @@ module TcEnv(
 #include "HsVersions.h"
 
 import TcMonad
-import TcType	( TcKind,  TcType, TcTyVar, TcTyVarSet, TcThetaType,
-		  tcInstTyVars, zonkTcTyVars,
-		)
-import Id	( mkUserLocal, isDataConWrapId_maybe )
-import IdInfo	( vanillaIdInfo )
-import MkId 	( mkSpecPragmaId )
-import Var	( TyVar, Id, setVarName,
-		  idType, lazySetIdInfo, idInfo, tyVarKind, UVar,
-		)
+import TcType		( TcKind,  TcType, TcTyVar, TcTyVarSet, TcThetaType,
+			  tcInstTyVars, zonkTcTyVars,
+			)
+import Id		( mkUserLocal, isDataConWrapId_maybe )
+import IdInfo		( vanillaIdInfo )
+import MkId	 	( mkSpecPragmaId )
+import Var		( TyVar, Id, setVarName,
+			  idType, lazySetIdInfo, idInfo, tyVarKind, UVar,
+			)
 import VarSet
-import VarEnv	( TyVarSubstEnv )
-import Type	( Kind, Type, superKind,
-		  tyVarsOfType, tyVarsOfTypes,
-		  splitForAllTys, splitRhoTy, splitFunTys,
-		  splitAlgTyConApp_maybe, getTyVar, getDFunTyKey
-		)
-import DataCon	( DataCon )
-import TyCon	( TyCon, tyConKind, tyConArity, isSynTyCon )
-import Class	( Class, ClassOpItem, ClassContext, classTyCon )
-import Subst	( substTy )
-import Name	( Name, OccName, NamedThing(..), 
-		  nameOccName, nameModule, getSrcLoc, mkGlobalName,
-		  isLocallyDefined,
-		  NameEnv, emptyNameEnv, lookupNameEnv, nameEnvElts, 
-		  extendNameEnv, extendNameEnvList
-		)
-import OccName	( mkDFunOcc, mkDefaultMethodOcc, occNameString )
-import Module	( Module )
-import Unify	( unifyTyListsX, matchTys )
-import HscTypes	( ModDetails(..), InstEnv, lookupTypeEnv, TyThing(..),
-		  GlobalSymbolTable, Provenance(..) )
-import Unique	( pprUnique10, Unique, Uniquable(..) )
+import VarEnv		( TyVarSubstEnv )
+import Type		( Kind, Type, superKind,
+			  tyVarsOfType, tyVarsOfTypes,
+			  splitForAllTys, splitRhoTy, splitFunTys,
+			  splitAlgTyConApp_maybe, getTyVar, getDFunTyKey
+			)
+import DataCon		( DataCon )
+import TyCon		( TyCon, tyConKind, tyConArity, isSynTyCon )
+import Class		( Class, ClassOpItem, ClassContext, classTyCon )
+import Subst		( substTy )
+import Name		( Name, OccName, NamedThing(..), 
+			  nameOccName, nameModule, getSrcLoc, mkGlobalName,
+			  isLocallyDefined,
+			  NameEnv, emptyNameEnv, lookupNameEnv, nameEnvElts, 
+			  extendNameEnv, extendNameEnvList
+			)
+import OccName		( mkDFunOcc, mkDefaultMethodOcc, occNameString )
+import Module		( Module )
+import Unify		( unifyTyListsX, matchTys )
+import HscTypes		( ModDetails(..), InstEnv, lookupTypeEnv, TyThing(..),
+			  GlobalSymbolTable, Provenance(..) )
+import Unique		( pprUnique10, Unique, Uniquable(..) )
 import UniqFM
-import Unique	( Uniquable(..) )
-import Util	( zipEqual, zipWith3Equal, mapAccumL )
-import SrcLoc	( SrcLoc )
+import Unique		( Uniquable(..) )
+import Util		( zipEqual, zipWith3Equal, mapAccumL )
+import SrcLoc		( SrcLoc )
 import FastString	( FastString )
 import Maybes
 import Outputable
-import IOExts	( newIORef )
+import TcInstUtil	( emptyInstEnv )
+
+import IOExts		( newIORef )
 \end{code}
 
 %************************************************************************
@@ -142,7 +144,7 @@ data TcTyThing
 --	4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment
 
 initTcEnv :: GlobalSymbolTable -> IO TcEnv
-initTcEnv gst inst_env
+initTcEnv gst
   = do { gtv_var <- newIORef emptyVarSet ;
 	 return (TcEnv { tcGST    = gst,
 		      	 tcGEnv   = emptyNameEnv,

ghc/compiler/typecheck/TcMonad.lhs

@@ -21,13 +21,14 @@ module TcMonad(
 	listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
 
 	checkTc, checkTcM, checkMaybeTc, checkMaybeTcM, 
-	failTc, failWithTc, addErrTc, addErrsTc, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
+	failTc, failWithTc, addErrTc, addErrsTc, warnTc, 
+	recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
 	addErrTcM, addInstErrTcM, failWithTcM,
 
 	tcGetEnv, tcSetEnv,
 	tcGetDefaultTys, tcSetDefaultTys,
 	tcGetUnique, tcGetUniques, tcGetDFunUniq,
-	doptsTc,
+	doptsTc, getDOptsTc,
 
 	tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
 	tcAddErrCtxtM, tcSetErrCtxtM,
@@ -112,9 +113,6 @@ type TcKind      = TcType
 \begin{code}
 type NF_TcM r =  TcDown -> TcEnv -> IO r	-- Can't raise UserError
 type TcM    r =  TcDown -> TcEnv -> IO r	-- Can raise UserError
-	-- ToDo: nuke the 's' part
-	-- The difference between the two is
-	-- now for documentation purposes only
 
 type Either_TcM r =  TcDown -> TcEnv -> IO r	-- Either NF_TcM or TcM
 	-- Used only in this file for type signatures which
@@ -641,6 +639,10 @@ addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
 doptsTc :: (DynFlags -> Bool) -> TcM Bool
 doptsTc dopt (TcDown{tc_dflags=dflags}) env_down
    = return (dopt dflags)
+
+getDOptsTc :: TcM DynFlags
+getDOptsTc (TcDown{tc_dflags=dflags}) env_down
+   = return dflags
 \end{code}