From 0b445d919bc1f6e8014956d67a1154d8d2af3521 Mon Sep 17 00:00:00 2001 From: sewardj Date: Tue, 17 Oct 2000 15:57:57 +0000 Subject: [PATCH] [project @ 2000-10-17 15:57:57 by sewardj] Fix enough renamer bits to get going again on the typechecker. HACK ALERT: RnIfaces is almost completely #ifdef'd out! --- ghc/compiler/basicTypes/Name.lhs | 2 +- ghc/compiler/prelude/PrelNames.lhs | 10 +++++ ghc/compiler/rename/RnBinds.lhs | 13 ++++--- ghc/compiler/rename/RnExpr.lhs | 18 ++++----- ghc/compiler/rename/RnIfaces.lhs | 65 ++++++++++++++++++++------------- ghc/compiler/typecheck/TcDeriv.lhs | 46 ++++++++++++----------- ghc/compiler/typecheck/TcEnv.lhs | 3 ++ ghc/compiler/typecheck/TcInstUtil.lhs | 2 +- 8 files changed, 96 insertions(+), 63 deletions(-) diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 18d1918..9fe8142 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -121,7 +121,7 @@ nameModule name = pprPanic "nameModule" (ppr name) \begin{code} isLocallyDefinedName :: Name -> Bool isUserExportedName :: Name -> Bool -isLocalName :: Name -> Bool -- Not globala +isLocalName :: Name -> Bool -- Not globals isGlobalName :: Name -> Bool isSystemName :: Name -> Bool isExternallyVisibleName :: Name -> Bool diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index f99fe5f..f73146a 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -807,6 +807,16 @@ enumFrom_RDR = nameRdrName enumFromName mkInt_RDR = nameRdrName intDataConName enumFromThen_RDR = nameRdrName enumFromThenName enumFromThenTo_RDR = nameRdrName enumFromThenToName +ratioDataCon_RDR = nameRdrName ratioDataConName +plusInteger_RDR = nameRdrName plusIntegerName +timesInteger_RDR = nameRdrName timesIntegerName +enumClass_RDR = nameRdrName enumClassName +monadClass_RDR = nameRdrName monadClassName +ioDataCon_RDR = nameRdrName ioDataConName +cCallableClass_RDR = nameRdrName cCallableClassName +cReturnableClass_RDR = nameRdrName cReturnableClassName +eqClass_RDR = nameRdrName eqClassName +eqString_RDR = nameRdrName eqStringName \end{code} diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index 9ec3657..bfc67ad 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -31,15 +31,16 @@ import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn, FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV ) -import CmdLineOpts ( opt_WarnMissingSigs ) +import CmdLineOpts ( DynFlag(..) ) import Digraph ( stronglyConnComp, SCC(..) ) -import Name ( OccName, Name, nameOccName, mkUnboundName, isUnboundName ) +import Name ( OccName, Name, nameOccName ) import NameSet import RdrName ( RdrName, rdrNameOcc ) import BasicTypes ( RecFlag(..) ) import List ( partition ) import Bag ( bagToList ) import Outputable +import PrelNames ( mkUnboundName, isUnboundName ) \end{code} -- ToDo: Put the annotations into the monad, so that they arrive in the proper @@ -169,11 +170,13 @@ rnTopMonoBinds mbinds sigs let bndr_name_set = mkNameSet binder_names in - renameSigs (okBindSig bndr_name_set) sigs `thenRn` \ (siglist, sig_fvs) -> + renameSigs (okBindSig bndr_name_set) sigs `thenRn` \ (siglist, sig_fvs) -> + doptRn Opt_WarnMissingSigs `thenRn` \ warnMissing -> let type_sig_vars = [n | Sig n _ _ <- siglist] - un_sigd_binders | opt_WarnMissingSigs = nameSetToList (delListFromNameSet bndr_name_set type_sig_vars) - | otherwise = [] + un_sigd_binders | warnMissing = nameSetToList (delListFromNameSet + bndr_name_set type_sig_vars) + | otherwise = [] in mapRn_ (addWarnRn.missingSigWarn) un_sigd_binders `thenRn_` diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 0225370..3cf439d 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -26,12 +26,12 @@ import RnHsSyn import RnMonad import RnEnv import RnIfaces ( lookupFixityRn ) -import CmdLineOpts ( dopt_GlasgowExts, opt_IgnoreAsserts ) +import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts ) import Literal ( inIntRange ) import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity ) import PrelNames ( hasKey, assertIdKey, eqClass_RDR, foldr_RDR, build_RDR, eqString_RDR, - ccallableClass_RDR, creturnableClass_RDR, + cCallableClass_RDR, cReturnableClass_RDR, monadClass_RDR, enumClass_RDR, ordClass_RDR, ratioDataCon_RDR, negate_RDR, assertErr_RDR, ioDataCon_RDR, plusInteger_RDR, timesInteger_RDR @@ -67,9 +67,9 @@ rnPat (VarPatIn name) returnRn (VarPatIn vname, emptyFVs) rnPat (SigPatIn pat ty) - = doptsRn dopt_GlasgowExts `thenRn` \ opt_GlasgowExts -> + = doptRn Opt_GlasgowExts `thenRn` \ glaExts -> - if opt_GlasgowExts + if glaExts then rnPat pat `thenRn` \ (pat', fvs1) -> rnHsType doc ty `thenRn` \ (ty', fvs2) -> returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2) @@ -184,7 +184,7 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss) mapFvRn rnPat pats `thenRn` \ (pats', pat_fvs) -> rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) -> - doptsRn dopt_GlasgowExts `thenRn` \ opt_GlasgowExts -> + doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts -> (case maybe_rhs_sig of Nothing -> returnRn (Nothing, emptyFVs) Just ty | opt_GlasgowExts -> rnHsType doc_sig ty `thenRn` \ (ty', ty_fvs) -> @@ -220,7 +220,7 @@ rnGRHSs (GRHSs grhss binds maybe_ty) returnRn (GRHSs grhss' binds' Nothing, fvGRHSs) rnGRHS (GRHS guarded locn) - = doptsRn dopt_GlasgowExts `thenRn` \ opt_GlasgowExts -> + = doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts -> pushSrcLocRn locn $ (if not (opt_GlasgowExts || is_standard_guard guarded) then addWarnRn (nonStdGuardErr guarded) @@ -345,8 +345,8 @@ rnExpr section@(SectionR op expr) rnExpr (HsCCall fun args may_gc is_casm fake_result_ty) -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls - = lookupOrigNames [ccallableClass_RDR, - creturnableClass_RDR, + = lookupOrigNames [cCallableClass_RDR, + cReturnableClass_RDR, ioDataCon_RDR] `thenRn` \ implicit_fvs -> rnExprs args `thenRn` \ (args', fvs_args) -> returnRn (HsCCall fun args' may_gc is_casm fake_result_ty, @@ -799,7 +799,7 @@ litFVs (HsInt i) = returnRn (unitFV (getName intTyCon)) litFVs (HsIntPrim i) = returnRn (unitFV (getName intPrimTyCon)) litFVs (HsFloatPrim f) = returnRn (unitFV (getName floatPrimTyCon)) litFVs (HsDoublePrim d) = returnRn (unitFV (getName doublePrimTyCon)) -litFVs (HsLitLit l bogus_ty) = lookupOrigName ccallableClass_RDR `thenRn` \ cc -> +litFVs (HsLitLit l bogus_ty) = lookupOrigName cCallableClass_RDR `thenRn` \ cc -> returnRn (unitFV cc) litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit) -- HsInteger and HsRat only appear -- in post-typechecker translations diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 7be1ba1..43133a0 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -5,7 +5,10 @@ \begin{code} module RnIfaces ( - findAndReadIface, +#if 1 + lookupFixityRn +#else + findAndReadIface, getInterfaceExports, getDeferredDecls, getImportedInstDecls, getImportedRules, @@ -17,6 +20,7 @@ module RnIfaces ( getDeclBinders, getDeclSysBinders, removeContext -- removeContext probably belongs somewhere else +#endif ) where #include "HsVersions.h" @@ -41,11 +45,11 @@ import ParseIface ( parseIface, IfaceStuff(..) ) import Name ( Name {-instance NamedThing-}, nameOccName, nameModule, isLocallyDefined, - isWiredInName, NamedThing(..), + {-isWiredInName, -} NamedThing(..), elemNameEnv, extendNameEnv ) -import Module ( Module, mkVanillaModule, pprModuleName, - moduleName, isLocalModule, +import Module ( Module, mkVanillaModule, + moduleName, isModuleInThisPackage, ModuleName, WhereFrom(..), ) import RdrName ( RdrName, rdrNameOcc ) @@ -62,8 +66,14 @@ import Lex import FiniteMap import Outputable import Bag +import HscTypes import List ( nub ) + +#if 1 +import Panic ( panic ) +lookupFixityRn = panic "lookupFixityRn" +#else \end{code} @@ -82,12 +92,12 @@ loadOrphanModules :: [ModuleName] -> RnM d () loadOrphanModules mods | null mods = returnRn () | otherwise = traceRn (text "Loading orphan modules:" <+> - fsep (map pprModuleName mods)) `thenRn_` + fsep (map mods)) `thenRn_` mapRn_ load mods `thenRn_` returnRn () where load mod = loadInterface (mk_doc mod) mod ImportBySystem - mk_doc mod = pprModuleName mod <+> ptext SLIT("is a orphan-instance module") + mk_doc mod = ppr mod <+> ptext SLIT("is a orphan-instance module") loadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d Ifaces @@ -164,7 +174,7 @@ tryLoadInterface doc_str mod_name from -- about, it should be from a different package to this one WARN( not (maybeToBool mod_info) && case from of { ImportBySystem -> True; other -> False } && - isLocalModule mod, + isModuleInThisPackage mod, ppr mod ) loadDecls mod (iDecls ifaces) (pi_decls iface) `thenRn` \ (decls_vers, new_decls) -> @@ -220,7 +230,8 @@ addModDeps mod new_deps mod_deps -- and in that case, forget about the boot indicator filtered_new_deps :: (ModuleName, (WhetherHasOrphans, IsBootInterface)) filtered_new_deps - | isLocalModule mod = [ (imp_mod, (has_orphans, is_boot, False)) + | isModuleInThisPackage mod + = [ (imp_mod, (has_orphans, is_boot, False)) | (imp_mod, has_orphans, is_boot, _) <- new_deps ] | otherwise = [ (imp_mod, (True, False, False)) @@ -485,7 +496,7 @@ checkModUsage ((mod_name, _, _, whats_imported) : rest) = tryLoadInterface doc_str mod_name ImportBySystem `thenRn` \ (ifaces, maybe_err) -> case maybe_err of { Just err -> out_of_date (sep [ptext SLIT("Can't find version number for module"), - pprModuleName mod_name]) ; + ppr mod_name]) ; -- Couldn't find or parse a module mentioned in the -- old interface file. Don't complain -- it might just be that -- the current module doesn't need that import and it's been deleted @@ -503,10 +514,10 @@ checkModUsage ((mod_name, _, _, whats_imported) : rest) in -- If the module version hasn't changed, just move on if new_mod_vers == old_mod_vers then - traceRn (sep [ptext SLIT("Module version unchanged:"), pprModuleName mod_name]) + traceRn (sep [ptext SLIT("Module version unchanged:"), ppr mod_name]) `thenRn_` checkModUsage rest else - traceRn (sep [ptext SLIT("Module version has changed:"), pprModuleName mod_name]) + traceRn (sep [ptext SLIT("Module version has changed:"), ppr mod_name]) `thenRn_` -- Module version changed, so check entities inside @@ -534,7 +545,7 @@ checkModUsage ((mod_name, _, _, whats_imported) : rest) returnRn outOfDate -- This one failed, so just bail out now }} where - doc_str = sep [ptext SLIT("need version info for"), pprModuleName mod_name] + doc_str = sep [ptext SLIT("need version info for"), ppr mod_name] checkEntityUsage mod decls [] @@ -699,15 +710,18 @@ getInterfaceExports mod_name from = getHomeSymbolTableRn `thenRn` \ hst -> case lookupModuleEnvByName hst mod_name of { Just mds -> returnRn (mdModule mds, mdExports mds) ; - - loadInterface doc_str mod_name from `thenRn` \ ifaces -> - case lookupModuleEnv (iPST ifaces) mod_name of - Just mds -> returnRn (mdModule mod, mdExports mds) - -- loadInterface always puts something in the map - -- even if it's a fake + Nothing -> pprPanic "getInterfaceExports" (ppr mod_name) + +-- I think this is what it _used_ to say. JRS, 001017 +-- loadInterface doc_str mod_name from `thenRn` \ ifaces -> +-- case lookupModuleEnv (iPST ifaces) mod_name of +-- Just mds -> returnRn (mdModule mod, mdExports mds) +-- -- loadInterface always puts something in the map +-- -- even if it's a fake + } where - doc_str = sep [pprModuleName mod_name, ptext SLIT("is directly imported")] + doc_str = sep [ppr mod_name, ptext SLIT("is directly imported")] \end{code} @@ -950,7 +964,7 @@ mkImportExportInfo this_mod export_avails exports -- but don't actually *use* anything from Foo -- In which case record an empty dependency list where - is_lib_module = not (isLocalModule mod) + is_lib_module = not (isModuleInThisPackage mod) is_sys_import = case how_imported of ImportBySystem -> True other -> False @@ -1152,7 +1166,7 @@ findAndReadIface doc_str mod_name hi_boot_file trace_msg = sep [hsep [ptext SLIT("Reading"), if hi_boot_file then ptext SLIT("[boot]") else empty, ptext SLIT("interface for"), - pprModuleName mod_name <> semi], + ppr mod_name <> semi], nest 4 (ptext SLIT("reason:") <+> doc_str)] \end{code} @@ -1199,7 +1213,7 @@ readIface wanted_mod file_path \begin{code} noIfaceErr mod_name boot_file search_path - = vcat [ptext SLIT("Could not find interface file for") <+> quotes (pprModuleName mod_name), + = vcat [ptext SLIT("Could not find interface file for") <+> quotes (ppr mod_name), ptext SLIT("in the directories") <+> -- \& to avoid cpp interpreting this string as a -- comment starter with a pre-4.06 mkdependHS --SDM @@ -1229,14 +1243,15 @@ importDeclWarn name warnRedundantSourceImport mod_name = ptext SLIT("Unnecessary {- SOURCE -} in the import of module") - <+> quotes (pprModuleName mod_name) + <+> quotes (ppr mod_name) hiModuleNameMismatchWarn :: Module -> ModuleName -> Message hiModuleNameMismatchWarn requested_mod read_mod = hsep [ ptext SLIT("Something is amiss; requested module name") - , ppr requested_mod + , ppr (moduleName requested_mod) , ptext SLIT("differs from name found in the interface file") - , pprModuleName read_mod + , ppr read_mod ] \end{code} +#endif /* TEMP DEBUG HACK! */ \ No newline at end of file diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 80d6b10..15f49cb 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -13,18 +13,20 @@ module TcDeriv ( tcDeriving ) where import HsSyn ( HsBinds(..), MonoBinds(..), collectLocatedMonoBinders ) import RdrHsSyn ( RdrNameMonoBinds ) import RnHsSyn ( RenamedHsBinds ) -import CmdLineOpts ( opt_D_dump_deriv ) +import CmdLineOpts ( DynFlag(..) ) import TcMonad -import TcEnv ( InstEnv, getEnvTyCons, tcSetInstEnv, newDFunName ) +import TcEnv ( TcEnv, tcSetInstEnv, getTcGST, newDFunName ) import TcGenDeriv -- Deriv stuff -import TcInstUtil ( InstInfo(..), pprInstInfo, simpleDFunClassTyCon, extendInstEnv ) +import TcInstUtil ( InstInfo(..), InstEnv, + pprInstInfo, simpleDFunClassTyCon, extendInstEnv ) import TcSimplify ( tcSimplifyThetas ) import RnBinds ( rnMethodBinds, rnTopMonoBinds ) import RnEnv ( bindLocatedLocalsRn ) -import RnMonad ( RnNameSupply, +import RnMonad ( --RnNameSupply, renameSourceCode, thenRn, mapRn, returnRn ) +import HscTypes ( DFunId, GlobalSymbolTable, PersistentRenamerState ) import Bag ( Bag, emptyBag, unionBags, listToBag ) import Class ( classKey, Class ) @@ -35,17 +37,17 @@ import DataCon ( dataConArgTys, isNullaryDataCon, isExistentialDataCon ) import PrelInfo ( needsDataDeclCtxtClassKeys ) import Maybes ( maybeToBool, catMaybes ) import Module ( Module ) -import Name ( isLocallyDefined, getSrcLoc, NamedThing(..) ) +import Name ( Name, isLocallyDefined, getSrcLoc, NamedThing(..) ) import RdrName ( RdrName ) -import RnMonad ( FixityEnv ) +--import RnMonad ( FixityEnv ) import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings, tyConTheta, maybeTyConSingleCon, isDataTyCon, isEnumerationTyCon, isAlgTyCon, TyCon ) import Type ( TauType, mkTyVarTys, mkTyConApp, - mkSigmaTy, mkDictTy, isUnboxedType, - splitAlgTyConApp, classesToPreds + mkSigmaTy, splitSigmaTy, splitDictTy, mkDictTy, + isUnboxedType, splitAlgTyConApp, classesToPreds ) import TysWiredIn ( voidTy ) import Var ( TyVar ) @@ -215,7 +217,7 @@ tcDeriving prs mod inst_env_in local_tycons let extra_mbind_list = map gen_tag_n_con_monobind nm_alist_etc extra_mbinds = foldr AndMonoBinds EmptyMonoBinds extra_mbind_list - method_binds_s = map (gen_bind (tcGST env)) new_dfuns + method_binds_s = map (gen_bind (getTcGST env)) new_dfuns mbinders = collectLocatedMonoBinders extra_mbinds -- Rename to get RenamedBinds. @@ -231,7 +233,7 @@ tcDeriving prs mod inst_env_in local_tycons in mapNF_Tc gen_inst_info (new_dfuns `zip` rn_method_binds_s) `thenNF_Tc` \ new_inst_infos -> - ioToTc (dumpIfSet opt_D_dump_deriv "Derived instances" + ioToTc (dumpIfSet Opt_D_dump_deriv "Derived instances" (ddump_deriving new_inst_infos rn_extra_binds)) `thenTc_` returnTc (new_inst_infos, rn_extra_binds) @@ -248,7 +250,7 @@ tcDeriving prs mod inst_env_in local_tycons iTys = tys, iTheta = theta, iDFunId = dfun, iBinds = binds, iLoc = getSrcLoc dfun, iPrags = [] } - where + where (tyvars, theta, tau) = splitSigmaTy dfun (clas, tys) = splitDictTy tau @@ -286,7 +288,7 @@ makeDerivEqns this_mod local_tycons think_about_deriving = need_deriving local_tycons (derive_these, _) = removeDups cmp_deriv think_about_deriving in - if null local_data_tycons then + if null local_tycons then returnTc [] -- Bale out now else mapTc mk_eqn derive_these `thenTc` \ maybe_eqns -> @@ -313,15 +315,16 @@ makeDerivEqns this_mod local_tycons mk_eqn (clas, tycon) = case chk_out clas tycon of - Just err -> addErrTc err `thenNF_Tc_` + Just err -> addErrTc err `thenNF_Tc_` returnNF_Tc Nothing - Nothing -> newDFunName this_mod clas tys locn `thenNF_Tc` \ dfun_name -> + Nothing -> newDFunName this_mod clas tyvar_tys locn `thenNF_Tc` \ dfun_name -> returnNF_Tc (Just (dfun_name, clas, tycon, tyvars, constraints)) where clas_key = classKey clas tyvars = tyConTyVars tycon -- ToDo: Do we need new tyvars ??? tyvar_tys = mkTyVarTys tyvars data_cons = tyConDataCons tycon + locn = getSrcLoc tycon constraints = extra_constraints ++ concat (map mk_constraints data_cons) @@ -436,15 +439,15 @@ add_solns :: InstEnv -- The global, non-derived ones add_solns inst_env_in eqns solns = (new_dfuns, inst_env) - where - new_dfuns = zipWithEqual "add_solns" mk_deriv_dfun eqns solns - (inst_env, _) = extendInstEnv inst_env_in + where + new_dfuns = zipWithEqual "add_solns" mk_deriv_dfun eqns solns + (inst_env, _) = extendInstEnv inst_env_in -- Ignore the errors about duplicate instances. -- We don't want repeated error messages -- They'll appear later, when we do the top-level extendInstEnvs - mk_deriv_dfun (dfun_name clas, tycon, tyvars, _) theta - = mkDictFunId dfun_name clas tyvars [mkTyConApp tycon (mkTyVarTys tyvars)] theta + mk_deriv_dfun (dfun_name, clas, tycon, tyvars, _) theta + = mkDictFunId dfun_name clas tyvars [mkTyConApp tycon (mkTyVarTys tyvars)] theta \end{code} %************************************************************************ @@ -514,7 +517,7 @@ the renamer. What a great hack! -- (paired with class name, as we need that when generating dict -- names.) gen_bind :: GlobalSymbolTable -> DFunId -> RdrNameMonoBinds -gen_bind fixities inst +gen_bind fixities dfun | not (isLocallyDefined tycon) = EmptyMonoBinds | clas `hasKey` showClassKey = gen_Show_binds fixities tycon | clas `hasKey` readClassKey = gen_Read_binds fixities tycon @@ -575,7 +578,7 @@ gen_taggery_Names dfuns = foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far -> foldlTc do_tag2con names_so_far tycons_of_interest where - all_CTs = map simplDFunClassTyCon dfuns + all_CTs = map simpleDFunClassTyCon dfuns all_tycons = map snd all_CTs (tycons_of_interest, _) = removeDups compare all_tycons @@ -611,7 +614,6 @@ gen_taggery_Names dfuns is_in_eqns clas_key tycon ((c,t):cts) = (clas_key == classKey c && tycon == t) || is_in_eqns clas_key tycon cts - \end{code} \begin{code} diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 6882991..eb65396 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -6,6 +6,7 @@ module TcEnv( -- Getting stuff from the environment TcEnv, initTcEnv, tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds, tcEnvTyVars, + getTcGST, -- Instance environment tcGetInstEnv, tcSetInstEnv, @@ -159,6 +160,8 @@ tcEnvIds env = [id | AnId id <- nameEnvElts (tcGEnv env)] tcEnvTyVars env = [tv | ATyVar tv <- nameEnvElts (tcLEnv env)] tcEnvTcIds env = [id | ATcId id <- nameEnvElts (tcLEnv env)] +getTcGST (TcEnv { tcGST = gst }) = gst + -- This data type is used to help tie the knot -- when type checking type and class declarations data TyThingDetails = SynTyDetails Type diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs index d60a0a5..ac7615e 100644 --- a/ghc/compiler/typecheck/TcInstUtil.lhs +++ b/ghc/compiler/typecheck/TcInstUtil.lhs @@ -8,7 +8,7 @@ The bits common to TcInstDcls and TcDeriv. \begin{code} module TcInstUtil ( InstInfo(..), pprInstInfo, - simpleInstInfoTy, simpleInstInfoTyCon, + simpleInstInfoTy, simpleInstInfoTyCon, simpleDFunClassTyCon, -- Instance environment InstEnv, emptyInstEnv, extendInstEnv, -- 1.7.10.4