cmInit, -- :: GhciMode -> IO CmState
cmDepAnal, -- :: CmState -> [FilePath] -> IO ModuleGraph
+ cmDownsweep,
cmTopSort, -- :: Bool -> ModuleGraph -> [SCC ModSummary]
cyclicModuleErr, -- :: [ModSummary] -> String -- Used by DriverMkDepend
import HscMain ( newHscEnv )
import DriverState ( v_Output_file, v_NoHsMain, v_MainModIs )
import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, isHaskellSrcFilename )
-import Finder ( findModule, findLinkable, addHomeModuleToFinder, flushFinderCache,
- mkHomeModLocation, FindResult(..), cantFindError )
+import Finder ( findModule, findLinkable, addHomeModuleToFinder,
+ flushFinderCache, mkHomeModLocation, FindResult(..), cantFindError )
import HscTypes ( ModSummary(..), HomeModInfo(..), ModIface(..), msHsFilePath,
HscEnv(..), GhciMode(..),
InteractiveContext(..), emptyInteractiveContext,
import DATA_IOREF ( readIORef )
#ifdef GHCI
+import Finder ( findPackageModule )
import HscMain ( hscGetInfo, GetInfoResult, hscStmt, hscTcExpr, hscKcType )
import HscTypes ( TyThing(..), icPrintUnqual, showModMsg )
import TcRnDriver ( mkExportEnv, getModuleContents )
import Name ( Name )
import NameEnv
import Id ( idType )
-import Type ( tidyType )
+import Type ( tidyType, dropForAlls )
import VarEnv ( emptyTidyEnv )
import Linker ( HValue, unload, extendLinkEnv )
import GHC.Exts ( unsafeCoerce# )
import Foreign
import Control.Exception as Exception ( Exception, try )
-import CmdLineOpts ( DynFlag(..), dopt_unset )
+import CmdLineOpts ( DynFlag(..), dopt_unset, dopt )
#endif
import EXCEPTION ( throwDyn )
hsc_env = cm_hsc cmstate
hpt = hsc_HPT hsc_env
- export_env <- mkExportEnv hsc_env (map mkModule exports)
+ let export_mods = map mkModule exports
+ mapM_ (checkModuleExists (hsc_dflags hsc_env) hpt) export_mods
+ export_env <- mkExportEnv hsc_env export_mods
toplev_envs <- mapM (mkTopLevEnv hpt) toplevs
let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
ic_exports = exports,
ic_rn_gbl_env = all_env } }
+checkModuleExists :: DynFlags -> HomePackageTable -> Module -> IO ()
+checkModuleExists dflags hpt mod =
+ case lookupModuleEnv hpt mod of
+ Just mod_info -> return ()
+ _not_a_home_module -> do
+ res <- findPackageModule dflags mod True
+ case res of
+ Found _ _ -> return ()
+ err -> let msg = cantFindError dflags mod err in
+ throwDyn (CmdLineError (showSDoc msg))
+
mkTopLevEnv :: HomePackageTable -> String -> IO GlobalRdrEnv
mkTopLevEnv hpt mod
= case lookupModuleEnv hpt (mkModule mod) of
Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++ mod))
- Just details -> case hm_globals details of
+ Just details -> case mi_globals (hm_iface details) of
Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not interpreted " ++ mod))
Just env -> return env
cmModuleIsInterpreted :: CmState -> String -> IO Bool
cmModuleIsInterpreted cmstate str
= case lookupModuleEnv (cmHPT cmstate) (mkModule str) of
- Just details -> return (isJust (hm_globals details))
+ Just details -> return (isJust (mi_globals (hm_iface details)))
_not_a_home_module -> return False
-----------------------------------------------------------------------------
case maybe_stuff of
Nothing -> return Nothing
- Just ty -> return (Just res_str)
+ Just ty -> return (Just (showSDocForUser unqual doc))
where
- res_str = showSDocForUser unqual (text expr <+> dcolon <+> ppr tidy_ty)
+ doc = text expr <+> dcolon <+> ppr final_ty
unqual = icPrintUnqual (cm_ic cmstate)
tidy_ty = tidyType emptyTidyEnv ty
-
+ dflags = hsc_dflags (cm_hsc cmstate)
+ -- if -fglasgow-exts is on we show the foralls, otherwise
+ -- we don't.
+ final_ty
+ | dopt Opt_GlasgowExts dflags = tidy_ty
+ | otherwise = dropForAlls tidy_ty
-----------------------------------------------------------------------------
-- cmKindOfType: returns a string representing the kind of a type
hPutStrLn stderr (showSDoc (hcat [
text "Chasing modules from: ",
hcat (punctuate comma (map text rootnames))]))
- downsweep dflags rootnames (cm_mg cmstate)
+ cmDownsweep dflags rootnames (cm_mg cmstate) []
where
hsc_env = cm_hsc cmstate
dflags = hsc_dflags hsc_env
-- Compilation "succeeded", and may or may not have returned a new
-- linkable (depending on whether compilation was actually performed
-- or not).
- CompOK new_details new_globals new_iface maybe_new_linkable
+ CompOK new_details new_iface maybe_new_linkable
-> do let
new_linkable = maybe_new_linkable `orElse` old_linkable
new_info = HomeModInfo { hm_iface = new_iface,
- hm_globals = new_globals,
hm_details = new_details,
hm_linkable = new_linkable }
return (Just new_info)
-- We pass in the previous collection of summaries, which is used as a
-- cache to avoid recalculating a module summary if the source is
-- unchanged.
-
-downsweep :: DynFlags -> [FilePath] -> [ModSummary] -> IO [ModSummary]
-downsweep dflags roots old_summaries
+--
+-- The returned list of [ModSummary] nodes has one node for each home-package
+-- module. The imports of these nodes are all there, including the imports
+-- of non-home-package modules.
+
+cmDownsweep :: DynFlags
+ -> [FilePath] -- Roots
+ -> [ModSummary] -- Old summaries
+ -> [Module] -- Ignore dependencies on these; treat them as
+ -- if they were package modules
+ -> IO [ModSummary]
+cmDownsweep dflags roots old_summaries excl_mods
= do rootSummaries <- mapM getRootSummary roots
checkDuplicates rootSummaries
loop (concatMap msImports rootSummaries)
exists <- doesFileExist lhs_file
if exists then summariseFile dflags lhs_file else do
let mod_name = mkModule file
- maybe_summary <- summarise dflags emptyNodeMap Nothing False mod_name
+ maybe_summary <- summarise dflags emptyNodeMap Nothing False
+ mod_name excl_mods
case maybe_summary of
Nothing -> packageModErr mod_name
Just s -> return s
loop ((cur_path, wanted_mod, is_boot) : ss) done
| key `elemFM` done = loop ss done
| otherwise = do { mb_s <- summarise dflags old_summary_map
- (Just cur_path) is_boot wanted_mod
+ (Just cur_path) is_boot
+ wanted_mod excl_mods
; case mb_s of
Nothing -> loop ss done
Just s -> loop (msImports s ++ ss)
-- to findModule will find it, even if it's not on any search path
addHomeModuleToFinder mod location
- src_timestamp
- <- case ml_hs_file location of
- Nothing -> noHsFileErr Nothing mod
- Just src_fn -> getModificationTime src_fn
-
+ src_timestamp <- getModificationTime file
return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
ms_location = location,
ms_hspp_file = Just hspp_fn,
-> Maybe FilePath -- Importing module (for error messages)
-> IsBootInterface -- True <=> a {-# SOURCE #-} import
-> Module -- Imported module to be summarised
+ -> [Module] -- Modules to exclude
-> IO (Maybe ModSummary) -- Its new summary
-summarise dflags old_summary_map cur_mod is_boot wanted_mod
+summarise dflags old_summary_map cur_mod is_boot wanted_mod excl_mods
+ | wanted_mod `elem` excl_mods
+ = return Nothing
+
+ | Just old_summary <- lookupFM old_summary_map (wanted_mod, hsc_src)
+ = do { -- Find its new timestamp; all the
+ -- ModSummaries in the old map have valid ml_hs_files
+ let location = ms_location old_summary
+ src_fn = fromJust (ml_hs_file location)
+
+ ; src_timestamp <- getModificationTime src_fn
+
+ -- return the cached summary if the source didn't change
+ ; if ms_hs_date old_summary == src_timestamp
+ then return (Just old_summary)
+ else new_summary location
+ }
+
+ | otherwise
= do { found <- findModule dflags wanted_mod True {-explicit-}
; case found of
Found location pkg
- | isHomePackage pkg
- -> do { summary <- do_summary location
- ; return (Just summary) }
- | otherwise
- -> return Nothing -- Drop an external-package modules
-
- err -> noModError dflags cur_mod wanted_mod err
+ | not (isHomePackage pkg) -> return Nothing -- Drop external-pkg
+ | isJust (ml_hs_file location) -> new_summary location -- Home package
+ err -> noModError dflags cur_mod wanted_mod err -- Not found
}
where
hsc_src = if is_boot then HsBootFile else HsSrcFile
- do_summary location
+ new_summary location
= do { -- Adjust location to point to the hs-boot source file,
-- hi file, object file, when is_boot says so
- let location' | is_boot = addBootSuffixLocn location
- | otherwise = location
-
- -- Find the source file to summarise
- ; src_fn <- case ml_hs_file location' of
- Nothing -> noHsFileErr cur_mod wanted_mod
- Just src_fn -> return src_fn
-
- -- In the case of hs-boot files, check that it exists
- -- The Finder was dealing only with the main source file
- ; if is_boot then do
- { exists <- doesFileExist src_fn
- ; if exists then return ()
- else noHsBootFileErr cur_mod src_fn }
- else return ()
-
- -- Find its timestamp
- ; src_timestamp <- getModificationTime src_fn
-
- -- return the cached summary if the source didn't change
- ; case lookupFM old_summary_map (wanted_mod, hsc_src) of {
- Just s | ms_hs_date s == src_timestamp -> return s;
- _ -> do
-
- -- Preprocess the source file
- { (dflags', hspp_fn) <- preprocess dflags src_fn
- -- The dflags' contains the OPTIONS pragmas
-
+ let location' | is_boot = addBootSuffixLocn location
+ | otherwise = location
+ src_fn = fromJust (ml_hs_file location')
+
+ -- Check that it exists
+ -- It might have been deleted since the Finder last found it
+ ; exists <- doesFileExist src_fn
+ ; if exists then return () else noHsFileErr cur_mod src_fn
+
+ -- Preprocess the source file and get its imports
+ -- The dflags' contains the OPTIONS pragmas
+ ; (dflags', hspp_fn) <- preprocess dflags src_fn
; buf <- hGetStringBuffer hspp_fn
; (srcimps, the_imps, mod_name) <- getImports dflags' buf hspp_fn
<> text ": file name does not match module name"
<+> quotes (ppr mod_name))))
- ; return (ModSummary { ms_mod = wanted_mod,
- ms_hsc_src = hsc_src,
- ms_location = location',
- ms_hspp_file = Just hspp_fn,
- ms_hspp_buf = Just buf,
- ms_srcimps = srcimps,
- ms_imps = the_imps,
- ms_hs_date = src_timestamp })
- }}}
+ -- Find its timestamp, and return the summary
+ ; src_timestamp <- getModificationTime src_fn
+ ; return (Just ( ModSummary { ms_mod = wanted_mod,
+ ms_hsc_src = hsc_src,
+ ms_location = location',
+ ms_hspp_file = Just hspp_fn,
+ ms_hspp_buf = Just buf,
+ ms_srcimps = srcimps,
+ ms_imps = the_imps,
+ ms_hs_date = src_timestamp }))
+ }
-----------------------------------------------------------------------------
vcat [cantFindError dflags wanted_mod err,
nest 2 (parens (pp_where cur_mod))]
-noHsFileErr :: Maybe FilePath -> Module -> IO a
--- Complain about not being able to find an imported module
-noHsFileErr cur_mod mod
- = throwDyn $ CmdLineError $ showSDoc $
- vcat [text "No source file for module" <+> quotes (ppr mod),
- nest 2 (parens (pp_where cur_mod))]
-
-noHsBootFileErr cur_mod path
+noHsFileErr cur_mod path
= throwDyn $ CmdLineError $ showSDoc $
vcat [text "Can't find" <+> text path,
nest 2 (parens (pp_where cur_mod))]
projects / ghc-hetmet.git / blobdiff