Skip to content

GitLab

Commit 0b445d91 authored by sewardj's avatar sewardj
Browse files

[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!
parent 17879095
Hide whitespace changes
Inline Side-by-side
Showing with 96 additions and 63 deletions
ghc/compiler/basicTypes/Name.lhs
View file @ 0b445d91
......@@ -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
......
ghc/compiler/prelude/PrelNames.lhs
View file @ 0b445d91
......@@ -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}
......
ghc/compiler/rename/RnBinds.lhs
View file @ 0b445d91
......@@ -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_`
......
ghc/compiler/rename/RnExpr.lhs
View file @ 0b445d91
......@@ -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
......
ghc/compiler/rename/RnIfaces.lhs
View file @ 0b445d91
......@@ -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
ghc/compiler/typecheck/TcDeriv.lhs
View file @ 0b445d91
......@@ -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}
......
ghc/compiler/typecheck/TcEnv.lhs
View file @ 0b445d91
......@@ -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
......
ghc/compiler/typecheck/TcInstUtil.lhs
View file @ 0b445d91
......@@ -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,
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment