# -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.101 2000/10/27 16:30:02 simonmar Exp $
+# $Id: Makefile,v 1.102 2000/10/30 09:52:14 simonpj Exp $
TOP = ..
include $(TOP)/mk/boilerplate.mk
#-----------------------------------------------------------------------------
# Linking
-SRC_LD_OPTS += -no-link-chk -ldl
+SRC_LD_OPTS += -no-link-chk
ifneq "$(GhcWithHscBuiltViaC)" "YES"
ifeq "$(GhcReportCompiles)" "YES"
nameUnique, setNameUnique, setLocalNameSort,
tidyTopName,
- nameOccName, nameModule, setNameOcc, nameRdrName, setNameModuleAndLoc,
+ nameOccName, nameModule, nameModule_maybe,
+ setNameOcc, nameRdrName, setNameModuleAndLoc,
toRdrName, hashName,
isUserExportedName,
import OccName -- All of it
import Module ( Module, moduleName, mkVanillaModule,
printModulePrefix, isModuleInThisPackage )
-import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, rdrNameOcc,
- rdrNameModule )
-import CmdLineOpts ( opt_Static, opt_PprStyle_NoPrags,
- opt_OmitInterfacePragmas, opt_EnsureSplittableC )
-
+import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, rdrNameOcc, rdrNameModule )
+import CmdLineOpts ( opt_Static, opt_OmitInterfacePragmas, opt_EnsureSplittableC )
import SrcLoc ( builtinSrcLoc, noSrcLoc, SrcLoc )
-import Unique ( Unique, Uniquable(..), u2i, pprUnique )
+import Unique ( Unique, Uniquable(..), u2i, pprUnique, pprUnique10 )
import Maybes ( expectJust )
import FastTypes
import UniqFM
nameUnique name = n_uniq name
nameOccName name = n_occ name
nameSrcLoc name = n_loc name
+
nameModule (Name { n_sort = Global mod }) = mod
nameModule name = pprPanic "nameModule" (ppr name)
+
+nameModule_maybe (Name { n_sort = Global mod }) = Just mod
+nameModule_maybe name = Nothing
\end{code}
\begin{code}
\begin{code}
tidyTopName :: Module -> TidyOccEnv -> Name -> (TidyOccEnv, Name)
-tidyTopName mod env name
- = (env', name')
+tidyTopName mod env
+ name@(Name { n_occ = occ, n_sort = sort, n_uniq = uniq, n_loc = loc })
+ = case sort of
+ System -> localise -- System local Ids
+ Local -> localise -- User non-exported Ids
+ Exported -> globalise -- User-exported things
+ Global _ -> no_op -- Constructors, class selectors etc
+
where
- (env', occ') = tidyOccName env (n_occ name)
+ no_op = (env, name)
- name' = Name { n_uniq = n_uniq name, n_sort = mk_top_sort mod,
- n_occ = occ', n_loc = n_loc name }
+ globalise = (env, name { n_sort = Global mod }) -- Don't change occurrence name
-mk_top_sort mod | all_toplev_ids_visible = Global mod
- | otherwise = Local
+ localise = (env', name')
+ (env', occ') = tidyOccName env occ
+ name' | all_toplev_ids_visible = name { n_occ = occ', n_sort = Global mod }
+ | otherwise = name { n_occ = occ' }
all_toplev_ids_visible =
not opt_OmitInterfacePragmas || -- Pragmas can make them visible
pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ})
= getPprStyle $ \ sty ->
- let local | debugStyle sty
- = pprOccName occ <> text "{-" <> pprUnique uniq <> text "-}"
- | codeStyle sty
- = pprUnique uniq
- | otherwise
- = pprOccName occ
-
- global m | codeStyle sty
- = ppr (moduleName m) <> char '_' <> pprOccName occ
- | debugStyle sty || printModulePrefix m
- = ppr (moduleName m) <> dot <> pprOccName occ
- | otherwise
- = pprOccName occ
- in case sort of
- System -> local
- Local -> local
- Exported -> local
- Global mod -> global mod
+ case sort of
+ Global mod -> pprGlobal sty uniq mod occ
+ System -> pprSysLocal sty uniq occ
+ Local -> pprLocal sty uniq occ empty
+ Exported -> pprLocal sty uniq occ (char 'x')
+
+pprLocal sty uniq occ pp_export
+ | codeStyle sty = pprUnique uniq
+ | debugStyle sty = pprOccName occ <>
+ text "{-" <> pp_export <+> pprUnique10 uniq <> text "-}"
+ | otherwise = pprOccName occ
+
+pprGlobal sty uniq mod occ
+ | codeStyle sty = ppr (moduleName mod) <> char '_' <> pprOccName occ
+ | debugStyle sty = ppr (moduleName mod) <> dot <> pprOccName occ <>
+ text "{-" <> pprUnique10 uniq <> text "-}"
+ | printModulePrefix mod = ppr (moduleName mod) <> dot <> pprOccName occ
+ | otherwise = pprOccName occ
+
+pprSysLocal sty uniq occ
+ | codeStyle sty = pprUnique uniq
+ | otherwise = pprOccName occ <> char '_' <> pprUnique uniq
\end{code}
-- so emacs can find the file
ppr (UnhelpfulSrcLoc s) = ptext s
+ ppr NoSrcLoc = ptext SLIT("<No locn>")
\end{code}
tidyTopId mod env@(tidy_env, var_env) env_idinfo id
= -- Top level variables
let
- (tidy_env', name') | exportWithOrigOccName id = (tidy_env, idName id)
- | otherwise = tidyTopName mod tidy_env (idName id)
+ (tidy_env', name') = tidyTopName mod tidy_env (idName id)
ty' = tidyTopType (idType id)
idinfo' = tidyIdInfo env_idinfo (idInfo id)
id' = mkId name' ty' idinfo'
tyClDeclNames (TySynonym name _ _ loc)
= [(name,loc)]
-tyClDeclNames (ClassDecl _ name _ _ sigs _ _ loc)
- = (name,loc) : [(name,loc) | ClassOpSig n _ _ loc <- sigs]
+tyClDeclNames (ClassDecl _ cls_name _ _ sigs _ _ loc)
+ = (cls_name,loc) : [(n,loc) | ClassOpSig n _ _ loc <- sigs]
-tyClDeclNames (TyData _ _ name _ cons _ _ loc _ _)
- = (name,loc) : conDeclsNames cons
+tyClDeclNames (TyData _ _ tc_name _ cons _ _ loc _ _)
+ = (tc_name,loc) : conDeclsNames cons
-tyClDeclNames (IfaceSig _ _ _ _) = []
+tyClDeclNames (IfaceSig name _ _ loc) = [(name,loc)]
type ClassDeclSysNames name = [name]
-- [tycon, datacon wrapper, datacon worker,
\begin{code}
--- caches contents of package directories, never expunged
+-- v_PkgDirCache caches contents of package directories, never expunged
GLOBAL_VAR(v_PkgDirCache, error "no pkg cache!", FiniteMap String (PackageName, FilePath))
--- caches contents of home directories, expunged whenever we
--- create a new finder.
+-- v_HomeDirCache caches contents of home directories,
+-- expunged whenever we create a new finder.
GLOBAL_VAR(v_HomeDirCache, Nothing, Maybe (FiniteMap String FilePath))
initFinder :: PackageConfigInfo -> IO ()
-initFinder pkgs = do
- -- expunge our home cache
- writeIORef v_HomeDirCache Nothing
- -- lazilly fill in the package cache
- writeIORef v_PkgDirCache (unsafePerformIO (newPkgCache pkgs))
- pkg_dbg_info <- readIORef v_PkgDirCache
- putStrLn (unlines (map show (fmToList pkg_dbg_info)))
+initFinder pkgs
+ = do { -- expunge our home cache
+ ; writeIORef v_HomeDirCache Nothing
+ -- lazilly fill in the package cache
+ ; writeIORef v_PkgDirCache (unsafePerformIO (newPkgCache pkgs))
+
+-- Debug output
+-- ; pkg_dbg_info <- readIORef v_PkgDirCache
+-- ; putStrLn (unlines (map show (fmToList pkg_dbg_info)))
+ }
findModule :: ModuleName -> IO (Maybe (Module, ModuleLocation))
-findModule name = do
- hPutStr stderr ("findModule: " ++ moduleNameUserString name ++ " ... ")
- maybe_m <- findModule_wrk name
- case maybe_m of
- Nothing -> hPutStrLn stderr "Not Found"
- Just mm -> hPutStrLn stderr (showSDoc (ppr (snd mm)))
- return maybe_m
-
+findModule name
+ = do { hPutStr stderr ("findModule: " ++ moduleNameUserString name ++ " ... ")
+ ; maybe_m <- findModule_wrk name
+ ; case maybe_m of
+ Nothing -> hPutStrLn stderr "Not Found"
+ Just mm -> hPutStrLn stderr (showSDoc (ppr (snd mm)))
+ ; return maybe_m
+ }
+
findModule_wrk :: ModuleName -> IO (Maybe (Module, ModuleLocation))
-findModule_wrk name = do
- j <- maybeHomeModule name
- case j of
- Just home_module -> return (Just home_module)
- Nothing -> maybePackageModule name
+findModule_wrk name
+ = do { j <- maybeHomeModule name
+ ; case j of
+ Just home_module -> return (Just home_module)
+ Nothing -> maybePackageModule name
+ }
maybeHomeModule :: ModuleName -> IO (Maybe (Module, ModuleLocation))
maybeHomeModule mod_name = do
#include "HsVersions.h"
import Maybe ( isJust )
-import Monad ( when )
-import IO ( hPutStr, hPutStrLn, hClose, stderr,
- openFile, IOMode(..) )
+import IO ( hPutStr, hPutStrLn, stderr )
import HsSyn
-import RdrHsSyn ( RdrNameHsModule )
-import FastString ( unpackFS )
import StringBuffer ( hGetStringBuffer )
import Parser ( parse )
import Lex ( PState(..), ParseResult(..) )
import MkIface ( completeIface, mkModDetailsFromIface, mkModDetails,
writeIface )
import TcModule ( TcResults(..), typecheckModule )
-import TcEnv ( tcEnvTyCons, tcEnvClasses )
import InstEnv ( emptyInstEnv )
import Desugar ( deSugar )
import SimplCore ( core2core )
import CodeGen ( codeGen )
import CodeOutput ( codeOutput )
-import Module ( ModuleName, moduleNameUserString,
- moduleUserString, moduleName, emptyModuleEnv,
- extendModuleEnv )
+import Module ( ModuleName, moduleName, emptyModuleEnv )
import CmdLineOpts
-import ErrUtils ( ghcExit, doIfSet, dumpIfSet_dyn )
+import ErrUtils ( dumpIfSet_dyn )
import UniqSupply ( mkSplitUniqSupply )
import Bag ( emptyBag )
import Outputable
-import Char ( isSpace )
import StgInterp ( stgToInterpSyn )
import HscStats ( ppSourceStats )
import HscTypes ( ModDetails, ModIface(..), PersistentCompilerState(..),
- PersistentRenamerState(..), WhatsImported(..),
- HomeSymbolTable, PackageSymbolTable, ImportVersion,
- GenAvailInfo(..), RdrAvailInfo, OrigNameEnv(..),
- PackageRuleBase, HomeIfaceTable, PackageIfaceTable,
- extendTypeEnv, groupTyThings, TypeEnv, TyThing,
+ PersistentRenamerState(..),
+ HomeSymbolTable, PackageSymbolTable,
+ OrigNameEnv(..), PackageRuleBase, HomeIfaceTable,
+ extendTypeEnv, groupTyThings,
typeEnvClasses, typeEnvTyCons, emptyIfaceTable )
-import RnMonad ( ExportItem, ParsedIface(..) )
-import CmSummarise ( ModSummary(..), name_of_summary, ms_get_imports,
- mimp_name )
+import CmSummarise ( ModSummary(..), ms_get_imports, mimp_name )
import InterpSyn ( UnlinkedIBind )
import StgInterp ( ItblEnv )
import FiniteMap ( FiniteMap, plusFM, emptyFM, addToFM )
-import OccName ( OccName, pprOccName )
-import Name ( Name, nameModule, emptyNameEnv, nameOccName,
- getName, extendNameEnv_C, nameEnvElts )
-import VarEnv ( emptyVarEnv )
-import Module ( Module, mkModuleName, lookupModuleEnvByName )
+import OccName ( OccName )
+import Name ( Name, nameModule, emptyNameEnv, nameOccName, getName )
+import Module ( Module, lookupModuleEnvByName )
\end{code}
let pcs_tc = tc_pcs tc_result
env_tc = tc_env tc_result
- binds_tc = tc_binds tc_result
local_insts = tc_insts tc_result
local_rules = tc_rules tc_result
;
maybe_tc_result
<- typecheckModule dflags this_mod pcs_rn hst hit rn_hs_decls;
case maybe_tc_result of {
- Nothing -> return (HscFail pcs_rn);
+ Nothing -> do { hPutStrLn stderr "Typechecked failed"
+ ; return (HscFail pcs_rn) } ;
Just tc_result -> do {
let pcs_tc = tc_pcs tc_result
env_tc = tc_env tc_result
- binds_tc = tc_binds tc_result
local_insts = tc_insts tc_result
;
-- DESUGAR, SIMPLIFY, TIDY-CORE
-- Just "big" names
-- We keep the Name in the range, so we can print them out
-lookupDeprec :: ModIface -> Name -> Maybe DeprecTxt
-lookupDeprec iface name
- = case mi_deprecs iface of
- NoDeprecs -> Nothing
- DeprecAll txt -> Just txt
- DeprecSome env -> case lookupNameEnv env name of
- Just (_, txt) -> Just txt
- Nothing -> Nothing
+lookupDeprec :: Deprecations -> Name -> Maybe DeprecTxt
+lookupDeprec NoDeprecs name = Nothing
+lookupDeprec (DeprecAll txt) name = Just txt
+lookupDeprec (DeprecSome env) name = case lookupNameEnv env name of
+ Just (_, txt) -> Just txt
+ Nothing -> Nothing
type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class
-----------------------------------------------------------------------------
--- $Id: TmpFiles.hs,v 1.7 2000/10/27 15:11:37 sewardj Exp $
+-- $Id: TmpFiles.hs,v 1.8 2000/10/30 09:52:15 simonpj Exp $
--
-- Temporary file management
--
fs <- readIORef v_FilesToClean
let blowAway f =
- (do when verbose (hPutStrLn stderr ("removing: " ++ f))
+ (do when verbose (hPutStrLn stderr ("Removing: " ++ f))
if '*' `elem` f then system ("rm -f " ++ f) >> return ()
else removeFile f)
`catchAllIO`
(\_ -> when verbose (hPutStrLn stderr
- ("warning: can't remove tmp file" ++ f)))
+ ("Warning: can't remove tmp file " ++ f)))
mapM_ blowAway fs
type Suffix = String
import HsSyn
import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation,
- RdrNameTyClDecl, RdrNameRuleDecl, RdrNameInstDecl
+ RdrNameTyClDecl, RdrNameRuleDecl, RdrNameInstDecl, RdrNameImportDecl
)
import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl,
extractHsTyNames,
RecompileRequired, recompileRequired
)
import RnHiFiles ( findAndReadIface, removeContext, loadExports, loadFixDecls, loadDeprecs )
-import RnEnv ( availName, availsToNameSet,
+import RnEnv ( availName,
emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, groupAvails,
warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules,
lookupOrigNames, lookupGlobalRn, newGlobalName
)
import Module ( Module, ModuleName, WhereFrom(..),
- moduleNameUserString, moduleName,
- lookupModuleEnv
+ moduleNameUserString, moduleName
)
import Name ( Name, isLocallyDefined, NamedThing(..), getSrcLoc,
nameOccName, nameModule,
mkNameEnv, nameEnvElts, extendNameEnv
)
+import RdrName ( elemRdrEnv )
import OccName ( occNameFlavour )
import NameSet
import TysWiredIn ( unitTyCon, intTyCon, boolTyCon )
import PrelNames ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name,
- ioTyCon_RDR,
+ ioTyCon_RDR, main_RDR,
unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR,
eqString_RDR
)
import HscTypes ( PersistentCompilerState, HomeIfaceTable, HomeSymbolTable,
ModIface(..), WhatsImported(..),
VersionInfo(..), ImportVersion, IfaceDecls(..),
- GlobalRdrEnv, AvailEnv, Avails, GenAvailInfo(..), AvailInfo,
+ GlobalRdrEnv, AvailEnv, GenAvailInfo(..), AvailInfo,
Provenance(..), ImportReason(..), initialVersionInfo,
- Deprecations(..), lookupDeprec
+ Deprecations(..), lookupDeprec, lookupTable
)
import List ( partition, nub )
\end{code}
\begin{code}
rename :: Module -> RdrNameHsModule -> RnMG (Maybe (ModIface, [RenamedHsDecl]))
-rename this_module this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec loc)
- = -- FIND THE GLOBAL NAME ENVIRONMENT
- getGlobalNames this_mod `thenRn` \ maybe_stuff ->
+rename this_module contents@(HsModule _ _ _ imports local_decls mod_deprec loc)
+ = pushSrcLocRn loc $
- -- CHECK FOR EARLY EXIT
- case maybe_stuff of {
- Nothing -> -- Everything is up to date; no need to recompile further
- rnDump [] [] `thenRn_`
- returnRn Nothing ;
-
- Just (gbl_env, local_gbl_env, export_avails, global_avail_env) ->
+ -- FIND THE GLOBAL NAME ENVIRONMENT
+ getGlobalNames this_module contents `thenRn` \ (gbl_env, local_gbl_env,
+ export_avails, global_avail_env) ->
+ -- Exit if we've found any errors
+ checkErrsRn `thenRn` \ no_errs_so_far ->
+ if not no_errs_so_far then
+ -- Found errors already, so exit now
+ rnDump [] [] `thenRn_`
+ returnRn Nothing
+ else
+
-- DEAL WITH DEPRECATIONS
rnDeprecs local_gbl_env mod_deprec
[d | DeprecD d <- local_decls] `thenRn` \ my_deprecs ->
rnSourceDecls local_decls
) `thenRn` \ (rn_local_decls, source_fvs) ->
+ -- CHECK THAT main IS DEFINED, IF REQUIRED
+ checkMain this_module local_gbl_env `thenRn_`
+
-- SLURP IN ALL THE NEEDED DECLARATIONS
implicitFVs mod_name rn_local_decls `thenRn` \ implicit_fvs ->
let
getNameSupplyRn `thenRn` \ name_supply ->
getIfacesRn `thenRn` \ ifaces ->
let
- direct_import_mods :: [ModuleName]
- direct_import_mods = nub [m | ImportDecl m _ _ _ _ _ <- imports]
-
-- We record fixities even for things that aren't exported,
-- so that we can change into the context of this moodule easily
fixities = mkNameEnv [ (name, fixity)
-- Sort the exports to make them easier to compare for versions
- my_exports = groupAvails export_avails
+ my_exports = groupAvails this_module export_avails
mod_iface = ModIface { mi_module = this_module,
mi_version = initialVersionInfo,
in
-- REPORT UNUSED NAMES, AND DEBUG DUMP
- reportUnusedNames mod_name direct_import_mods
- gbl_env global_avail_env
- export_avails source_fvs
- rn_imp_decls `thenRn_`
+ reportUnusedNames mod_iface imports global_avail_env
+ real_source_fvs rn_imp_decls `thenRn_`
returnRn (Just (mod_iface, final_decls))
- }
+ where
+ mod_name = moduleName this_module
+\end{code}
+
+Checking that main is defined
+
+\begin{code}
+checkMain :: Module -> GlobalRdrEnv -> RnMG ()
+checkMain this_mod local_env
+ | moduleName this_mod == mAIN_Name
+ = checkRn (main_RDR `elemRdrEnv` local_env) noMainErr
+ | otherwise
+ = returnRn ()
\end{code}
@implicitFVs@ forces the renamer to slurp in some things which aren't
%*********************************************************
\begin{code}
-reportUnusedNames :: ModuleName -> [ModuleName]
- -> GlobalRdrEnv -> AvailEnv
- -> Avails -> NameSet -> [RenamedHsDecl]
+reportUnusedNames :: ModIface -> [RdrNameImportDecl]
+ -> AvailEnv
+ -> NameSet
+ -> [RenamedHsDecl]
-> RnMG ()
-reportUnusedNames mod_name direct_import_mods
- gbl_env avail_env
- export_avails mentioned_names
- imported_decls
+reportUnusedNames my_mod_iface imports avail_env
+ used_names imported_decls
= warnUnusedModules unused_imp_mods `thenRn_`
warnUnusedLocalBinds bad_locals `thenRn_`
warnUnusedImports bad_imp_names `thenRn_`
- printMinimalImports mod_name minimal_imports `thenRn_`
- warnDeprecations really_used_names `thenRn_`
+ printMinimalImports my_mod_iface minimal_imports `thenRn_`
+ warnDeprecations my_mod_iface really_used_names `thenRn_`
returnRn ()
where
- used_names = mentioned_names `unionNameSets` availsToNameSet export_avails
+ gbl_env = mi_globals my_mod_iface
-- Now, a use of C implies a use of T,
-- if C was brought into scope by T(..) or T(C)
| otherwise = addToFM acc m emptyAvailEnv
-- Add an empty collection of imports for a module
-- from which we have sucked only instance decls
-
+
+ direct_import_mods :: [ModuleName]
+ direct_import_mods = nub [m | ImportDecl m _ _ _ _ _ <- imports]
+
-- unused_imp_mods are the directly-imported modules
-- that are not mentioned in minimal_imports
unused_imp_mods = [m | m <- direct_import_mods,
module_unused mod = moduleName mod `elem` unused_imp_mods
-warnDeprecations used_names
+warnDeprecations my_mod_iface used_names
= doptRn Opt_WarnDeprecations `thenRn` \ warn_drs ->
if not warn_drs then returnRn () else
mapRn_ warnDeprec deprecs
where
- lookup_deprec hit pit n
- = case lookupModuleEnv hit mod of
- Just iface -> lookupDeprec iface n
- Nothing -> case lookupModuleEnv pit mod of
- Just iface -> lookupDeprec iface n
- Nothing -> pprPanic "warnDeprecations:" (ppr n)
- where
- mod = nameModule n
+ mod = mi_module my_mod_iface
+ my_deprecs = mi_deprecs my_mod_iface
+ lookup_deprec hit pit n
+ | isLocalThing mod n = lookupDeprec my_deprecs n
+ | otherwise = case lookupTable hit pit n of
+ Just iface -> lookupDeprec (mi_deprecs iface) n
+ Nothing -> pprPanic "warnDeprecations:" (ppr n)
-- ToDo: deal with original imports with 'qualified' and 'as M' clauses
-printMinimalImports mod_name imps
+printMinimalImports my_mod_iface imps
= doptRn Opt_D_dump_minimal_imports `thenRn` \ dump_minimal ->
if not dump_minimal then returnRn () else
}) `thenRn_`
returnRn ()
where
- filename = moduleNameUserString mod_name ++ ".imports"
+ filename = moduleNameUserString (moduleName (mi_module my_mod_iface))
+ ++ ".imports"
ppr_mod_ie (mod_name, ies)
| mod_name == pRELUDE_Name
= empty
badDeprec d
= sep [ptext SLIT("Illegal deprecation when whole module is deprecated"),
nest 4 (ppr d)]
+
+noMainErr
+ = hsep [ptext SLIT("Module"), quotes (ppr mAIN_Name),
+ ptext SLIT("must include a definition for"), quotes (ptext SLIT("main"))]
\end{code}
import Name ( Name, NamedThing(..),
getSrcLoc,
mkLocalName, mkImportedLocalName, mkGlobalName,
- mkIPName, nameOccName, nameModule,
+ mkIPName, nameOccName, nameModule_maybe,
extendNameEnv_C, plusNameEnv_C, nameEnvElts,
setNameModuleAndLoc
)
\begin{code}
newTopBinder :: Module -> RdrName -> SrcLoc -> RnM d Name
+ -- newTopBinder puts into the cache the binder with the
+ -- module information set correctly. When the decl is later renamed,
+ -- the binding site will thereby get the correct module.
+ -- There maybe occurrences that don't have the correct Module, but
+ -- by the typechecker will propagate the binding definition to all
+ -- the occurrences, so that doesn't matter
+
newTopBinder mod rdr_name loc
= -- First check the cache
traceRn (text "newTopBinder" <+> ppr mod <+> ppr loc) `thenRn_`
+ -- There should never be a qualified name in a binding position (except in instance decls)
+ -- The parser doesn't check this because the same parser parses instance decls
+ (if isQual rdr_name then
+ qualNameErr (text "its declaration") (rdr_name,loc)
+ else
+ returnRn ()
+ ) `thenRn_`
+
getNameSupplyRn `thenRn` \ (us, cache, ipcache) ->
let
occ = rdrNameOcc rdr_name
filterAvail ie avail = Nothing
-------------------------------------
-groupAvails :: Avails -> [(ModuleName, Avails)]
+groupAvails :: Module -> Avails -> [(ModuleName, Avails)]
-- Group by module and sort by occurrence
-- This keeps the list in canonical order
-groupAvails avails
+groupAvails this_mod avails
= [ (mkSysModuleNameFS fs, sortLt lt avails)
| (fs,avails) <- fmToList groupFM
]
add env avail = addToFM_C combine env mod_fs [avail]
where
- mod_fs = moduleNameFS (moduleName (nameModule (availName avail)))
+ mod_fs = moduleNameFS (moduleName avail_mod)
+ avail_mod = case nameModule_maybe (availName avail) of
+ Just m -> m
+ Nothing -> this_mod
combine old _ = avail:old
a1 `lt` a2 = occ1 < occ2
Just err -> failWithRn ifaces err
tryLoadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d (Ifaces, Maybe Message)
- -- Returns (Just err) if an error happened
- -- Guarantees to return with iImpModInfo m --> (..., True)
- -- (If the load fails, we plug in a vanilla placeholder)
+ -- Returns (Just err) if an error happened
+ -- It *doesn't* add an error to the monad, because sometimes it's ok to fail...
+ -- Specifically, when we read the usage information from an interface file,
+ -- we try to read the interfaces it mentions. But it's OK to fail; perhaps
+ -- the module has changed, and that interface is no longer used.
+
+ -- tryLoadInterface guarantees to return with iImpModInfo m --> (..., True)
+ -- (If the load fails, we plug in a vanilla placeholder)
tryLoadInterface doc_str mod_name from
= getHomeIfaceTableRn `thenRn` \ hit ->
getIfacesRn `thenRn` \ ifaces ->
= mapRn (load_entity mod) entities `thenRn` \ avails ->
returnRn (mod, avails)
where
- new_name mod occ = newGlobalName mod occ
-
load_entity mod (Avail occ)
- = new_name mod occ `thenRn` \ name ->
+ = newGlobalName mod occ `thenRn` \ name ->
returnRn (Avail name)
load_entity mod (AvailTC occ occs)
- = new_name mod occ `thenRn` \ name ->
- mapRn (new_name mod) occs `thenRn` \ names ->
+ = newGlobalName mod occ `thenRn` \ name ->
+ mapRn (newGlobalName mod) occs `thenRn` \ names ->
returnRn (AvailTC name names)
-> (Version, RdrNameTyClDecl)
-> RnM d (NameEnv Version, DeclsMap)
loadDecl mod (version_map, decls_map) (version, decl)
- = getIfaceDeclBinders new_name decl `thenRn` \ full_avail ->
+ = getIfaceDeclBinders mod decl `thenRn` \ full_avail ->
let
main_name = availName full_avail
new_decls_map = extendNameEnvList decls_map stuff
new_version_map = extendNameEnv version_map main_name version
in
returnRn (new_version_map, new_decls_map)
- where
- -- newTopBinder puts into the cache the binder with the
- -- module information set correctly. When the decl is later renamed,
- -- the binding site will thereby get the correct module.
- -- There maybe occurrences that don't have the correct Module, but
- -- by the typechecker will propagate the binding definition to all
- -- the occurrences, so that doesn't matter
- new_name rdr_name loc = newTopBinder mod rdr_name loc
-
-----------------------------------------------------
-- Loading fixity decls
\begin{code}
getIfaceDeclBinders, getTyClDeclBinders
- :: (RdrName -> SrcLoc -> RnM d Name) -- New-name function
+ :: Module
-> RdrNameTyClDecl
-> RnM d AvailInfo
-getIfaceDeclBinders new_name tycl_decl
- = getTyClDeclBinders new_name tycl_decl `thenRn` \ avail ->
- getSysTyClDeclBinders new_name tycl_decl `thenRn` \ extras ->
+getIfaceDeclBinders mod tycl_decl
+ = getTyClDeclBinders mod tycl_decl `thenRn` \ avail ->
+ getSysTyClDeclBinders mod tycl_decl `thenRn` \ extras ->
returnRn (addSysAvails avail extras)
-- Add the sys-binders to avail. When we import the decl,
-- it's full_avail that will get added to the 'already-slurped' set (iSlurp)
-- If we miss out sys-binders, we'll read the decl multiple times!
-getTyClDeclBinders new_name (IfaceSig var ty prags src_loc)
- = new_name var src_loc `thenRn` \ var_name ->
+getTyClDeclBinders mod (IfaceSig var ty prags src_loc)
+ = newTopBinder mod var src_loc `thenRn` \ var_name ->
returnRn (Avail var_name)
-getTyClDeclBinders new_name tycl_decl
+getTyClDeclBinders mod tycl_decl
= mapRn do_one (tyClDeclNames tycl_decl) `thenRn` \ (main_name:sub_names) ->
returnRn (AvailTC main_name (main_name : sub_names))
where
- do_one (name,loc) = new_name name loc
+ do_one (name,loc) = newTopBinder mod name loc
\end{code}
@getDeclSysBinders@ gets the implicit binders introduced by a decl.
bindings of their own elsewhere.
\begin{code}
-getSysTyClDeclBinders new_name (ClassDecl _ cname _ _ sigs _ names src_loc)
- = sequenceRn [new_name n src_loc | n <- names]
+getSysTyClDeclBinders mod (ClassDecl _ cname _ _ sigs _ names src_loc)
+ = sequenceRn [newTopBinder mod n src_loc | n <- names]
-getSysTyClDeclBinders new_name (TyData _ _ _ _ cons _ _ _ _ _)
- = sequenceRn [new_name wkr_name src_loc | ConDecl _ wkr_name _ _ _ src_loc <- cons]
+getSysTyClDeclBinders mod (TyData _ _ _ _ cons _ _ _ _ _)
+ = sequenceRn [newTopBinder mod wkr_name src_loc | ConDecl _ wkr_name _ _ _ src_loc <- cons]
-getSysTyClDeclBinders new_name other_decl
+getSysTyClDeclBinders mod other_decl
= returnRn []
\end{code}
-- For (a) a library module, we don't record it at all unless it contains orphans
-- (We must never lose track of orphans.)
--
- -- (b) a source-imported module, don't record the dependency at all
- --
- -- (b) may seem a bit strange. The idea is that the usages in a .hi file records
- -- *all* the module's dependencies other than the loop-breakers. We use
- -- this info in findAndReadInterface to decide whether to look for a .hi file or
- -- a .hi-boot file.
- --
- -- This means we won't track version changes, or orphans, from .hi-boot files.
- -- The former is potentially rather bad news. It could be fixed by recording
- -- whether something is a boot file along with the usage info for it, but
- -- I can't be bothered just now.
+ -- (b) a home-package module
mk_imp_info mod_name (has_orphans, is_boot, opened) so_far
| mod_name == this_mod -- Check if M appears in the set of modules 'below' M
go_for_it NothingAtAll
- | is_lib_module && not has_orphans
- = so_far
-
- | is_lib_module -- Record the module version only
- = go_for_it (Everything module_vers)
+ | is_lib_module
+ -- Ignore modules from other packages, unless it has
+ -- orphans, in which case we must remember it in our
+ -- dependencies. But in that case we only record the
+ -- module version, nothing more detailed
+ = if has_orphans then
+ go_for_it (Everything module_vers)
+ else
+ so_far
| otherwise
= go_for_it whats_imported
importDecl name
= -- Check if it was loaded before beginning this module
+ if isLocallyDefined name then
+ returnRn AlreadySlurped
+ else
checkAlreadyAvailable name `thenRn` \ done ->
if done then
returnRn AlreadySlurped
import PrelNames ( pRELUDE_Name, mAIN_Name, main_RDR )
import UniqFM ( lookupUFM )
import Bag ( bagToList )
-import Module ( ModuleName, mkModuleInThisPackage, WhereFrom(..) )
+import Module ( ModuleName, moduleName, WhereFrom(..) )
import NameSet
import Name ( Name, nameSrcLoc,
setLocalNameSort, nameOccName, nameEnvElts )
import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv,
GenAvailInfo(..), AvailInfo, Avails, AvailEnv )
-import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual, isUnqual )
+import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual )
import OccName ( setOccNameSpace, dataName )
import NameSet ( elemNameSet, emptyNameSet )
-import SrcLoc ( SrcLoc )
import Outputable
import Maybes ( maybeToBool, catMaybes, mapMaybe )
import UniqFM ( emptyUFM, listToUFM )
%************************************************************************
\begin{code}
-getGlobalNames :: RdrNameHsModule
- -> RnMG (Maybe (GlobalRdrEnv, -- Maps all in-scope things
- GlobalRdrEnv, -- Maps just *local* things
- Avails, -- The exported stuff
- AvailEnv -- Maps a name to its parent AvailInfo
- -- Just for in-scope things only
- ))
- -- Nothing => no need to recompile
-
-getGlobalNames (HsModule this_mod _ exports imports decls _ mod_loc)
+getGlobalNames :: Module -> RdrNameHsModule
+ -> RnMG (GlobalRdrEnv, -- Maps all in-scope things
+ GlobalRdrEnv, -- Maps just *local* things
+ Avails, -- The exported stuff
+ AvailEnv) -- Maps a name to its parent AvailInfo
+ -- Just for in-scope things only
+
+getGlobalNames this_mod (HsModule _ _ exports imports decls _ mod_loc)
= -- These two fix-loops are to get the right
-- provenance information into a Name
- fixRn ( \ ~(Just (rec_gbl_env, _, rec_export_avails, _)) ->
+ fixRn ( \ ~(rec_gbl_env, _, rec_export_avails, _) ->
let
rec_unqual_fn :: Name -> Bool -- Is this chap in scope unqualified?
-- PROCESS LOCAL DECLS
-- Do these *first* so that the correct provenance gets
-- into the global name cache.
- importsFromLocalDecls this_mod rec_exp_fn decls
- `thenRn` \ (local_gbl_env, local_mod_avails) ->
+ importsFromLocalDecls this_mod rec_exp_fn decls `thenRn` \ (local_gbl_env, local_mod_avails) ->
-- PROCESS IMPORT DECLS
-- Do the non {- SOURCE -} ones first, so that we get a helpful
is_source_import (ImportDecl _ ImportByUserSource _ _ _ _) = True
is_source_import other = False
in
- mapAndUnzipRn (importsFromImportDecl rec_unqual_fn) ordinary
- `thenRn` \ (imp_gbl_envs1, imp_avails_s1) ->
- mapAndUnzipRn (importsFromImportDecl rec_unqual_fn) source
- `thenRn` \ (imp_gbl_envs2, imp_avails_s2) ->
+ mapAndUnzipRn (importsFromImportDecl rec_unqual_fn) ordinary `thenRn` \ (imp_gbl_envs1, imp_avails_s1) ->
+ mapAndUnzipRn (importsFromImportDecl rec_unqual_fn) source `thenRn` \ (imp_gbl_envs2, imp_avails_s2) ->
-- COMBINE RESULTS
-- We put the local env second, so that a local provenance
all_avails :: ExportAvails
all_avails = foldr plusExportAvails local_mod_avails (imp_avails_s2 ++ imp_avails_s1)
+
(_, global_avail_env) = all_avails
in
- -- TRY FOR EARLY EXIT
- -- We can't go for an early exit before this because we have to check
- -- for name clashes. Consider:
- --
- -- module A where module B where
- -- import B h = True
- -- f = h
- --
- -- Suppose I've compiled everything up, and then I add a
- -- new definition to module B, that defines "f".
- --
- -- Then I must detect the name clash in A before going for an early
- -- exit. The early-exit code checks what's actually needed from B
- -- to compile A, and of course that doesn't include B.f. That's
- -- why we wait till after the plusEnv stuff to do the early-exit.
-
- -- Check For early exit
- checkErrsRn `thenRn` \ no_errs_so_far ->
- if not no_errs_so_far then
- -- Found errors already, so exit now
- returnRn Nothing
- else
-
- -- PROCESS EXPORT LISTS
- exportsFromAvail this_mod exports all_avails gbl_env `thenRn` \ export_avails ->
-
+ -- PROCESS EXPORT LIST (but not if we've had errors already)
+ checkErrsRn `thenRn` \ no_errs_so_far ->
+ (if no_errs_so_far then
+ exportsFromAvail this_mod_name exports all_avails gbl_env
+ else
+ returnRn []
+ ) `thenRn` \ export_avails ->
-- ALL DONE
- returnRn (Just (gbl_env, local_gbl_env, export_avails, global_avail_env))
+ returnRn (gbl_env, local_gbl_env, export_avails, global_avail_env)
)
where
+ this_mod_name = moduleName this_mod
all_imports = prel_imports ++ imports
-- NB: opt_NoImplicitPrelude is slightly different to import Prelude ();
-- because the former doesn't even look at Prelude.hi for instance declarations,
-- whereas the latter does.
- prel_imports | this_mod == pRELUDE_Name ||
+ prel_imports | this_mod_name == pRELUDE_Name ||
explicit_prelude_import ||
opt_NoImplicitPrelude
= []
\begin{code}
-importsFromLocalDecls mod_name rec_exp_fn decls
- = mapRn (getLocalDeclBinders (newLocalName mod rec_exp_fn)) decls `thenRn` \ avails_s ->
+importsFromLocalDecls this_mod rec_exp_fn decls
+ = mapRn (getLocalDeclBinders this_mod rec_exp_fn) decls `thenRn` \ avails_s ->
let
avails = concat avails_s
recordLocalSlurps avails `thenRn_`
-- Build the environment
- qualifyImports mod_name
+ qualifyImports (moduleName this_mod)
True -- Want unqualified names
Nothing -- no 'as M'
[] -- Hide nothing
(\n -> LocalDef) -- Provenance is local
avails
- where
- mod = mkModuleInThisPackage mod_name
---------------------------
-getLocalDeclBinders :: (RdrName -> SrcLoc -> RnMG Name)
+getLocalDeclBinders :: Module
+ -> (Name -> Bool) -- Whether exported
-> RdrNameHsDecl -> RnMG Avails
-getLocalDeclBinders new_name (ValD binds)
- = mapRn do_one (bagToList (collectTopBinders binds))
- where
- do_one (rdr_name, loc) = new_name rdr_name loc `thenRn` \ name ->
- returnRn (Avail name)
-
-getLocalDeclBinders new_name (TyClD tycl_decl)
- = getTyClDeclBinders new_name tycl_decl `thenRn` \ avail ->
+getLocalDeclBinders mod rec_exp_fn (TyClD tycl_decl)
+ = -- For type and class decls, we generate Global names, with
+ -- no export indicator. They need to be global because they get
+ -- permanently bound into the TyCons and Classes. They don't need
+ -- an export indicator because they are all implicitly exported.
+ getTyClDeclBinders mod tycl_decl `thenRn` \ avail ->
returnRn [avail]
-getLocalDeclBinders new_name (ForD (ForeignDecl nm kind _ ext_nm _ loc))
+getLocalDeclBinders mod rec_exp_fn (ValD binds)
+ = mapRn (newLocalBinder mod rec_exp_fn)
+ (bagToList (collectTopBinders binds))
+
+getLocalDeclBinders mod rec_exp_fn (ForD (ForeignDecl nm kind _ ext_nm _ loc))
| binds_haskell_name kind
- = new_name nm loc `thenRn` \ name ->
- returnRn [Avail name]
+ = newLocalBinder mod rec_exp_fn (nm, loc) `thenRn` \ avail ->
+ returnRn [avail]
| otherwise -- a foreign export
= lookupOrigName nm `thenRn_`
binds_haskell_name FoLabel = True
binds_haskell_name FoExport = isDynamicExtName ext_nm
-getLocalDeclBinders new_name (FixD _) = returnRn []
-getLocalDeclBinders new_name (DeprecD _) = returnRn []
-getLocalDeclBinders new_name (DefD _) = returnRn []
-getLocalDeclBinders new_name (InstD _) = returnRn []
-getLocalDeclBinders new_name (RuleD _) = returnRn []
-
+getLocalDeclBinders mod rec_exp_fn (FixD _) = returnRn []
+getLocalDeclBinders mod rec_exp_fn (DeprecD _) = returnRn []
+getLocalDeclBinders mod rec_exp_fn (DefD _) = returnRn []
+getLocalDeclBinders mod rec_exp_fn (InstD _) = returnRn []
+getLocalDeclBinders mod rec_exp_fn (RuleD _) = returnRn []
---------------------------
-newLocalName mod rec_exp_fn rdr_name loc
- = check_unqual rdr_name loc `thenRn_`
+newLocalBinder mod rec_exp_fn (rdr_name, loc)
+ = -- Generate a local name, and with a suitable export indicator
newTopBinder mod rdr_name loc `thenRn` \ name ->
- returnRn (setLocalNameSort name (rec_exp_fn name))
- where
- -- There should never be a qualified name in a binding position (except in instance decls)
- -- The parser doesn't check this because the same parser parses instance decls
- check_unqual rdr_name loc
- | isUnqual rdr_name = returnRn ()
- | otherwise = qualNameErr (text "the binding for" <+> quotes (ppr rdr_name))
- (rdr_name,loc)
+ returnRn (Avail (setLocalNameSort name (rec_exp_fn name)))
\end{code}
returnRn (ClassDecl context cname tyvars fds sigs mbinds' names src_loc, meth_fvs)
where
meth_doc = text "the default-methods for class" <+> ppr cname
+
+rnClassBinds _ tycl_decl = returnRn (tycl_decl, emptyFVs)
+ -- Not a class declaration
\end{code}
-- which is just waht check_one_sig looks for
mapTc check_one_sig sigs `thenTc_`
mapTc check_main_ctxt sigs `thenTc_`
-
- returnTc (Just ([], emptyLIE))
+ returnTc (Just ([], emptyLIE))
| not (null sigs)
= mapTc check_one_sig sigs `thenTc_`
newLocalId, newSpecPragmaId,
newDefaultMethodName, newDFunName,
- -- ???
- tcSetEnv, explicitLookupId
+ -- Misc
+ isLocalThing, tcSetEnv, explicitLookupId
) where
#include "HsVersions.h"
import TcType ( TcKind, TcType, TcTyVar, TcTyVarSet, TcThetaType,
tcInstTyVars, zonkTcTyVars,
)
-import Id ( idName, mkUserLocal, isDataConWrapId_maybe )
+import Id ( mkUserLocal, isDataConWrapId_maybe )
import IdInfo ( vanillaIdInfo )
import MkId ( mkSpecPragmaId )
import Var ( TyVar, Id, idType, lazySetIdInfo, idInfo )
import Subst ( substTy )
import Name ( Name, OccName, NamedThing(..),
nameOccName, nameModule, getSrcLoc, mkGlobalName,
- isLocallyDefined, nameModule,
+ isLocallyDefined, nameModule_maybe,
NameEnv, lookupNameEnv, nameEnvElts,
extendNameEnvList, emptyNameEnv
)
loc)
\end{code}
+\begin{code}
+isLocalThing :: NamedThing a => Module -> a -> Bool
+ -- True if the thing has a Local name,
+ -- or a Global name from the specified module
+isLocalThing mod thing = case nameModule_maybe (getName thing) of
+ Nothing -> True -- A local name
+ Just m -> m == mod -- A global thing
+\end{code}
%************************************************************************
%* *
= tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_thing ->
case maybe_thing of
Just thing -> returnNF_Tc thing
- other -> notFound "tcLookupGlobal:" name
+ other -> notFound "tcLookupGlobal" name
tcLookupGlobalId :: Name -> NF_TcM Id
tcLookupGlobalId name
= tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id ->
case maybe_id of
Just (AnId clas) -> returnNF_Tc clas
- other -> notFound "tcLookupGlobalId:" name
+ other -> notFound "tcLookupGlobalId" name
tcLookupDataCon :: Name -> TcM DataCon
tcLookupDataCon con_name
= tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_clas ->
case maybe_clas of
Just (AClass clas) -> returnNF_Tc clas
- other -> notFound "tcLookupClass:" name
+ other -> notFound "tcLookupClass" name
tcLookupTyCon :: Name -> NF_TcM TyCon
tcLookupTyCon name
= tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_tc ->
case maybe_tc of
Just (ATyCon tc) -> returnNF_Tc tc
- other -> notFound "tcLookupTyCon:" name
+ other -> notFound "tcLookupTyCon" name
\end{code}
= tcLookup_maybe name `thenNF_Tc` \ maybe_thing ->
case maybe_thing of
Just thing -> returnNF_Tc thing
- other -> notFound "tcLookup:" name
+ other -> notFound "tcLookup" name
-- Extract the IdInfo from an IfaceSig imported from an interface file
\end{code}
Just (tycon, _) -> tycon
isLocalInst :: Module -> InstInfo -> Bool
-isLocalInst mod info = mod == nameModule (idName (iDFunId info))
+isLocalInst mod info = isLocalThing mod (iDFunId info)
\end{code}
import TcBinds ( tcTopBinds )
import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds )
import TcDefaults ( tcDefaults )
-import TcEnv ( TcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv, tcLookupGlobal_maybe,
- tcEnvTyCons, tcEnvClasses,
+import TcEnv ( TcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv,
+ tcEnvTyCons, tcEnvClasses, isLocalThing,
tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv
)
import TcRules ( tcRules )
import Bag ( isEmptyBag )
import ErrUtils ( printErrorsAndWarnings, dumpIfSet_dyn )
import Id ( idType, idName, idUnfolding )
-import Module ( Module, moduleName, plusModuleEnv )
-import Name ( Name, nameOccName, isLocallyDefined, isGlobalName,
- toRdrName, nameEnvElts, emptyNameEnv, lookupNameEnv
+import Module ( Module, plusModuleEnv )
+import Name ( Name, nameOccName, isLocallyDefined, isGlobalName, getName,
+ toRdrName, nameEnvElts, lookupNameEnv, mkNameEnv
)
import TyCon ( tyConGenInfo, isClassTyCon )
import OccName ( isSysOcc )
-import PrelNames ( mAIN_Name, mainName )
import Maybes ( thenMaybe )
import Util
import BasicTypes ( EP(..), Fixity )
PackageSymbolTable, DFunId, ModIface(..),
TypeEnv, extendTypeEnv, lookupTable,
TyThing(..), groupTyThings )
-import FiniteMap ( FiniteMap, delFromFM, lookupWithDefaultFM )
+import List ( partition )
\end{code}
Outside-world interface:
typecheckModule dflags this_mod pcs hst hit decls
= do env <- initTcEnv global_symbol_table
- (maybe_result, (errs,warns)) <- initTc dflags env tc_module
+ (maybe_result, (warns,errs)) <- initTc dflags env tc_module
let { maybe_tc_result :: Maybe TcResults ;
maybe_tc_result = case maybe_result of
printTcDump dflags maybe_tc_result
if isEmptyBag errs then
- return Nothing
- else
return maybe_tc_result
+ else
+ return Nothing
where
global_symbol_table = pcs_PST pcs `plusModuleEnv` hst
in
tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds ->
- -- Check that Main defines main
- checkMain this_mod `thenTc_`
-
-- Backsubstitution. This must be done last.
-- Even tcSimplifyTop may do some unification.
let
zonkRules local_rules `thenNF_Tc` \ local_rules' ->
- let groups :: FiniteMap Module TypeEnv
- groups = groupTyThings (nameEnvElts (getTcGEnv final_env))
-
+ let (local_things, imported_things) = partition (isLocalThing this_mod)
+ (nameEnvElts (getTcGEnv final_env))
+
local_type_env :: TypeEnv
- local_type_env = lookupWithDefaultFM groups emptyNameEnv this_mod
+ local_type_env = mkNameEnv [(getName thing, thing) | thing <- local_things]
new_pst :: PackageSymbolTable
- new_pst = extendTypeEnv (pcs_PST pcs) (delFromFM groups this_mod)
+ new_pst = extendTypeEnv (pcs_PST pcs) (groupTyThings imported_things)
final_pcs :: PersistentCompilerState
final_pcs = pcs { pcs_PST = new_pst,
\end{code}
-\begin{code}
-checkMain :: Module -> TcM ()
-checkMain this_mod
- | moduleName this_mod == mAIN_Name
- = tcLookupGlobal_maybe mainName `thenNF_Tc` \ maybe_main ->
- case maybe_main of
- Just (AnId _) -> returnTc ()
- other -> addErrTc noMainErr
-
- | otherwise = returnTc ()
-
-noMainErr
- = hsep [ptext SLIT("Module"), quotes (ppr mAIN_Name),
- ptext SLIT("must include a definition for"), quotes (ptext SLIT("main"))]
-\end{code}
-
%************************************************************************
%* *
initTc :: DynFlags
-> TcEnv
-> TcM r
- -> IO (Maybe r, (Bag ErrMsg, Bag WarnMsg))
+ -> IO (Maybe r, (Bag WarnMsg, Bag ErrMsg))
initTc dflags tc_env do_this
= do {
import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar )
import TcMonoType ( kcHsSigType, tcHsSigType, tcTyVars, checkSigTyVars )
import TcExpr ( tcExpr )
-import TcEnv ( tcExtendLocalValEnv, tcExtendTyVarEnv )
+import TcEnv ( tcExtendLocalValEnv, tcExtendTyVarEnv, isLocalThing )
import Rules ( extendRuleBase )
import Inst ( LIE, emptyLIE, plusLIEs, instToId )
import Id ( idType, idName, mkVanillaId )
-import Name ( nameModule )
import Module ( Module )
import VarSet
import Type ( tyVarsOfTypes, openTypeKind )
-- When relinking this module from its interface-file decls
-- we'll have IfaceRules that are in fact local to this module
- is_local (IfaceRuleOut n _) = mod == nameModule (idName n)
+ is_local (IfaceRuleOut n _) = isLocalThing mod n
is_local other = True
tcRule :: RenamedRuleDecl -> TcM (LIE, TypecheckedRuleDecl)
import BasicTypes ( RecFlag(..), NewOrData(..) )
import TcMonad
-import TcEnv ( TcEnv, TyThing(..), TyThingDetails(..),
- tcExtendKindEnv, tcLookupGlobal, tcExtendGlobalEnv )
+import TcEnv ( TcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..),
+ tcExtendKindEnv, tcLookup, tcExtendGlobalEnv )
import TcTyDecls ( tcTyDecl1, kcConDetails, mkNewTyConRep )
import TcClassDcl ( tcClassDecl1 )
import TcMonoType ( kcHsTyVars, kcHsType, kcHsBoxedSigType, kcHsContext, mkTyClTyVars )
-- the kind of the tycon/class. Give it to the thing inside, and
-- check the result kind matches
kcTyClDeclBody tc_name hs_tyvars thing_inside
- = tcLookupGlobal tc_name `thenNF_Tc` \ thing ->
+ = tcLookup tc_name `thenNF_Tc` \ thing ->
let
kind = case thing of
- ATyCon tc -> tyConKind tc
- AClass cl -> tyConKind (classTyCon cl)
+ AGlobal (ATyCon tc) -> tyConKind tc
+ AGlobal (AClass cl) -> tyConKind (classTyCon cl)
+ AThing kind -> kind
-- For some odd reason, a class doesn't include its kind
(tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames hs_tyvars) kind
TauType, RhoType, SigmaType, PredType(..), ThetaType,
ClassPred, ClassContext, mkClassPred,
- getClassTys_maybe, ipName_maybe, classesToPreds, classesOfPreds,
+ getClassTys_maybe, ipName_maybe, classesOfPreds,
isTauTy, mkRhoTy, splitRhoTy,
mkSigmaTy, isSigmaTy, splitSigmaTy,
getDFunTyKey,
ipName_maybe (IParam n _) = Just n
ipName_maybe _ = Nothing
-classesToPreds :: ClassContext -> ThetaType
-classesToPreds cts = map (uncurry Class) cts
-
classesOfPreds :: ThetaType -> ClassContext
classesOfPreds theta = [(clas,tys) | Class clas tys <- theta]
\end{code}
projects / ghc-hetmet.git / commitdiff