import CmLink
import CmTypes
+import CmStaticInfo ( GhciMode(..) )
+import DriverPipeline
+import DriverFlags ( getDynFlags )
+import DriverPhases
+import DriverUtil
+import Finder
+import HscMain ( initPersistentCompilerState )
import HscTypes
import RnEnv ( unQualInScope )
import Id ( idType, idName )
-import Name ( Name, NamedThing(..) )
+import Name ( Name, NamedThing(..), nameRdrName )
import NameEnv
-import RdrName ( emptyRdrEnv )
-import Module ( Module, ModuleName, moduleName, isHomeModule,
- mkModuleName, moduleNameUserString, moduleUserString )
-import CmStaticInfo ( GhciMode(..) )
-import DriverPipeline
+import RdrName ( lookupRdrEnv, emptyRdrEnv )
+import Module
import GetImports
import Type ( tidyType )
import VarEnv ( emptyTidyEnv )
-import HscTypes
-import HscMain ( initPersistentCompilerState )
-import Finder
import UniqFM
import Unique ( Uniquable )
import Digraph ( SCC(..), stronglyConnComp, flattenSCC )
-import DriverFlags ( getDynFlags )
-import DriverPhases
-import DriverUtil ( splitFilename3 )
import ErrUtils ( showPass )
import Util
-import DriverUtil
import TmpFiles
import Outputable
import Panic
import Exception ( throwDyn )
-- std
-import Time ( ClockTime )
import Directory ( getModificationTime, doesFileExist )
import IO
import Monad
Nothing -> do
mod <- moduleNameToModule mn
if isHomeModule mod
- then throwDyn (OtherError (showSDoc
+ then throwDyn (CmdLineError (showSDoc
(quotes (ppr (moduleName mod))
<+> text "is not currently loaded")))
else return mod
moduleNameToModule mn
= do maybe_stuff <- findModule mn
case maybe_stuff of
- Nothing -> throwDyn (OtherError ("can't find module `"
+ Nothing -> throwDyn (CmdLineError ("can't find module `"
++ moduleNameUserString mn ++ "'"))
Just (m,_) -> return m
-- update the interactive context
let
- new_rn_env = extendLocalRdrEnv rn_env (map idName ids)
+ names = map idName ids
- -- Extend the renamer-env from bound_ids, not
- -- bound_names, because the latter may contain
- -- [it] when the former is empty
- new_type_env = extendNameEnvList type_env
+ -- these names have just been shadowed
+ shadowed = [ n | r <- map nameRdrName names,
+ Just n <- [lookupRdrEnv rn_env r] ]
+
+ new_rn_env = extendLocalRdrEnv rn_env names
+
+ -- remove any shadowed bindings from the type_env
+ filtered_type_env = delListFromNameEnv type_env shadowed
+
+ new_type_env = extendNameEnvList filtered_type_env
[ (getName id, AnId id) | id <- ids]
new_ic = icontext { ic_rn_env = new_rn_env,
let thing_to_run = unsafeCoerce# hval :: IO [HValue]
hvals <- thing_to_run
- -- get the newly bound things, and bind them
- let names = map idName ids
- new_pls <- updateClosureEnv pls (zip names hvals)
+ -- Get the newly bound things, and bind them. Don't forget
+ -- to delete any shadowed bindings from the closure_env, lest
+ -- we end up with a space leak.
+ pls <- delListFromClosureEnv pls shadowed
+ new_pls <- addListToClosureEnv pls (zip names hvals)
return (cmstate{ pcs=new_pcs, pls=new_pls, ic=new_ic }, names)
where
Just l | not (isObjectLinkable l) || stillThere l
-> old_linkable
-- ToDo: emit a warning if not (stillThere l)
- | otherwise
- -> Nothing
+ other -> Nothing
-- make sure that if we had an old disk linkable around, that it's
-- still there on the disk (in case we need to re-link it).
| otherwise = maybeToList maybe_old_linkable
-- only linkables newer than the source code are valid
- maybe_src_date = ms_hs_date summary
+ src_date = ms_hs_date summary
valid_linkable
- = case maybe_src_date of
- Nothing -> panic "valid_linkable_list"
- Just src_date
- -> filter (\l -> linkableTime l > src_date) linkable
+ = filter (\l -> linkableTime l > src_date) linkable
return (valid_linkable ++ new_linkables)
downwards_closure_of_module :: [ModSummary] -> ModuleName -> [ModuleName]
downwards_closure_of_module summaries root
= let toEdge :: ModSummary -> (ModuleName,[ModuleName])
- toEdge summ = (name_of_summary summ, ms_allimps summ)
- res = simple_transitive_closure (map toEdge summaries) [root]
+ toEdge summ = (name_of_summary summ,
+ filter (`elem` all_mods) (ms_allimps summ))
+
+ all_mods = map name_of_summary summaries
+
+ res = simple_transitive_closure (map toEdge summaries) [root]
in
--trace (showSDoc (text "DC of mod" <+> ppr root
-- <+> text "=" <+> ppr res)) (
rootSummaries
all_summaries
<- loop (concat (map ms_imps rootSummaries))
- (filter (isHomeModule.ms_mod) rootSummaries)
+ (mkModuleEnv [ (mod, s) | s <- rootSummaries,
+ let mod = ms_mod s, isHomeModule mod
+ ])
return (all_summaries, a_root_is_Main)
where
getRootSummary :: FilePath -> IO ModSummary
| haskellish_file file
= do exists <- doesFileExist file
if exists then summariseFile file else do
- throwDyn (OtherError ("can't find file `" ++ file ++ "'"))
+ throwDyn (CmdLineError ("can't find file `" ++ file ++ "'"))
| otherwise
= do exists <- doesFileExist hs_file
if exists then summariseFile hs_file else do
exists <- doesFileExist lhs_file
if exists then summariseFile lhs_file else do
- getSummary (mkModuleName file)
+ let mod_name = mkModuleName file
+ maybe_summary <- getSummary mod_name
+ case maybe_summary of
+ Nothing -> packageModErr mod_name
+ Just s -> return s
where
hs_file = file ++ ".hs"
lhs_file = file ++ ".lhs"
- getSummary :: ModuleName -> IO ModSummary
+ getSummary :: ModuleName -> IO (Maybe ModSummary)
getSummary nm
= do found <- findModule nm
case found of
Just (mod, location) -> do
let old_summary = findModInSummaries old_summaries mod
- new_summary <- summarise mod location old_summary
- case new_summary of
- Nothing -> return (fromJust old_summary)
- Just s -> return s
+ summarise mod location old_summary
- Nothing -> throwDyn (OtherError
+ Nothing -> throwDyn (CmdLineError
("can't find module `"
++ showSDoc (ppr nm) ++ "'"))
-
- -- loop invariant: home_summaries doesn't contain package modules
- loop :: [ModuleName] -> [ModSummary] -> IO [ModSummary]
- loop [] home_summaries = return home_summaries
- loop imps home_summaries
- = do -- all modules currently in homeSummaries
- let all_home = map (moduleName.ms_mod) home_summaries
- -- imports for modules we don't already have
- let needed_imps = nub (filter (`notElem` all_home) imps)
+ -- loop invariant: env doesn't contain package modules
+ loop :: [ModuleName] -> ModuleEnv ModSummary -> IO [ModSummary]
+ loop [] env = return (moduleEnvElts env)
+ loop imps env
+ = do -- imports for modules we don't already have
+ let needed_imps = nub (filter (not . (`elemUFM` env)) imps)
-- summarise them
needed_summaries <- mapM getSummary needed_imps
-- get just the "home" modules
- let new_home_summaries
- = filter (isHomeModule.ms_mod) needed_summaries
+ let new_home_summaries = [ s | Just s <- needed_summaries ]
-- loop, checking the new imports
let new_imps = concat (map ms_imps new_home_summaries)
- loop new_imps (new_home_summaries ++ home_summaries)
+ loop new_imps (extendModuleEnvList env
+ [ (ms_mod s, s) | s <- new_home_summaries ])
-----------------------------------------------------------------------------
-- Summarising modules
summariseFile :: FilePath -> IO ModSummary
summariseFile file
= do hspp_fn <- preprocess file
- modsrc <- readFile hspp_fn
+ (srcimps,imps,mod_name) <- getImportsFromFile hspp_fn
- let (srcimps,imps,mod_name) = getImports modsrc
- (path, basename, ext) = splitFilename3 file
+ let (path, basename, ext) = splitFilename3 file
Just (mod, location)
<- mkHomeModuleLocn mod_name (path ++ '/':basename) file
-
- maybe_src_timestamp
+
+ src_timestamp
<- case ml_hs_file location of
- Nothing -> return Nothing
- Just src_fn -> maybe_getModificationTime src_fn
+ Nothing -> noHsFileErr mod_name
+ Just src_fn -> getModificationTime src_fn
return (ModSummary mod
location{ml_hspp_file=Just hspp_fn}
- srcimps imps
- maybe_src_timestamp)
+ srcimps imps src_timestamp)
-- Summarise a module, and pick up source and timestamp.
-summarise :: Module -> ModuleLocation -> Maybe ModSummary
- -> IO (Maybe ModSummary)
+summarise :: Module -> ModuleLocation -> Maybe ModSummary
+ -> IO (Maybe ModSummary)
summarise mod location old_summary
| isHomeModule mod
= do let hs_fn = unJust "summarise" (ml_hs_file location)
- maybe_src_timestamp
+ src_timestamp
<- case ml_hs_file location of
- Nothing -> return Nothing
- Just src_fn -> maybe_getModificationTime src_fn
+ Nothing -> noHsFileErr mod
+ Just src_fn -> getModificationTime src_fn
-- return the cached summary if the source didn't change
case old_summary of {
- Just s | ms_hs_date s == maybe_src_timestamp -> return Nothing;
+ Just s | ms_hs_date s == src_timestamp -> return (Just s);
_ -> do
hspp_fn <- preprocess hs_fn
- modsrc <- readFile hspp_fn
- let (srcimps,imps,mod_name) = getImports modsrc
-
- maybe_src_timestamp
- <- case ml_hs_file location of
- Nothing -> return Nothing
- Just src_fn -> maybe_getModificationTime src_fn
+ (srcimps,imps,mod_name) <- getImportsFromFile hspp_fn
when (mod_name /= moduleName mod) $
- throwDyn (OtherError
- (showSDoc (text "file name does not match module name: "
- <+> ppr (moduleName mod) <+> text "vs"
- <+> ppr mod_name)))
+ throwDyn (ProgramError
+ (showSDoc (text hs_fn
+ <> text ": file name does not match module name"
+ <+> quotes (ppr (moduleName mod)))))
return (Just (ModSummary mod location{ml_hspp_file=Just hspp_fn}
- srcimps imps
- maybe_src_timestamp))
+ srcimps imps src_timestamp))
}
- | otherwise
- = return (Just (ModSummary mod location [] [] Nothing))
+ | otherwise = return Nothing
+
+noHsFileErr mod
+ = panic (showSDoc (text "no source file for module" <+> quotes (ppr mod)))
-maybe_getModificationTime :: FilePath -> IO (Maybe ClockTime)
-maybe_getModificationTime fn
- = (do time <- getModificationTime fn
- return (Just time))
- `catch`
- (\err -> return Nothing)
+packageModErr mod
+ = throwDyn (CmdLineError (showSDoc (text "module" <+>
+ quotes (ppr mod) <+>
+ text "is a package module")))
\end{code}
projects / ghc-hetmet.git / blobdiff