Session,
defaultErrorHandler,
defaultCleanupHandler,
- init, initFromArgs,
newSession,
-- * Flags and settings
- DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt,
+ DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt,
+ GhcMode(..), GhcLink(..), defaultObjectTarget,
parseDynamicFlags,
- initPackages,
getSessionDynFlags,
setSessionDynFlags,
+ parseStaticFlags,
-- * Targets
Target(..), TargetId(..), Phase,
removeTarget,
guessTarget,
+ -- * Extending the program scope
+ extendGlobalRdrScope, -- :: Session -> [GlobalRdrElt] -> IO ()
+ setGlobalRdrScope, -- :: Session -> [GlobalRdrElt] -> IO ()
+ extendGlobalTypeScope, -- :: Session -> [Id] -> IO ()
+ setGlobalTypeScope, -- :: Session -> [Id] -> IO ()
+
-- * Loading\/compiling the program
depanal,
load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal
workingDirectoryChanged,
checkModule, CheckedModule(..),
TypecheckedSource, ParsedSource, RenamedSource,
+ compileToCore,
+
+ -- * Parsing Haddock comments
+ parseHaddockComment,
-- * Inspecting the module structure of the program
- ModuleGraph, ModSummary(..), ModLocation(..),
+ ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
getModuleGraph,
isLoaded,
topSortModuleGraph,
-- * Interactive evaluation
getBindings, getPrintUnqual,
+ findModule,
#ifdef GHCI
setContext, getContext,
getNamesInScope,
exprType,
typeKind,
parseName,
- RunResult(..),
- runStmt,
+ RunResult(..),
+ runStmt, SingleStep(..),
+ resume,
+ Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
+ resumeHistory, resumeHistoryIx),
+ History(historyBreakInfo), getHistorySpan,
+ getResumeContext,
+ abandon, abandonAll,
+ InteractiveEval.back,
+ InteractiveEval.forward,
showModule,
- compileExpr, HValue,
+ isModuleInterpreted,
+ compileExpr, HValue, dynCompileExpr,
lookupName,
+ obtainTerm, obtainTerm1,
+ modInfoModBreaks,
+ ModBreaks(..), BreakIndex,
+ BreakInfo(breakInfo_number, breakInfo_module),
+ BreakArray, setBreakOn, setBreakOff, getBreak,
#endif
-- * Abstract syntax elements
+ -- ** Packages
+ PackageId,
+
-- ** Modules
- Module, mkModule, pprModule,
+ Module, mkModule, pprModule, moduleName, modulePackageId,
+ ModuleName, mkModuleName, moduleNameString,
-- ** Names
Name,
- nameModule, nameParent_maybe, pprParenSymName, nameSrcLoc,
+ isExternalName, nameModule, pprParenSymName, nameSrcSpan,
NamedThing(..),
RdrName(Qual,Unqual),
TyCon,
tyConTyVars, tyConDataCons, tyConArity,
isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
- synTyConDefn, synTyConRhs,
+ isOpenTyCon,
+ synTyConDefn, synTyConType, synTyConResKind,
-- ** Type variables
TyVar,
instanceDFunId, pprInstance, pprInstanceHdr,
-- ** Types and Kinds
- Type, dropForAlls, splitForAllTys, funResultTy, pprParendType,
+ Type, dropForAlls, splitForAllTys, funResultTy,
+ pprParendType, pprTypeApp,
Kind,
PredType,
ThetaType, pprThetaArrow,
-- ** Source locations
SrcLoc, pprDefnLoc,
+ mkSrcLoc, isGoodSrcLoc, noSrcLoc,
+ srcLocFile, srcLocLine, srcLocCol,
+ SrcSpan,
+ mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
+ srcSpanStart, srcSpanEnd,
+ srcSpanFile,
+ srcSpanStartLine, srcSpanEndLine,
+ srcSpanStartCol, srcSpanEndCol,
-- * Exceptions
GhcException(..), showGhcException,
ToDo:
* inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
- * we need to expose DynFlags, so should parseDynamicFlags really be
- part of this interface?
* what StaticFlags should we expose, if any?
-}
#ifdef GHCI
import qualified Linker
-import Linker ( HValue, extendLinkEnv )
-import TcRnDriver ( tcRnLookupRdrName, tcRnGetInfo,
- tcRnLookupName, getModuleExports )
-import RdrName ( plusGlobalRdrEnv, Provenance(..),
- ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
- emptyGlobalRdrEnv, mkGlobalRdrEnv )
-import HscMain ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType )
-import Type ( tidyType )
-import VarEnv ( emptyTidyEnv )
-import GHC.Exts ( unsafeCoerce# )
+import Linker ( HValue )
+import ByteCodeInstr
+import BreakArray
+import NameSet
+import TcRnDriver
+import InteractiveEval
#endif
-import Packages ( initPackages )
-import NameSet ( NameSet, nameSetToList, elemNameSet )
-import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..),
- globalRdrEnvElts )
-import HsSyn
-import Type ( Kind, Type, dropForAlls, PredType, ThetaType,
- pprThetaArrow, pprParendType, splitForAllTys,
- funResultTy )
-import Id ( Id, idType, isImplicitId, isDeadBinder,
- isExportedId, isLocalId, isGlobalId,
- isRecordSelector, recordSelectorFieldLabel,
- isPrimOpId, isFCallId, isClassOpId_maybe,
- isDataConWorkId, idDataCon,
- isBottomingId )
-import Var ( TyVar )
+import Packages
+import NameSet
+import RdrName
+import HsSyn
+import Type hiding (typeKind)
+import TcType hiding (typeKind)
+import Id
+import Var hiding (setIdType)
import TysPrim ( alphaTyVars )
-import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
- isPrimTyCon, isFunTyCon, tyConArity,
- tyConTyVars, tyConDataCons, synTyConDefn, synTyConRhs )
-import Class ( Class, classSCTheta, classTvsFds, classMethods )
-import FunDeps ( pprFundeps )
-import DataCon ( DataCon, dataConWrapId, dataConSig, dataConTyCon,
- dataConFieldLabels, dataConStrictMarks,
- dataConIsInfix, isVanillaDataCon )
-import Name ( Name, nameModule, NamedThing(..), nameParent_maybe,
- nameSrcLoc, nameOccName )
+import TyCon
+import Class
+import FunDeps
+import DataCon
+import Name hiding ( varName )
import OccName ( parenSymOcc )
-import NameEnv ( nameEnvElts )
import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
import SrcLoc
+import Desugar
+import CoreSyn
+import TcRnDriver ( tcRnModule )
import DriverPipeline
-import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase )
+import DriverPhases ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase )
import HeaderInfo ( getImports, getOptions )
-import Packages ( isHomePackage )
import Finder
-import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) )
+import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) )
import HscTypes
import DynFlags
-import SysTools ( initSysTools, cleanTempFiles )
+import StaticFlags
+import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
+ cleanTempDirs )
import Module
+import UniqFM
+import UniqSet
+import Unique
+import PackageConfig
import FiniteMap
import Panic
import Digraph
-import Bag ( unitBag )
+import Bag ( unitBag, listToBag )
import ErrUtils ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg,
- mkPlainErrMsg, printBagOfErrors, printErrorsAndWarnings )
+ mkPlainErrMsg, printBagOfErrors, printBagOfWarnings,
+ WarnMsg )
import qualified ErrUtils
import Util
import StringBuffer ( StringBuffer, hGetStringBuffer )
import Outputable
-import SysTools ( cleanTempFilesExcept )
import BasicTypes
-import TcType ( tcSplitSigmaTy, isDictTy )
import Maybes ( expectJust, mapCatMaybes )
+import HaddockParse
+import HaddockLex ( tokenise )
import Control.Concurrent
import System.Directory ( getModificationTime, doesFileExist )
-import Data.Maybe ( isJust, isNothing )
-import Data.List ( partition, nub )
+import Data.Maybe
+import Data.List
import qualified Data.List as List
-import Control.Monad ( unless, when )
+import Control.Monad
import System.Exit ( exitWith, ExitCode(..) )
import System.Time ( ClockTime )
import Control.Exception as Exception hiding (handle)
import Data.IORef
import System.IO
-import System.IO.Error ( isDoesNotExistError )
+import System.IO.Error ( try, isDoesNotExistError )
import Prelude hiding (init)
-#if __GLASGOW_HASKELL__ < 600
-import System.IO as System.IO.Error ( try )
-#else
-import System.IO.Error ( try )
-#endif
-- -----------------------------------------------------------------------------
-- Exception handlers
-- handling, but still get the ordinary cleanup behaviour.
defaultCleanupHandler :: DynFlags -> IO a -> IO a
defaultCleanupHandler dflags inner =
- -- make sure we clean up after ourselves
- later (unless (dopt Opt_KeepTmpFiles dflags) $
- cleanTempFiles dflags)
- -- exceptions will be blocked while we clean the temporary files,
- -- so there shouldn't be any difficulty if we receive further
- -- signals.
- inner
-
-
--- | Initialises GHC. This must be done /once/ only. Takes the
--- TopDir path without the '-B' prefix.
-
-init :: Maybe String -> IO ()
-init mbMinusB = do
- -- catch ^C
- main_thread <- myThreadId
- putMVar interruptTargetThread [main_thread]
- installSignalHandlers
-
- dflags0 <- initSysTools mbMinusB defaultDynFlags
- writeIORef v_initDynFlags dflags0
-
--- | Initialises GHC. This must be done /once/ only. Takes the
--- command-line arguments. All command-line arguments which aren't
--- understood by GHC will be returned.
-
-initFromArgs :: [String] -> IO [String]
-initFromArgs args
- = do init mbMinusB
- return argv1
- where -- Grab the -B option if there is one
- (minusB_args, argv1) = partition (prefixMatch "-B") args
- mbMinusB | null minusB_args
- = Nothing
- | otherwise
- = Just (drop 2 (last minusB_args))
-
-GLOBAL_VAR(v_initDynFlags, error "initDynFlags", DynFlags)
- -- stores the DynFlags between the call to init and subsequent
- -- calls to newSession.
+ -- make sure we clean up after ourselves
+ later (do cleanTempFiles dflags
+ cleanTempDirs dflags
+ )
+ -- exceptions will be blocked while we clean the temporary files,
+ -- so there shouldn't be any difficulty if we receive further
+ -- signals.
+ inner
+
-- | Starts a new session. A session consists of a set of loaded
-- modules, a set of options (DynFlags), and an interactive context.
--- ToDo: GhcMode should say "keep typechecked code" and\/or "keep renamed
--- code".
-newSession :: GhcMode -> IO Session
-newSession mode = do
- dflags0 <- readIORef v_initDynFlags
- dflags <- initDynFlags dflags0
- env <- newHscEnv dflags{ ghcMode=mode }
+newSession :: Maybe FilePath -> IO Session
+newSession mb_top_dir = do
+ -- catch ^C
+ main_thread <- myThreadId
+ modifyMVar_ interruptTargetThread (return . (main_thread :))
+ installSignalHandlers
+
+ initStaticOpts
+ dflags0 <- initSysTools mb_top_dir defaultDynFlags
+ dflags <- initDynFlags dflags0
+ env <- newHscEnv dflags
ref <- newIORef env
return (Session ref)
sessionHscEnv :: Session -> IO HscEnv
sessionHscEnv (Session ref) = readIORef ref
-withSession :: Session -> (HscEnv -> IO a) -> IO a
-withSession (Session ref) f = do h <- readIORef ref; f h
-
-modifySession :: Session -> (HscEnv -> HscEnv) -> IO ()
-modifySession (Session ref) f = do h <- readIORef ref; writeIORef ref $! f h
-
-- -----------------------------------------------------------------------------
-- Flags & settings
getSessionDynFlags :: Session -> IO DynFlags
getSessionDynFlags s = withSession s (return . hsc_dflags)
--- | Updates the DynFlags in a Session
-setSessionDynFlags :: Session -> DynFlags -> IO ()
-setSessionDynFlags s dflags = modifySession s (\h -> h{ hsc_dflags = dflags })
+-- | Updates the DynFlags in a Session. This also reads
+-- the package database (unless it has already been read),
+-- and prepares the compilers knowledge about packages. It
+-- can be called again to load new packages: just add new
+-- package flags to (packageFlags dflags).
+--
+-- Returns a list of new packages that may need to be linked in using
+-- the dynamic linker (see 'linkPackages') as a result of new package
+-- flags. If you are not doing linking or doing static linking, you
+-- can ignore the list of packages returned.
+--
+setSessionDynFlags :: Session -> DynFlags -> IO [PackageId]
+setSessionDynFlags (Session ref) dflags = do
+ hsc_env <- readIORef ref
+ (dflags', preload) <- initPackages dflags
+ writeIORef ref $! hsc_env{ hsc_dflags = dflags' }
+ return preload
-- | If there is no -o option, guess the name of target executable
-- by using top-level source file name as a base.
if exists
then return (Target (TargetFile lhs_file Nothing) Nothing)
else do
- return (Target (TargetModule (mkModule file)) Nothing)
+ return (Target (TargetModule (mkModuleName file)) Nothing)
where
hs_file = file `joinFileExt` "hs"
lhs_file = file `joinFileExt` "lhs"
-- -----------------------------------------------------------------------------
+-- Extending the program scope
+
+extendGlobalRdrScope :: Session -> [GlobalRdrElt] -> IO ()
+extendGlobalRdrScope session rdrElts
+ = modifySession session $ \hscEnv ->
+ let global_rdr = hsc_global_rdr_env hscEnv
+ in hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv global_rdr rdrElts }
+
+setGlobalRdrScope :: Session -> [GlobalRdrElt] -> IO ()
+setGlobalRdrScope session rdrElts
+ = modifySession session $ \hscEnv ->
+ hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv emptyGlobalRdrEnv rdrElts }
+
+extendGlobalTypeScope :: Session -> [Id] -> IO ()
+extendGlobalTypeScope session ids
+ = modifySession session $ \hscEnv ->
+ let global_type = hsc_global_type_env hscEnv
+ in hscEnv{ hsc_global_type_env = extendTypeEnvWithIds global_type ids }
+
+setGlobalTypeScope :: Session -> [Id] -> IO ()
+setGlobalTypeScope session ids
+ = modifySession session $ \hscEnv ->
+ hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids }
+
+-- -----------------------------------------------------------------------------
+-- Parsing Haddock comments
+
+parseHaddockComment :: String -> Either String (HsDoc RdrName)
+parseHaddockComment string = parseHaddockParagraphs (tokenise string)
+
+-- -----------------------------------------------------------------------------
-- Loading the program
-- Perform a dependency analysis starting from the current targets
-- and update the session with the new module graph.
-depanal :: Session -> [Module] -> Bool -> IO (Maybe ModuleGraph)
+depanal :: Session -> [ModuleName] -> Bool -> IO (Maybe ModuleGraph)
depanal (Session ref) excluded_mods allow_dup_roots = do
hsc_env <- readIORef ref
let
dflags = hsc_dflags hsc_env
- gmode = ghcMode (hsc_dflags hsc_env)
targets = hsc_targets hsc_env
old_graph = hsc_mod_graph hsc_env
showPass dflags "Chasing dependencies"
- when (gmode == BatchCompile) $
- debugTraceMsg dflags 1 (hcat [
- text "Chasing modules from: ",
- hcat (punctuate comma (map pprTarget targets))])
+ debugTraceMsg dflags 2 (hcat [
+ text "Chasing modules from: ",
+ hcat (punctuate comma (map pprTarget targets))])
r <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
case r of
data LoadHowMuch
= LoadAllTargets
- | LoadUpTo Module
- | LoadDependenciesOf Module
+ | LoadUpTo ModuleName
+ | LoadDependenciesOf ModuleName
-- | Try to load the program. If a Module is supplied, then just
-- attempt to load up to this target. If no Module is supplied,
let hpt1 = hsc_HPT hsc_env
let dflags = hsc_dflags hsc_env
- let ghci_mode = ghcMode dflags -- this never changes
-- The "bad" boot modules are the ones for which we have
-- B.hs-boot in the module graph, but no B.hs
-- The downsweep should have ensured this does not happen
-- (see msDeps)
- let all_home_mods = [ms_mod s | s <- mod_graph, not (isBootSummary s)]
+ let all_home_mods = [ms_mod_name s
+ | s <- mod_graph, not (isBootSummary s)]
#ifdef DEBUG
bad_boot_mods = [s | s <- mod_graph, isBootSummary s,
- not (ms_mod s `elem` all_home_mods)]
+ not (ms_mod_name s `elem` all_home_mods)]
#endif
ASSERT( null bad_boot_mods ) return ()
let mg2_with_srcimps :: [SCC ModSummary]
mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
+ -- If we can determine that any of the {-# SOURCE #-} imports
+ -- are definitely unnecessary, then emit a warning.
+ warnUnnecessarySourceImports dflags mg2_with_srcimps
+
+ let
-- check the stability property for each module.
stable_mods@(stable_obj,stable_bco)
- | BatchCompile <- ghci_mode = ([],[])
- | otherwise = checkStability hpt1 mg2_with_srcimps all_home_mods
+ = checkStability hpt1 mg2_with_srcimps all_home_mods
-- prune bits of the HPT which are definitely redundant now,
-- to save space.
-- Unload any modules which are going to be re-linked this time around.
let stable_linkables = [ linkable
| m <- stable_obj++stable_bco,
- Just hmi <- [lookupModuleEnv pruned_hpt m],
+ Just hmi <- [lookupUFM pruned_hpt m],
Just linkable <- [hm_linkable hmi] ]
unload hsc_env stable_linkables
partial_mg
| LoadDependenciesOf mod <- how_much
= ASSERT( case last partial_mg0 of
- AcyclicSCC ms -> ms_mod ms == mod; _ -> False )
+ AcyclicSCC ms -> ms_mod_name ms == mod; _ -> False )
List.init partial_mg0
| otherwise
= partial_mg0
stable_mg =
[ AcyclicSCC ms
| AcyclicSCC ms <- full_mg,
- ms_mod ms `elem` stable_obj++stable_bco,
- ms_mod ms `notElem` [ ms_mod ms' |
- AcyclicSCC ms' <- partial_mg ] ]
+ ms_mod_name ms `elem` stable_obj++stable_bco,
+ ms_mod_name ms `notElem` [ ms_mod_name ms' |
+ AcyclicSCC ms' <- partial_mg ] ]
mg = stable_mg ++ partial_mg
let cleanup = cleanTempFilesExcept dflags
(ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))
+ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
+ 2 (ppr mg))
(upsweep_ok, hsc_env1, modsUpswept)
<- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable })
pruned_hpt stable_mods cleanup mg
a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
do_linking = a_root_is_Main || no_hs_main
- when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $
- debugTraceMsg dflags 1 (text ("Warning: output was redirected with -o, " ++
- "but no output will be generated\n" ++
- "because there is no " ++ moduleString main_mod ++ " module."))
+ when (ghcLink dflags == LinkBinary
+ && isJust ofile && not do_linking) $
+ debugTraceMsg dflags 1 $
+ text ("Warning: output was redirected with -o, " ++
+ "but no output will be generated\n" ++
+ "because there is no " ++
+ moduleNameString (moduleName main_mod) ++ " module.")
-- link everything together
- linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env1)
+ linkresult <- link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)
loadFinish Succeeded linkresult ref hsc_env1
= filter ((`notElem` mods_to_zap_names).ms_mod)
modsDone
- let hpt4 = retainInTopLevelEnvs (map ms_mod mods_to_keep)
+ let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
(hsc_HPT hsc_env1)
-- Clean up after ourselves
-- there should be no Nothings where linkables should be, now
ASSERT(all (isJust.hm_linkable)
- (moduleEnvElts (hsc_HPT hsc_env))) do
+ (eltsUFM (hsc_HPT hsc_env))) do
-- Link everything together
- linkresult <- link ghci_mode dflags False hpt4
+ linkresult <- link (ghcLink dflags) dflags False hpt4
let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
loadFinish Failed linkresult ref hsc_env4
CheckedModule { parsedSource :: ParsedSource,
renamedSource :: Maybe RenamedSource,
typecheckedSource :: Maybe TypecheckedSource,
- checkedModuleInfo :: Maybe ModuleInfo
+ checkedModuleInfo :: Maybe ModuleInfo,
+ coreBinds :: Maybe [CoreBind]
}
-- ToDo: improvements that could be made here:
-- if the module succeeded renaming but not typechecking,
-- fields within CheckedModule.
type ParsedSource = Located (HsModule RdrName)
-type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name])
+type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
+ Maybe (HsDoc Name), HaddockModInfo Name)
type TypecheckedSource = LHsBinds Id
-- NOTE:
-- | This is the way to get access to parsed and typechecked source code
--- for a module. 'checkModule' loads all the dependencies of the specified
--- module in the Session, and then attempts to typecheck the module. If
+-- for a module. 'checkModule' attempts to typecheck the module. If
-- successful, it returns the abstract syntax for the module.
-checkModule :: Session -> Module -> IO (Maybe CheckedModule)
-checkModule session@(Session ref) mod = do
- -- load up the dependencies first
- r <- load session (LoadDependenciesOf mod)
- if (failed r) then return Nothing else do
-
- -- now parse & typecheck the module
+-- If compileToCore is true, it also desugars the module and returns the
+-- resulting Core bindings as a component of the CheckedModule.
+checkModule :: Session -> ModuleName -> Bool -> IO (Maybe CheckedModule)
+checkModule session@(Session ref) mod compileToCore = do
+ -- parse & typecheck the module
hsc_env <- readIORef ref
let mg = hsc_mod_graph hsc_env
- case [ ms | ms <- mg, ms_mod ms == mod ] of
+ case [ ms | ms <- mg, ms_mod_name ms == mod ] of
[] -> return Nothing
(ms:_) -> do
- mbChecked <- hscFileCheck hsc_env{hsc_dflags=ms_hspp_opts ms} ms
+ mbChecked <- hscFileCheck
+ hsc_env{hsc_dflags=ms_hspp_opts ms}
+ ms compileToCore
case mbChecked of
Nothing -> return Nothing
- Just (HscChecked parsed renamed Nothing) ->
+ Just (HscChecked parsed renamed Nothing _) ->
return (Just (CheckedModule {
parsedSource = parsed,
renamedSource = renamed,
typecheckedSource = Nothing,
- checkedModuleInfo = Nothing }))
+ checkedModuleInfo = Nothing,
+ coreBinds = Nothing }))
Just (HscChecked parsed renamed
- (Just (tc_binds, rdr_env, details))) -> do
+ (Just (tc_binds, rdr_env, details))
+ maybeCoreBinds) -> do
let minf = ModuleInfo {
minf_type_env = md_types details,
- minf_exports = md_exports details,
+ minf_exports = availsToNameSet $
+ md_exports details,
minf_rdr_env = Just rdr_env,
minf_instances = md_insts details
+#ifdef GHCI
+ ,minf_modBreaks = emptyModBreaks
+#endif
}
return (Just (CheckedModule {
parsedSource = parsed,
renamedSource = renamed,
typecheckedSource = Just tc_binds,
- checkedModuleInfo = Just minf }))
-
--- ---------------------------------------------------------------------------
+ checkedModuleInfo = Just minf,
+ coreBinds = maybeCoreBinds}))
+
+-- | This is the way to get access to the Core bindings corresponding
+-- to a module. 'compileToCore' invokes 'checkModule' to parse, typecheck, and
+-- desugar the module, then returns the resulting list of Core bindings if
+-- successful.
+compileToCore :: Session -> FilePath -> IO (Maybe [CoreBind])
+compileToCore session@(Session ref) fn = do
+ hsc_env <- readIORef ref
+ -- First, set the target to the desired filename
+ target <- guessTarget fn Nothing
+ addTarget session target
+ load session LoadAllTargets
+ -- Then find dependencies
+ maybeModGraph <- depanal session [] True
+ case maybeModGraph of
+ Nothing -> return Nothing
+ Just modGraph -> do
+ case find ((== fn) . msHsFilePath) modGraph of
+ Just modSummary -> do
+ -- Now we have the module name;
+ -- parse, typecheck and desugar the module
+ let mod = ms_mod_name modSummary
+ maybeCheckedModule <- checkModule session mod True
+ case maybeCheckedModule of
+ Nothing -> return Nothing
+ Just checkedMod -> return $ coreBinds checkedMod
+ -- ---------------------------------------------------------------------------
-- Unloading
unload :: HscEnv -> [Linkable] -> IO ()
unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
- = case ghcMode (hsc_dflags hsc_env) of
- BatchCompile -> return ()
- JustTypecheck -> return ()
+ = case ghcLink (hsc_dflags hsc_env) of
#ifdef GHCI
- Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables
+ LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables
#else
- Interactive -> panic "unload: no interpreter"
+ LinkInMemory -> panic "unload: no interpreter"
#endif
- other -> panic "unload: strange mode"
+ other -> return ()
-- -----------------------------------------------------------------------------
-- checkStability
module. So we need to know that we will definitely not be recompiling
any of these modules, and we can use the object code.
- NB. stability is of no importance to BatchCompile at all, only Interactive.
- (ToDo: what about JustTypecheck?)
-
The stability check is as follows. Both stableObject and
stableBCO are used during the upsweep phase later.
These properties embody the following ideas:
- - if a module is stable:
+ - if a module is stable, then:
- if it has been compiled in a previous pass (present in HPT)
then it does not need to be compiled or re-linked.
- if it has not been compiled in a previous pass,
checkStability
:: HomePackageTable -- HPT from last compilation
-> [SCC ModSummary] -- current module graph (cyclic)
- -> [Module] -- all home modules
- -> ([Module], -- stableObject
- [Module]) -- stableBCO
+ -> [ModuleName] -- all home modules
+ -> ([ModuleName], -- stableObject
+ [ModuleName]) -- stableBCO
checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
where
| otherwise = (stable_obj, stable_bco)
where
scc = flattenSCC scc0
- scc_mods = map ms_mod scc
+ 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))
&& same_as_prev t
| otherwise = False
where
- same_as_prev t = case lookupModuleEnv hpt (ms_mod ms) of
+ same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of
Just hmi | Just l <- hm_linkable hmi
-> isObjectLinkable l && t == linkableTime l
_other -> True
-- make's behaviour.
bco_ok ms
- = case lookupModuleEnv hpt (ms_mod ms) of
+ = case lookupUFM hpt (ms_mod_name ms) of
Just hmi | Just l <- hm_linkable hmi ->
not (isObjectLinkable l) &&
linkableTime l >= ms_hs_date ms
_other -> False
-ms_allimps :: ModSummary -> [Module]
+ms_allimps :: ModSummary -> [ModuleName]
ms_allimps ms = map unLoc (ms_srcimps ms ++ ms_imps ms)
-- -----------------------------------------------------------------------------
pruneHomePackageTable
:: HomePackageTable
-> [ModSummary]
- -> ([Module],[Module])
+ -> ([ModuleName],[ModuleName])
-> HomePackageTable
pruneHomePackageTable hpt summ (stable_obj, stable_bco)
- = mapModuleEnv prune hpt
+ = mapUFM prune hpt
where prune hmi
| is_stable modl = hmi'
| otherwise = hmi'{ hm_details = emptyModDetails }
where
- modl = mi_module (hm_iface hmi)
+ modl = moduleName (mi_module (hm_iface hmi))
hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms
= hmi{ hm_linkable = Nothing }
| otherwise
= hmi
- where ms = expectJust "prune" (lookupModuleEnv ms_map modl)
+ where ms = expectJust "prune" (lookupUFM ms_map modl)
- ms_map = mkModuleEnv [(ms_mod ms, ms) | ms <- summ]
+ ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
is_stable m = m `elem` stable_obj || m `elem` stable_bco
upsweep
:: HscEnv -- Includes initially-empty HPT
-> HomePackageTable -- HPT from last time round (pruned)
- -> ([Module],[Module]) -- stable modules (see checkStability)
+ -> ([ModuleName],[ModuleName]) -- stable modules (see checkStability)
-> IO () -- How to clean up unwanted tmp files
-> [SCC ModSummary] -- Mods to do (the worklist)
-> IO (SuccessFlag,
case mb_mod_info of
Nothing -> return (Failed, hsc_env, [])
Just mod_info -> do
- { let this_mod = ms_mod mod
+ { let this_mod = ms_mod_name mod
-- Add new info to hsc_env
- hpt1 = extendModuleEnv (hsc_HPT hsc_env)
- this_mod mod_info
+ hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info
hsc_env1 = hsc_env { hsc_HPT = hpt1 }
-- Space-saving: delete the old HPT entry
-- main Haskell source file. Deleting it
-- would force .. (what?? --SDM)
old_hpt1 | isBootSummary mod = old_hpt
- | otherwise = delModuleEnv old_hpt this_mod
+ | otherwise = delFromUFM old_hpt this_mod
; (restOK, hsc_env2, modOKs)
<- upsweep' hsc_env1 old_hpt1 stable_mods cleanup
-- successful. If no compilation happened, return the old Linkable.
upsweep_mod :: HscEnv
-> HomePackageTable
- -> ([Module],[Module])
+ -> ([ModuleName],[ModuleName])
-> 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 mod_index nmods
- = do
- let
+ = let
+ this_mod_name = ms_mod_name summary
this_mod = ms_mod summary
mb_obj_date = ms_obj_date summary
obj_fn = ml_obj_file (ms_location summary)
hs_date = ms_hs_date summary
+ is_stable_obj = this_mod_name `elem` stable_obj
+ is_stable_bco = this_mod_name `elem` stable_bco
+
+ old_hmi = lookupUFM old_hpt this_mod_name
+
+ -- We're using the dflags for this module now, obtained by
+ -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.
+ dflags = ms_hspp_opts summary
+ prevailing_target = hscTarget (hsc_dflags hsc_env)
+ local_target = hscTarget dflags
+
+ -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that
+ -- we don't do anything dodgy: these should only work to change
+ -- from -fvia-C to -fasm and vice-versa, otherwise we could
+ -- end up trying to link object code to byte code.
+ target = if prevailing_target /= local_target
+ && (not (isObjectTarget prevailing_target)
+ || not (isObjectTarget local_target))
+ then prevailing_target
+ else local_target
+
+ -- store the corrected hscTarget into the summary
+ summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }
+
+ -- The old interface is ok if
+ -- a) we're compiling a source file, and the old HPT
+ -- entry is for a source file
+ -- b) we're compiling a hs-boot file
+ -- Case (b) allows an hs-boot file to get the interface of its
+ -- real source file on the second iteration of the compilation
+ -- manager, but that does no harm. Otherwise the hs-boot file
+ -- will always be recompiled
+
+ mb_old_iface
+ = case old_hmi of
+ Nothing -> Nothing
+ Just hm_info | isBootSummary summary -> Just iface
+ | not (mi_boot iface) -> Just iface
+ | otherwise -> Nothing
+ where
+ iface = hm_iface hm_info
+
compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo)
- compile_it = upsweep_compile hsc_env old_hpt this_mod
- summary mod_index nmods
-
- case ghcMode (hsc_dflags hsc_env) of
- BatchCompile ->
- case () of
- -- Batch-compilating is easy: just check whether we have
- -- an up-to-date object file. If we do, then the compiler
- -- needs to do a recompilation check.
- _ | Just obj_date <- mb_obj_date, obj_date >= hs_date -> do
- linkable <-
- findObjectLinkable this_mod obj_fn obj_date
- compile_it (Just linkable)
-
- | otherwise ->
- compile_it Nothing
-
- interactive ->
- case () of
- _ | is_stable_obj, isJust old_hmi ->
- return old_hmi
+ compile_it = upsweep_compile hsc_env old_hpt this_mod_name
+ summary' mod_index nmods mb_old_iface
+
+ compile_it_discard_iface
+ = upsweep_compile hsc_env old_hpt this_mod_name
+ summary' mod_index nmods Nothing
+
+ in
+ case target of
+
+ _any
+ -- Regardless of whether we're generating object code or
+ -- byte code, we can always use an existing object file
+ -- if it is *stable* (see checkStability).
+ | is_stable_obj, isJust old_hmi ->
+ return old_hmi
-- object is stable, and we have an entry in the
-- old HPT: nothing to do
- | is_stable_obj, isNothing old_hmi -> do
- linkable <-
- findObjectLinkable this_mod obj_fn
+ | is_stable_obj, isNothing old_hmi -> do
+ linkable <- findObjectLinkable this_mod obj_fn
(expectJust "upseep1" mb_obj_date)
- compile_it (Just linkable)
+ compile_it (Just linkable)
-- object is stable, but we need to load the interface
-- off disk to make a HMI.
- | is_stable_bco ->
- ASSERT(isJust old_hmi) -- must be in the old_hpt
- return old_hmi
+ HscInterpreted
+ | is_stable_bco ->
+ ASSERT(isJust old_hmi) -- must be in the old_hpt
+ return old_hmi
-- BCO is stable: nothing to do
- | Just hmi <- old_hmi,
- Just l <- hm_linkable hmi, not (isObjectLinkable l),
- linkableTime l >= ms_hs_date summary ->
- compile_it (Just l)
+ | Just hmi <- old_hmi,
+ Just l <- hm_linkable hmi, not (isObjectLinkable l),
+ linkableTime l >= ms_hs_date summary ->
+ compile_it (Just l)
-- we have an old BCO that is up to date with respect
-- to the source: do a recompilation check as normal.
- | otherwise ->
- compile_it Nothing
+ | otherwise ->
+ compile_it Nothing
-- no existing code at all: we must recompile.
- where
- is_stable_obj = this_mod `elem` stable_obj
- is_stable_bco = this_mod `elem` stable_bco
- old_hmi = lookupModuleEnv old_hpt this_mod
+ -- When generating object code, if there's an up-to-date
+ -- object file on the disk, then we can use it.
+ -- However, if the object file is new (compared to any
+ -- linkable we had from a previous compilation), then we
+ -- must discard any in-memory interface, because this
+ -- means the user has compiled the source file
+ -- separately and generated a new interface, that we must
+ -- read from the disk.
+ --
+ obj | isObjectTarget obj,
+ Just obj_date <- mb_obj_date, obj_date >= hs_date -> do
+ case old_hmi of
+ Just hmi
+ | Just l <- hm_linkable hmi,
+ isObjectLinkable l && linkableTime l == obj_date
+ -> compile_it (Just l)
+ _otherwise -> do
+ linkable <- findObjectLinkable this_mod obj_fn obj_date
+ compile_it_discard_iface (Just linkable)
+
+ _otherwise ->
+ compile_it Nothing
+
-- Run hsc to compile a module
upsweep_compile hsc_env old_hpt this_mod 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
- -- entry is for a source file
- -- b) we're compiling a hs-boot file
- -- Case (b) allows an hs-boot file to get the interface of its
- -- real source file on the second iteration of the compilation
- -- manager, but that does no harm. Otherwise the hs-boot file
- -- will always be recompiled
-
- mb_old_iface
- = case lookupModuleEnv old_hpt this_mod of
- Nothing -> Nothing
- Just hm_info | isBootSummary summary -> Just iface
- | not (mi_boot iface) -> Just iface
- | otherwise -> Nothing
- where
- iface = hm_iface hm_info
-
- compresult <- compile hsc_env summary mb_old_linkable mb_old_iface
+ mb_old_iface
+ mb_old_linkable
+ = do
+ compresult <- compile hsc_env summary mb_old_linkable mb_old_iface
mod_index nmods
- case compresult of
+ case compresult of
-- Compilation failed. Compile may still have updated the PCS, tho.
CompErrs -> return Nothing
-- Filter modules in the HPT
-retainInTopLevelEnvs :: [Module] -> HomePackageTable -> HomePackageTable
+retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
retainInTopLevelEnvs keep_these hpt
- = mkModuleEnv [ (mod, expectJust "retain" mb_mod_info)
+ = listToUFM [ (mod, expectJust "retain" mb_mod_info)
| mod <- keep_these
- , let mb_mod_info = lookupModuleEnv hpt mod
+ , let mb_mod_info = lookupUFM hpt mod
, isJust mb_mod_info ]
-- ---------------------------------------------------------------------------
topSortModuleGraph
:: Bool -- Drop hi-boot nodes? (see below)
-> [ModSummary]
- -> Maybe Module
+ -> Maybe ModuleName
-> [SCC ModSummary]
-- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
-- The resulting list of strongly-connected-components is in topologically
| otherwise = throwDyn (ProgramError "module does not exist")
moduleGraphNodes :: Bool -> [ModSummary]
- -> ([(ModSummary, Int, [Int])], HscSource -> Module -> Maybe Int)
+ -> ([(ModSummary, Int, [Int])], HscSource -> ModuleName -> Maybe Int)
moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key)
where
-- Drop hs-boot nodes by using HsSrcFile as the key
-- We use integers as the keys for the SCC algorithm
nodes :: [(ModSummary, Int, [Int])]
- nodes = [(s, expectJust "topSort" (lookup_key (ms_hsc_src s) (ms_mod s)),
+ nodes = [(s, expectJust "topSort" $
+ lookup_key (ms_hsc_src s) (ms_mod_name s),
out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++
- out_edge_keys HsSrcFile (map unLoc (ms_imps s)) )
+ out_edge_keys HsSrcFile (map unLoc (ms_imps s)) ++
+ (-- see [boot-edges] below
+ if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
+ then []
+ else case lookup_key HsBootFile (ms_mod_name s) of
+ Nothing -> []
+ Just k -> [k])
+ )
| s <- summaries
, not (isBootSummary s && drop_hs_boot_nodes) ]
-- Drop the hi-boot ones if told to do so
+ -- [boot-edges] if this is a .hs and there is an equivalent
+ -- .hs-boot, add a link from the former to the latter. This
+ -- has the effect of detecting bogus cases where the .hs-boot
+ -- depends on the .hs, by introducing a cycle. Additionally,
+ -- it ensures that we will always process the .hs-boot before
+ -- the .hs, and so the HomePackageTable will always have the
+ -- most up to date information.
+
key_map :: NodeMap Int
- key_map = listToFM ([(ms_mod s, ms_hsc_src s) | s <- summaries]
+ key_map = listToFM ([(moduleName (ms_mod s), ms_hsc_src s)
+ | s <- summaries]
`zip` [1..])
- lookup_key :: HscSource -> Module -> Maybe Int
+ lookup_key :: HscSource -> ModuleName -> Maybe Int
lookup_key hs_src mod = lookupFM key_map (mod, hs_src)
- out_edge_keys :: HscSource -> [Module] -> [Int]
+ out_edge_keys :: HscSource -> [ModuleName] -> [Int]
out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms
-- If we want keep_hi_boot_nodes, then we do lookup_key with
-- the IsBootInterface parameter True; else False
-type NodeKey = (Module, HscSource) -- The nodes of the graph are
+type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are
type NodeMap a = FiniteMap NodeKey a -- keyed by (mod, src_file_type) pairs
msKey :: ModSummary -> NodeKey
-msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (mod,boot)
+msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)
mkNodeMap :: [ModSummary] -> NodeMap ModSummary
mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries]
nodeMapElts :: NodeMap a -> [a]
nodeMapElts = eltsFM
+-- If there are {-# SOURCE #-} imports between strongly connected
+-- 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 :: DynFlags -> [SCC ModSummary] -> IO ()
+warnUnnecessarySourceImports dflags sccs =
+ printBagOfWarnings dflags (listToBag (concat (map (check.flattenSCC) sccs)))
+ where check ms =
+ let mods_in_this_cycle = map ms_mod_name ms in
+ [ warn m i | m <- ms, i <- ms_srcimps m,
+ unLoc i `notElem` mods_in_this_cycle ]
+
+ warn :: ModSummary -> Located ModuleName -> WarnMsg
+ warn ms (L loc mod) =
+ mkPlainErrMsg loc
+ (ptext SLIT("Warning: {-# SOURCE #-} unnecessary in import of ")
+ <+> quotes (ppr mod))
+
-----------------------------------------------------------------------------
-- Downsweep (dependency analysis)
downsweep :: HscEnv
-> [ModSummary] -- Old summaries
- -> [Module] -- Ignore dependencies on these; treat
+ -> [ModuleName] -- Ignore dependencies on these; treat
-- them as if they were package modules
-> Bool -- True <=> allow multiple targets to have
-- the same module name; this is
dup_roots :: [[ModSummary]] -- Each at least of length 2
dup_roots = filterOut isSingleton (nodeMapElts root_map)
- loop :: [(Located Module,IsBootInterface)]
+ loop :: [(Located ModuleName,IsBootInterface)]
-- Work list: process these modules
-> NodeMap [ModSummary]
-- Visited set; the range is a list because
mkRootMap summaries = addListToFM_C (++) emptyFM
[ (msKey s, [s]) | s <- summaries ]
-msDeps :: ModSummary -> [(Located Module, IsBootInterface)]
+msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]
-- (msDeps s) returns the dependencies of the ModSummary s.
-- A wrinkle is that for a {-# SOURCE #-} import we return
-- *both* the hs-boot file
(dflags', hspp_fn, buf)
<- preprocessFile dflags file mb_phase maybe_buf
- (srcimps,the_imps, L _ mod) <- getImports dflags' buf hspp_fn
+ (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn
-- Make a ModLocation for this file
- location <- mkHomeModLocation dflags mod file
+ location <- mkHomeModLocation dflags mod_name file
-- Tell the Finder cache where it is, so that subsequent calls
-- to findModule will find it, even if it's not on any search path
- addHomeModuleToFinder hsc_env mod location
+ mod <- addHomeModuleToFinder hsc_env mod_name location
src_timestamp <- case maybe_buf of
Just (_,t) -> return t
:: HscEnv
-> NodeMap ModSummary -- Map of old summaries
-> IsBootInterface -- True <=> a {-# SOURCE #-} import
- -> Located Module -- Imported module to be summarised
+ -> Located ModuleName -- Imported module to be summarised
-> Maybe (StringBuffer, ClockTime)
- -> [Module] -- Modules to exclude
+ -> [ModuleName] -- Modules to exclude
-> IO (Maybe ModSummary) -- Its new summary
summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf excl_mods
obj_timestamp <- getObjTimestamp location is_boot
return (Just old_summary{ ms_obj_date = obj_timestamp })
| otherwise =
- -- source changed: find and re-summarise. We call the finder
- -- again, because the user may have moved the source file.
- new_summary location src_fn src_timestamp
+ -- source changed: re-summarise.
+ new_summary location (ms_mod old_summary) src_fn src_timestamp
find_it = do
-- Don't use the Finder's cache this time. If the module was
-- search path, so we want to consider it to be a home module. If
-- the module was previously a home module, it may have moved.
uncacheModule hsc_env wanted_mod
- found <- findModule hsc_env wanted_mod True {-explicit-}
+ found <- findImportedModule hsc_env wanted_mod Nothing
case found of
- Found location pkg
- | not (isHomePackage pkg) -> return Nothing
- -- Drop external-pkg
- | isJust (ml_hs_file location) -> just_found location
+ Found location mod
+ | isJust (ml_hs_file location) ->
-- Home package
+ just_found location mod
+ | otherwise ->
+ -- Drop external-pkg
+ ASSERT(modulePackageId mod /= thisPackage dflags)
+ return Nothing
+ where
+
err -> noModError dflags loc wanted_mod err
-- Not found
- just_found location = do
+ just_found location mod = 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
maybe_t <- modificationTimeIfExists src_fn
case maybe_t of
Nothing -> noHsFileErr loc src_fn
- Just t -> new_summary location' src_fn t
+ Just t -> new_summary location' mod src_fn t
- new_summary location src_fn src_timestamp
+ new_summary location mod src_fn src_timestamp
= do
-- Preprocess the source file and get its imports
-- The dflags' contains the OPTIONS pragmas
-- Find the object timestamp, and return the summary
obj_timestamp <- getObjTimestamp location is_boot
- return (Just ( ModSummary { ms_mod = wanted_mod,
+ return (Just ( ModSummary { ms_mod = mod,
ms_hsc_src = hsc_src,
ms_location = location,
ms_hspp_file = hspp_fn,
-- Error messages
-----------------------------------------------------------------------------
-noModError :: DynFlags -> SrcSpan -> Module -> FindResult -> IO ab
+noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
-- ToDo: we don't have a proper line number for this error
noModError dflags loc wanted_mod err
- = throwDyn $ mkPlainErrMsg loc $ cantFindError dflags wanted_mod err
+ = throwDyn $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
noHsFileErr loc path
= throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path
-- Note: if you change the working directory, you should also unload
-- the current program (set targets to empty, followed by load).
workingDirectoryChanged :: Session -> IO ()
-workingDirectoryChanged s = withSession s $ \hsc_env ->
- flushFinderCache (hsc_FC hsc_env)
+workingDirectoryChanged s = withSession s $ flushFinderCaches
-- -----------------------------------------------------------------------------
-- inspecting the session
getModuleGraph :: Session -> IO ModuleGraph -- ToDo: DiGraph ModSummary
getModuleGraph s = withSession s (return . hsc_mod_graph)
-isLoaded :: Session -> Module -> IO Bool
+isLoaded :: Session -> ModuleName -> IO Bool
isLoaded s m = withSession s $ \hsc_env ->
- return $! isJust (lookupModuleEnv (hsc_HPT hsc_env) m)
+ return $! isJust (lookupUFM (hsc_HPT hsc_env) m)
getBindings :: Session -> IO [TyThing]
-getBindings s = withSession s (return . nameEnvElts . ic_type_env . hsc_IC)
+getBindings s = withSession s $ \hsc_env ->
+ -- we have to implement the shadowing behaviour of ic_tmp_ids here
+ -- (see InteractiveContext) and the quickest way is to use an OccEnv.
+ let
+ tmp_ids = ic_tmp_ids (hsc_IC hsc_env)
+ filtered = foldr f (const []) tmp_ids emptyUniqSet
+ f id rest set
+ | uniq `elementOfUniqSet` set = rest set
+ | otherwise = AnId id : rest (addOneToUniqSet set uniq)
+ where uniq = getUnique (nameOccName (idName id))
+ in
+ return filtered
getPrintUnqual :: Session -> IO PrintUnqualified
getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC)
-- | Container for information about a 'Module'.
data ModuleInfo = ModuleInfo {
minf_type_env :: TypeEnv,
- minf_exports :: NameSet,
+ minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails?
minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod
minf_instances :: [Instance]
+#ifdef GHCI
+ ,minf_modBreaks :: ModBreaks
+#endif
-- ToDo: this should really contain the ModIface too
}
-- We don't want HomeModInfo here, because a ModuleInfo applies
getModuleInfo s mdl = withSession s $ \hsc_env -> do
let mg = hsc_mod_graph hsc_env
if mdl `elem` map ms_mod mg
- then getHomeModuleInfo hsc_env mdl
+ then getHomeModuleInfo hsc_env (moduleName mdl)
else do
{- if isHomeModule (hsc_dflags hsc_env) mdl
then return Nothing
getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
getPackageModuleInfo hsc_env mdl = do
#ifdef GHCI
- (_msgs, mb_names) <- getModuleExports hsc_env mdl
- case mb_names of
+ (_msgs, mb_avails) <- getModuleExports hsc_env mdl
+ case mb_avails of
Nothing -> return Nothing
- Just names -> do
+ Just avails -> do
eps <- readIORef (hsc_EPS hsc_env)
let
+ names = availsToNameSet avails
pte = eps_PTE eps
- n_list = nameSetToList names
- tys = [ ty | name <- n_list,
+ tys = [ ty | name <- concatMap availNames avails,
Just ty <- [lookupTypeEnv pte name] ]
--
return (Just (ModuleInfo {
minf_type_env = mkTypeEnv tys,
minf_exports = names,
- minf_rdr_env = Just $! nameSetToGlobalRdrEnv names mdl,
- minf_instances = error "getModuleInfo: instances for package module unimplemented"
+ minf_rdr_env = Just $! nameSetToGlobalRdrEnv names (moduleName mdl),
+ minf_instances = error "getModuleInfo: instances for package module unimplemented",
+ minf_modBreaks = emptyModBreaks
}))
#else
-- bogusly different for non-GHCI (ToDo)
#endif
getHomeModuleInfo hsc_env mdl =
- case lookupModuleEnv (hsc_HPT hsc_env) mdl of
+ case lookupUFM (hsc_HPT hsc_env) mdl of
Nothing -> return Nothing
Just hmi -> do
let details = hm_details hmi
return (Just (ModuleInfo {
minf_type_env = md_types details,
- minf_exports = md_exports details,
+ minf_exports = availsToNameSet (md_exports details),
minf_rdr_env = mi_globals $! hm_iface hmi,
minf_instances = md_insts details
+#ifdef GHCI
+ ,minf_modBreaks = md_modBreaks details
+#endif
}))
-- | The list of top-level entities defined in a module
modInfoIsExportedName minf name = elemNameSet name (minf_exports minf)
modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified
-modInfoPrintUnqualified minf = fmap unQualInScope (minf_rdr_env minf)
+modInfoPrintUnqualified minf = fmap mkPrintUnqualified (minf_rdr_env minf)
modInfoLookupName :: Session -> ModuleInfo -> Name -> IO (Maybe TyThing)
modInfoLookupName s minf name = withSession s $ \hsc_env -> do
Just tyThing -> return (Just tyThing)
Nothing -> do
eps <- readIORef (hsc_EPS hsc_env)
- return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name
+ return $! lookupType (hsc_dflags hsc_env)
+ (hsc_HPT hsc_env) (eps_PTE eps) name
+
+#ifdef GHCI
+modInfoModBreaks = minf_modBreaks
+#endif
isDictonaryId :: Id -> Bool
isDictonaryId id
lookupGlobalName :: Session -> Name -> IO (Maybe TyThing)
lookupGlobalName s name = withSession s $ \hsc_env -> do
eps <- readIORef (hsc_EPS hsc_env)
- return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name
+ return $! lookupType (hsc_dflags hsc_env)
+ (hsc_HPT hsc_env) (eps_PTE eps) name
-- -----------------------------------------------------------------------------
-- Misc exported utils
-- -----------------------------------------------------------------------------
-- Interactive evaluation
-#ifdef GHCI
+-- | Takes a 'ModuleName' and possibly a 'PackageId', and consults the
+-- filesystem and package database to find the corresponding 'Module',
+-- using the algorithm that is used for an @import@ declaration.
+findModule :: Session -> ModuleName -> Maybe PackageId -> IO Module
+findModule s mod_name maybe_pkg = withSession s $ \hsc_env ->
+ findModule' hsc_env mod_name maybe_pkg
--- | Set the interactive evaluation context.
---
--- Setting the context doesn't throw away any bindings; the bindings
--- we've built up in the InteractiveContext simply move to the new
--- module. They always shadow anything in scope in the current context.
-setContext :: Session
- -> [Module] -- entire top level scope of these modules
- -> [Module] -- exports only of these modules
- -> IO ()
-setContext (Session ref) toplevs exports = do
- hsc_env <- readIORef ref
- let old_ic = hsc_IC hsc_env
- hpt = hsc_HPT hsc_env
-
- mapM_ (checkModuleExists hsc_env hpt) exports
- export_env <- mkExportEnv hsc_env exports
- toplev_envs <- mapM (mkTopLevEnv hpt) toplevs
- let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
- writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplevs,
- ic_exports = exports,
- ic_rn_gbl_env = all_env }}
-
-
--- Make a GlobalRdrEnv based on the exports of the modules only.
-mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
-mkExportEnv hsc_env mods = do
- stuff <- mapM (getModuleExports hsc_env) mods
- let
- (_msgs, mb_name_sets) = unzip stuff
- gres = [ nameSetToGlobalRdrEnv name_set mod
- | (Just name_set, mod) <- zip mb_name_sets mods ]
- --
- return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
-
-nameSetToGlobalRdrEnv :: NameSet -> Module -> GlobalRdrEnv
-nameSetToGlobalRdrEnv names mod =
- mkGlobalRdrEnv [ GRE { gre_name = name, gre_prov = vanillaProv mod }
- | name <- nameSetToList names ]
-
-vanillaProv :: Module -> Provenance
--- We're building a GlobalRdrEnv as if the user imported
--- all the specified modules into the global interactive module
-vanillaProv mod = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
- where
- decl = ImpDeclSpec { is_mod = mod, is_as = mod,
- is_qual = False,
- is_dloc = srcLocSpan interactiveSrcLoc }
-
-checkModuleExists :: HscEnv -> HomePackageTable -> Module -> IO ()
-checkModuleExists hsc_env hpt mod =
- case lookupModuleEnv hpt mod of
- Just mod_info -> return ()
+findModule' hsc_env mod_name maybe_pkg =
+ let
+ dflags = hsc_dflags hsc_env
+ hpt = hsc_HPT hsc_env
+ this_pkg = thisPackage dflags
+ in
+ case lookupUFM hpt mod_name of
+ Just mod_info -> return (mi_module (hm_iface mod_info))
_not_a_home_module -> do
- res <- findPackageModule hsc_env mod True
+ res <- findImportedModule hsc_env mod_name maybe_pkg
case res of
- Found _ _ -> return ()
- err -> let msg = cantFindError (hsc_dflags hsc_env) mod err in
+ Found _ m | modulePackageId m /= this_pkg -> return m
+ | otherwise -> throwDyn (CmdLineError (showSDoc $
+ text "module" <+> pprModule m <+>
+ text "is not loaded"))
+ err -> let msg = cannotFindModule dflags mod_name err in
throwDyn (CmdLineError (showSDoc msg))
-
-mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
-mkTopLevEnv hpt modl
- = case lookupModuleEnv hpt modl of
- Nothing ->
- throwDyn (ProgramError ("mkTopLevEnv: not a home module "
- ++ showSDoc (pprModule modl)))
- Just details ->
- case mi_globals (hm_iface details) of
- Nothing ->
- throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
- ++ showSDoc (pprModule modl)))
- Just env -> return env
-
--- | Get the interactive evaluation context, consisting of a pair of the
--- set of modules from which we take the full top-level scope, and the set
--- of modules from which we take just the exports respectively.
-getContext :: Session -> IO ([Module],[Module])
-getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
- return (ic_toplev_scope ic, ic_exports ic))
-
--- | Returns 'True' if the specified module is interpreted, and hence has
--- its full top-level scope available.
-moduleIsInterpreted :: Session -> Module -> IO Bool
-moduleIsInterpreted s modl = withSession s $ \h ->
- case lookupModuleEnv (hsc_HPT h) modl of
- Just details -> return (isJust (mi_globals (hm_iface details)))
- _not_a_home_module -> return False
-
--- | Looks up an identifier in the current interactive context (for :info)
-getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
-getInfo s name = withSession s $ \hsc_env -> tcRnGetInfo hsc_env name
-
--- | Returns all names in scope in the current interactive context
-getNamesInScope :: Session -> IO [Name]
-getNamesInScope s = withSession s $ \hsc_env -> do
- return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
-
-getRdrNamesInScope :: Session -> IO [RdrName]
-getRdrNamesInScope s = withSession s $ \hsc_env -> do
- let env = ic_rn_gbl_env (hsc_IC hsc_env)
- return (concat (map greToRdrNames (globalRdrEnvElts env)))
-
--- ToDo: move to RdrName
-greToRdrNames :: GlobalRdrElt -> [RdrName]
-greToRdrNames GRE{ gre_name = name, gre_prov = prov }
- = case prov of
- LocalDef -> [unqual]
- Imported specs -> concat (map do_spec (map is_decl specs))
- where
- occ = nameOccName name
- unqual = Unqual occ
- do_spec decl_spec
- | is_qual decl_spec = [qual]
- | otherwise = [unqual,qual]
- where qual = Qual (is_as decl_spec) occ
-
--- | Parses a string as an identifier, and returns the list of 'Name's that
--- the identifier can refer to in the current interactive context.
-parseName :: Session -> String -> IO [Name]
-parseName s str = withSession s $ \hsc_env -> do
- maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
- case maybe_rdr_name of
- Nothing -> return []
- Just (L _ rdr_name) -> do
- mb_names <- tcRnLookupRdrName hsc_env rdr_name
- case mb_names of
- Nothing -> return []
- Just ns -> return ns
- -- ToDo: should return error messages
-
--- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any
--- entity known to GHC, including 'Name's defined using 'runStmt'.
-lookupName :: Session -> Name -> IO (Maybe TyThing)
-lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name
-
--- -----------------------------------------------------------------------------
--- Getting the type of an expression
-
--- | Get the type of an expression
-exprType :: Session -> String -> IO (Maybe Type)
-exprType s expr = withSession s $ \hsc_env -> do
- maybe_stuff <- hscTcExpr hsc_env expr
- case maybe_stuff of
- Nothing -> return Nothing
- Just ty -> return (Just tidy_ty)
- where
- tidy_ty = tidyType emptyTidyEnv ty
-
--- -----------------------------------------------------------------------------
--- Getting the kind of a type
-
--- | Get the kind of a type
-typeKind :: Session -> String -> IO (Maybe Kind)
-typeKind s str = withSession s $ \hsc_env -> do
- maybe_stuff <- hscKcType hsc_env str
- case maybe_stuff of
- Nothing -> return Nothing
- Just kind -> return (Just kind)
-
------------------------------------------------------------------------------
--- cmCompileExpr: compile an expression and deliver an HValue
-
-compileExpr :: Session -> String -> IO (Maybe HValue)
-compileExpr s expr = withSession s $ \hsc_env -> do
- maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
- case maybe_stuff of
- Nothing -> return Nothing
- Just (new_ic, names, hval) -> do
- -- Run it!
- hvals <- (unsafeCoerce# hval) :: IO [HValue]
-
- case (names,hvals) of
- ([n],[hv]) -> return (Just hv)
- _ -> panic "compileExpr"
-
--- -----------------------------------------------------------------------------
--- running a statement interactively
-
-data RunResult
- = RunOk [Name] -- ^ names bound by this evaluation
- | RunFailed -- ^ statement failed compilation
- | RunException Exception -- ^ statement raised an exception
-
--- | Run a statement in the current interactive context. Statemenet
--- may bind multple values.
-runStmt :: Session -> String -> IO RunResult
-runStmt (Session ref) expr
- = do
- hsc_env <- readIORef ref
-
- -- Turn off -fwarn-unused-bindings when running a statement, to hide
- -- warnings about the implicit bindings we introduce.
- let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
- hsc_env' = hsc_env{ hsc_dflags = dflags' }
-
- maybe_stuff <- hscStmt hsc_env' expr
-
- case maybe_stuff of
- Nothing -> return RunFailed
- Just (new_hsc_env, names, hval) -> do
-
- let thing_to_run = unsafeCoerce# hval :: IO [HValue]
- either_hvals <- sandboxIO thing_to_run
-
- case either_hvals of
- Left e -> do
- -- on error, keep the *old* interactive context,
- -- so that 'it' is not bound to something
- -- that doesn't exist.
- return (RunException e)
-
- Right hvals -> do
- -- Get the newly bound things, and bind them.
- -- Don't need to delete any shadowed bindings;
- -- the new ones override the old ones.
- extendLinkEnv (zip names hvals)
-
- writeIORef ref new_hsc_env
- return (RunOk names)
-
--- When running a computation, we redirect ^C exceptions to the running
--- thread. ToDo: we might want a way to continue even if the target
--- thread doesn't die when it receives the exception... "this thread
--- is not responding".
-sandboxIO :: IO a -> IO (Either Exception a)
-sandboxIO thing = do
- m <- newEmptyMVar
- ts <- takeMVar interruptTargetThread
- child <- forkIO (do res <- Exception.try thing; putMVar m res)
- putMVar interruptTargetThread (child:ts)
- takeMVar m `finally` modifyMVar_ interruptTargetThread (return.tail)
-
-{-
--- This version of sandboxIO runs the expression in a completely new
--- RTS main thread. It is disabled for now because ^C exceptions
--- won't be delivered to the new thread, instead they'll be delivered
--- to the (blocked) GHCi main thread.
-
--- SLPJ: when re-enabling this, reflect a wrong-stat error as an exception
-
-sandboxIO :: IO a -> IO (Either Int (Either Exception a))
-sandboxIO thing = do
- st_thing <- newStablePtr (Exception.try thing)
- alloca $ \ p_st_result -> do
- stat <- rts_evalStableIO st_thing p_st_result
- freeStablePtr st_thing
- if stat == 1
- then do st_result <- peek p_st_result
- result <- deRefStablePtr st_result
- freeStablePtr st_result
- return (Right result)
- else do
- return (Left (fromIntegral stat))
-
-foreign import "rts_evalStableIO" {- safe -}
- rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt
- -- more informative than the C type!
--}
-
------------------------------------------------------------------------------
--- show a module and it's source/object filenames
-
-showModule :: Session -> ModSummary -> IO String
-showModule s mod_summary = withSession s $ \hsc_env -> do
- case lookupModuleEnv (hsc_HPT hsc_env) (ms_mod mod_summary) of
- Nothing -> panic "missing linkable"
- Just mod_info -> return (showModMsg (hscTarget (hsc_dflags hsc_env)) (not obj_linkable) mod_summary)
- where
- obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
-
-#endif /* GHCI */