Fix enough renamer bits to get going again on the typechecker.
HACK ALERT: RnIfaces is almost completely #ifdef'd out!
\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
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}
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
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_`
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
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)
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) ->
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)
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,
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
\begin{code}
module RnIfaces (
- findAndReadIface,
+#if 1
+ lookupFixityRn
+#else
+ findAndReadIface,
getInterfaceExports, getDeferredDecls,
getImportedInstDecls, getImportedRules,
getDeclBinders, getDeclSysBinders,
removeContext -- removeContext probably belongs somewhere else
+#endif
) where
#include "HsVersions.h"
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 )
import FiniteMap
import Outputable
import Bag
+import HscTypes
import List ( nub )
+
+#if 1
+import Panic ( panic )
+lookupFixityRn = panic "lookupFixityRn"
+#else
\end{code}
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
-- 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) ->
-- 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))
= 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
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
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 []
= 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}
-- 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
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}
\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
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
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 )
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 )
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.
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)
iTys = tys, iTheta = theta,
iDFunId = dfun, iBinds = binds,
iLoc = getSrcLoc dfun, iPrags = [] }
- where
+ where
(tyvars, theta, tau) = splitSigmaTy dfun
(clas, tys) = splitDictTy tau
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 ->
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)
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}
%************************************************************************
-- (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
= 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
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}
-- Getting stuff from the environment
TcEnv, initTcEnv,
tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds, tcEnvTyVars,
+ getTcGST,
-- Instance environment
tcGetInstEnv, tcSetInstEnv,
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
\begin{code}
module TcInstUtil (
InstInfo(..), pprInstInfo,
- simpleInstInfoTy, simpleInstInfoTyCon,
+ simpleInstInfoTy, simpleInstInfoTyCon, simpleDFunClassTyCon,
-- Instance environment
InstEnv, emptyInstEnv, extendInstEnv,
projects / ghc-hetmet.git / commitdiff