From: sewardj Date: Tue, 17 Oct 2000 10:27:58 +0000 (+0000) Subject: [project @ 2000-10-17 10:27:58 by sewardj] X-Git-Tag: Approximately_9120_patches~3554 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=a9d4abde339c30eeb7c7baf0a0edb13fa4a2eacd;p=ghc-hetmet.git [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 --- 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 --- 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 --- 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 --- 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 --- 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}