gcatch, gbracket, gfinally,
clearWarnings, getWarnings, hasWarnings,
printExceptionAndWarnings, printWarnings,
- handleSourceError,
+ handleSourceError, defaultCallbacks, GhcApiCallbacks(..),
-- * Flags and settings
DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt,
-- * Loading\/compiling the program
depanal,
- load, loadWithLogger, LoadHowMuch(..), SuccessFlag(..), -- also does depanal
+ load, loadWithLogger, LoadHowMuch(..),
+ SuccessFlag(..), succeeded, failed,
defaultWarnErrLogger, WarnErrLogger,
workingDirectoryChanged,
parseModule, typecheckModule, desugarModule, loadModule,
dflags0 <- liftIO $ initDynFlags defaultDynFlags
dflags <- liftIO $ initSysTools mb_top_dir dflags0
- env <- liftIO $ newHscEnv dflags
+ env <- liftIO $ newHscEnv defaultCallbacks dflags
setSession env
clearWarnings
+defaultCallbacks :: GhcApiCallbacks
+defaultCallbacks =
+ GhcApiCallbacks {
+ reportModuleCompilationResult =
+ \_ mb_err -> defaultWarnErrLogger mb_err
+ }
+
-- -----------------------------------------------------------------------------
-- Flags & settings
-- the actual compilation starts (e.g., during dependency analysis).
--
load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
-load how_much =
- loadWithLogger defaultWarnErrLogger how_much
+load how_much = do
+ mod_graph <- depanal [] False
+ load2 how_much mod_graph
-- | A function called to log warnings and errors.
type WarnErrLogger = GhcMonad m => Maybe SourceError -> m ()
-- even if we don't get a fully successful upsweep, the full module
-- graph is still retained in the Session. We can tell which modules
-- were successfully loaded by inspecting the Session's HPT.
- mod_graph <- depanal [] False
- load2 how_much mod_graph logger
+ withLocalCallbacks (\cbs -> cbs { reportModuleCompilationResult =
+ \_ -> logger }) $
+ load how_much
-load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] -> WarnErrLogger
+load2 :: GhcMonad m => LoadHowMuch -> [ModSummary]
-> m SuccessFlag
-load2 how_much mod_graph logger = do
+load2 how_much mod_graph = do
guessOutputFile
hsc_env <- getSession
-- If we can determine that any of the {-# SOURCE #-} imports
-- are definitely unnecessary, then emit a warning.
- warnUnnecessarySourceImports dflags mg2_with_srcimps
+ warnUnnecessarySourceImports mg2_with_srcimps
let
-- check the stability property for each module.
liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
2 (ppr mg))
(upsweep_ok, hsc_env1, modsUpswept)
- <- upsweep logger
- (hsc_env { hsc_HPT = emptyHomePackageTable })
+ <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable })
pruned_hpt stable_mods cleanup mg
-- Make modsDone be the summaries for each home module now
loadModule tcm = do
let ms = modSummary tcm
let mod = ms_mod_name ms
- let (tcg, details) = tm_internals tcm
+ let (tcg, _details) = tm_internals tcm
hpt_new <-
withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do
- (iface, _) <- makeSimpleIface Nothing tcg details
- let mod_info = HomeModInfo {
- hm_iface = iface,
- hm_details = details,
- hm_linkable = Nothing }
+
+ let compilerBackend comp env ms' _ _mb_old_iface _ =
+ withTempSession (\_ -> env) $
+ hscBackend comp tcg ms'
+ Nothing
hsc_env <- getSession
+ mod_info
+ <- compile' (compilerBackend hscNothingCompiler
+ ,compilerBackend hscInteractiveCompiler
+ ,compilerBackend hscBatchCompiler)
+ hsc_env ms 1 1 Nothing Nothing
+ -- compile' shouldn't change the environment
return $ addToUFM (hsc_HPT hsc_env) mod mod_info
modifySession $ \e -> e{ hsc_HPT = hpt_new }
return tcm
scc_mods = map ms_mod_name scc
home_module m = m `elem` all_home_mods && m `notElem` scc_mods
- scc_allimps = nub (filter home_module (concatMap ms_allimps scc))
+ scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc))
-- all imports outside the current SCC, but in the home pkg
stable_obj_imps = map (`elem` stable_obj) scc_allimps
linkableTime l >= ms_hs_date ms
_other -> False
-ms_allimps :: ModSummary -> [ModuleName]
-ms_allimps ms = map unLoc (ms_srcimps ms ++ ms_imps ms)
-
-- -----------------------------------------------------------------------------
-- | Prune the HomePackageTable
upsweep
:: GhcMonad m =>
- WarnErrLogger -- ^ Called to print warnings and errors.
- -> HscEnv -- ^ Includes initially-empty HPT
+ HscEnv -- ^ Includes initially-empty HPT
-> HomePackageTable -- ^ HPT from last time round (pruned)
-> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability)
-> IO () -- ^ How to clean up unwanted tmp files
HscEnv, -- With an updated HPT
[ModSummary]) -- Mods which succeeded
-upsweep logger hsc_env old_hpt stable_mods cleanup sccs = do
+upsweep hsc_env old_hpt stable_mods cleanup sccs = do
(res, hsc_env, done) <- upsweep' hsc_env old_hpt [] sccs 1 (length sccs)
return (res, hsc_env, reverse done)
where
= do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
-- show (map (moduleUserString.moduleName.mi_module.hm_iface)
-- (moduleEnvElts (hsc_HPT hsc_env)))
+ let logger = reportModuleCompilationResult (hsc_callbacks hsc_env)
mb_mod_info
<- handleSourceError
- (\err -> do logger (Just err); return Nothing) $ do
+ (\err -> do logger mod (Just err); return Nothing) $ do
mod_info <- upsweep_mod hsc_env old_hpt stable_mods
mod mod_index nmods
- logger Nothing -- log warnings
+ logger mod Nothing -- log warnings
return (Just mod_info)
liftIO cleanup -- Remove unwanted tmp files between compilations
| (s, key) <- numbered_summaries
-- Drop the hi-boot ones if told to do so
, not (isBootSummary s && drop_hs_boot_nodes)
- , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++
- out_edge_keys HsSrcFile (map unLoc (ms_imps s)) ++
+ , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++
+ out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++
(-- see [boot-edges] below
if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
then []
-- components in the topological sort, then those imports can
-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
-- were necessary, then the edge would be part of a cycle.
-warnUnnecessarySourceImports :: GhcMonad m => DynFlags -> [SCC ModSummary] -> m ()
-warnUnnecessarySourceImports dflags sccs =
- liftIO $ printBagOfWarnings dflags (listToBag (concatMap (check.flattenSCC) sccs))
+warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
+warnUnnecessarySourceImports sccs =
+ logWarnings (listToBag (concatMap (check.flattenSCC) sccs))
where check ms =
let mods_in_this_cycle = map ms_mod_name ms in
- [ warn i | m <- ms, i <- ms_srcimps m,
- unLoc i `notElem` mods_in_this_cycle ]
+ [ warn i | m <- ms, i <- ms_home_srcimps m,
+ unLoc i `notElem` mods_in_this_cycle ]
warn :: Located ModuleName -> WarnMsg
warn (L loc mod) =
-- Remember, this pass isn't doing the topological sort. It's
-- just gathering the list of all relevant ModSummaries
msDeps s =
- concat [ [(m,True), (m,False)] | m <- ms_srcimps s ]
- ++ [ (m,False) | m <- ms_imps s ]
+ concat [ [(m,True), (m,False)] | m <- ms_home_srcimps s ]
+ ++ [ (m,False) | m <- ms_home_imps s ]
+
+home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName]
+home_imps imps = [ ideclName i | L _ i <- imps, isNothing (ideclPkgQual i) ]
+
+ms_home_allimps :: ModSummary -> [ModuleName]
+ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)
+
+ms_home_srcimps :: ModSummary -> [Located ModuleName]
+ms_home_srcimps = home_imps . ms_srcimps
+
+ms_home_imps :: ModSummary -> [Located ModuleName]
+ms_home_imps = home_imps . ms_imps
-----------------------------------------------------------------------------
-- Summarising modules
projects / ghc-hetmet.git / blobdiff