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

typechecker burbles

diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs
index 18b9e38..f9c7ae5 100644 (file)
--- a/ghc/compiler/main/ErrUtils.lhs
+++ b/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}

diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs
index 12bbfcf..7c9ae96 100644 (file)
--- a/ghc/compiler/main/HscTypes.lhs
+++ b/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,

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 4c038e7..c4ede90 100644 (file)
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/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

diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 228a688..5875c2f 100644 (file)
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/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,

diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs
index 341a618..c365b94 100644 (file)
--- a/ghc/compiler/typecheck/TcMonad.lhs
+++ b/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}