-- * Loading\/compiling the program
depanal,
load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal
+ loadMsgs,
workingDirectoryChanged,
checkModule, CheckedModule(..),
+ TypecheckedSource, ParsedSource,
-- * Inspecting the module structure of the program
ModuleGraph, ModSummary(..),
getModuleInfo,
modInfoTyThings,
modInfoTopLevelScope,
+ modInfoPrintUnqualified,
+ modInfoExports,
lookupName,
-- * Interactive evaluation
import Name ( Name, getName, nameModule_maybe )
import RdrName ( RdrName, gre_name, globalRdrEnvElts )
import NameEnv ( nameEnvElts )
-import SrcLoc ( Located(..) )
+import SrcLoc ( Located(..), mkSrcLoc, srcLocSpan )
import DriverPipeline
import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase )
import GetImports ( getImports )
import BasicTypes ( SuccessFlag(..), succeeded, failed )
import Maybes ( orElse, expectJust, mapCatMaybes )
import TcType ( tcSplitSigmaTy, isDictTy )
+import Bag ( unitBag, emptyBag )
+import FastString ( mkFastString )
import Directory ( getModificationTime, doesFileExist )
import Maybe ( isJust, isNothing, fromJust, fromMaybe, catMaybes )
-- attempt to load up to this target. If no Module is supplied,
-- then try to load all targets.
load :: Session -> LoadHowMuch -> IO SuccessFlag
-load s@(Session ref) how_much
+load session how_much =
+ loadMsgs session how_much ErrUtils.printErrorsAndWarnings
+
+-- | Version of 'load' that takes a callback function to be invoked
+-- on compiler errors and warnings as they occur during compilation.
+loadMsgs :: Session -> LoadHowMuch -> (Messages-> IO ()) -> IO SuccessFlag
+loadMsgs s@(Session ref) how_much msg_act
= do
-- Dependency analysis first. Note that this fixes the module graph:
-- even if we don't get a fully successful upsweep, the full module
(upsweep_ok, hsc_env1, modsUpswept)
<- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable })
- pruned_hpt stable_mods cleanup mg
+ pruned_hpt stable_mods cleanup msg_act mg
-- Make modsDone be the summaries for each home module now
-- available; this should equal the domain of hpt3.
-> IO (Maybe CheckedModule)
checkModule session@(Session ref) mod msg_act = do
-- load up the dependencies first
- r <- load session (LoadDependenciesOf mod)
+ r <- loadMsgs session (LoadDependenciesOf mod) msg_act
if (failed r) then return Nothing else do
-- now parse & typecheck the module
case [ ms | ms <- mg, ms_mod ms == mod ] of
[] -> return Nothing
(ms:_) -> do
- r <- hscFileCheck hsc_env msg_act ms
+ -- Add in the OPTIONS from the source file This is nasty:
+ -- we've done this once already, in the compilation manager
+ -- It might be better to cache the flags in the
+ -- ml_hspp_file field, say
+ let dflags0 = hsc_dflags hsc_env
+ hspp_buf = expectJust "GHC.checkModule" (ms_hspp_buf ms)
+ opts = getOptionsFromStringBuffer hspp_buf
+ (dflags1,leftovers) <- parseDynamicFlags dflags0 (map snd opts)
+ if (not (null leftovers))
+ then do let filename = fromJust (ml_hs_file (ms_location ms))
+ msg_act (optionsErrorMsgs leftovers opts filename)
+ return Nothing
+ else do
+
+ r <- hscFileCheck hsc_env{hsc_dflags=dflags1} msg_act ms
case r of
HscFail ->
return Nothing
-> HomePackageTable -- HPT from last time round (pruned)
-> ([Module],[Module]) -- stable modules (see checkStability)
-> IO () -- How to clean up unwanted tmp files
+ -> (Messages -> IO ()) -- Compiler error message callback
-> [SCC ModSummary] -- Mods to do (the worklist)
-> IO (SuccessFlag,
HscEnv, -- With an updated HPT
[ModSummary]) -- Mods which succeeded
-upsweep hsc_env old_hpt stable_mods cleanup
- []
+upsweep hsc_env old_hpt stable_mods cleanup msg_act mods
+ = upsweep' hsc_env old_hpt stable_mods cleanup msg_act mods 1 (length mods)
+
+upsweep' hsc_env old_hpt stable_mods cleanup msg_act
+ [] _ _
= return (Succeeded, hsc_env, [])
-upsweep hsc_env old_hpt stable_mods cleanup
- (CyclicSCC ms:_)
+upsweep' hsc_env old_hpt stable_mods cleanup msg_act
+ (CyclicSCC ms:_) _ _
= do putMsg (showSDoc (cyclicModuleErr ms))
return (Failed, hsc_env, [])
-upsweep hsc_env old_hpt stable_mods cleanup
- (AcyclicSCC mod:mods)
+upsweep' hsc_env old_hpt stable_mods cleanup msg_act
+ (AcyclicSCC mod:mods) mod_index nmods
= do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
-- show (map (moduleUserString.moduleName.mi_module.hm_iface)
-- (moduleEnvElts (hsc_HPT hsc_env)))
- mb_mod_info <- upsweep_mod hsc_env old_hpt stable_mods mod
+ mb_mod_info <- upsweep_mod hsc_env old_hpt stable_mods msg_act mod
+ mod_index nmods
cleanup -- Remove unwanted tmp files between compilations
| otherwise = delModuleEnv old_hpt this_mod
; (restOK, hsc_env2, modOKs)
- <- upsweep hsc_env1 old_hpt1 stable_mods cleanup mods
+ <- upsweep' hsc_env1 old_hpt1 stable_mods cleanup
+ msg_act mods (mod_index+1) nmods
; return (restOK, hsc_env2, mod:modOKs)
}
upsweep_mod :: HscEnv
-> HomePackageTable
-> ([Module],[Module])
+ -> (Messages -> IO ())
-> ModSummary
+ -> Int -- index of module
+ -> Int -- total number of modules
-> IO (Maybe HomeModInfo) -- Nothing => Failed
-upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary
+upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) msg_act summary mod_index nmods
= do
let
this_mod = ms_mod summary
hs_date = ms_hs_date summary
compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo)
- compile_it = upsweep_compile hsc_env old_hpt this_mod summary
+ compile_it = upsweep_compile hsc_env old_hpt this_mod
+ msg_act summary mod_index nmods
case ghcMode (hsc_dflags hsc_env) of
BatchCompile ->
old_hmi = lookupModuleEnv old_hpt this_mod
-- Run hsc to compile a module
-upsweep_compile hsc_env old_hpt this_mod summary mb_old_linkable = do
+upsweep_compile hsc_env old_hpt this_mod msg_act summary
+ mod_index nmods
+ mb_old_linkable = do
let
-- The old interface is ok if it's in the old HPT
-- a) we're compiling a source file, and the old HPT
where
iface = hm_iface hm_info
- compresult <- compile hsc_env summary mb_old_linkable mb_old_iface
+ compresult <- compile hsc_env msg_act summary mb_old_linkable mb_old_iface
+ mod_index nmods
case compresult of
-- Compilation failed. Compile may still have updated the PCS, tho.
let
local_opts = getOptionsFromStringBuffer buf
--
- (dflags', errs) <- parseDynamicFlags dflags local_opts
+ (dflags', errs) <- parseDynamicFlags dflags (map snd local_opts)
let
needs_preprocessing
when needs_preprocessing $
ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")
- return (dflags', "<buffer>", buf)
+ return (dflags', src_fn, buf)
-----------------------------------------------------------------------------
modInfoExports :: ModuleInfo -> [Name]
modInfoExports minf = nameSetToList $! (md_exports $! minf_details minf)
+modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified
+modInfoPrintUnqualified minf = fmap unQualInScope (minf_rdr_env minf)
+
isDictonaryId :: Id -> Bool
isDictonaryId id
= case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau }
projects / ghc-hetmet.git / blobdiff