module GHC (
-- * Initialisation
- Session,
defaultErrorHandler,
defaultCleanupHandler,
- newSession,
+
+ -- * GHC Monad
+ Ghc, GhcT, GhcMonad(..),
+ runGhc, runGhcT, initGhcMonad,
+ gcatch, gbracket, gfinally,
+ clearWarnings, getWarnings, hasWarnings,
+ printExceptionAndWarnings, printWarnings,
+ handleSourceError, defaultCallbacks, GhcApiCallbacks(..),
+ needsTemplateHaskell,
-- * Flags and settings
- DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt,
+ DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt,
+ GhcMode(..), GhcLink(..), defaultObjectTarget,
parseDynamicFlags,
getSessionDynFlags,
setSessionDynFlags,
+ parseStaticFlags,
-- * Targets
Target(..), TargetId(..), Phase,
guessTarget,
-- * Extending the program scope
- extendGlobalRdrScope, -- :: Session -> [GlobalRdrElt] -> IO ()
- setGlobalRdrScope, -- :: Session -> [GlobalRdrElt] -> IO ()
- extendGlobalTypeScope, -- :: Session -> [Id] -> IO ()
- setGlobalTypeScope, -- :: Session -> [Id] -> IO ()
+ extendGlobalRdrScope,
+ setGlobalRdrScope,
+ extendGlobalTypeScope,
+ setGlobalTypeScope,
-- * Loading\/compiling the program
depanal,
- load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal
+ load, loadWithLogger, LoadHowMuch(..),
+ SuccessFlag(..), succeeded, failed,
+ defaultWarnErrLogger, WarnErrLogger,
workingDirectoryChanged,
- checkModule, CheckedModule(..),
- TypecheckedSource, ParsedSource, RenamedSource,
+ parseModule, typecheckModule, desugarModule, loadModule,
+ ParsedModule(..), TypecheckedModule(..), DesugaredModule(..),
+ TypecheckedSource, ParsedSource, RenamedSource, -- ditto
+ TypecheckedMod, ParsedMod,
+ moduleInfo, renamedSource, typecheckedSource,
+ parsedSource, coreModule,
+ compileToCoreModule, compileToCoreSimplified,
+ compileCoreToObj,
+ getModSummary,
-- * Parsing Haddock comments
parseHaddockComment,
getModuleInfo,
modInfoTyThings,
modInfoTopLevelScope,
- modInfoPrintUnqualified,
- modInfoExports,
+ modInfoExports,
modInfoInstances,
modInfoIsExportedName,
modInfoLookupName,
lookupGlobalName,
+ findGlobalAnns,
+ mkPrintUnqualifiedForModule,
+
+ -- * Querying the environment
+ packageDbModules,
-- * Printing
PrintUnqualified, alwaysQualify,
setContext, getContext,
getNamesInScope,
getRdrNamesInScope,
+ getGRE,
moduleIsInterpreted,
getInfo,
exprType,
typeKind,
parseName,
- RunResult(..),
- runStmt,
+ RunResult(..),
+ runStmt, SingleStep(..),
+ resume,
+ Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
+ resumeHistory, resumeHistoryIx),
+ History(historyBreakInfo, historyEnclosingDecl),
+ GHC.getHistorySpan, getHistoryModule,
+ getResumeContext,
+ abandon, abandonAll,
+ InteractiveEval.back,
+ InteractiveEval.forward,
showModule,
- compileExpr, HValue, dynCompileExpr,
+ isModuleInterpreted,
+ InteractiveEval.compileExpr, HValue, dynCompileExpr,
lookupName,
+ GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
+ modInfoModBreaks,
+ ModBreaks(..), BreakIndex,
+ BreakInfo(breakInfo_number, breakInfo_module),
+ BreakArray, setBreakOn, setBreakOff, getBreak,
#endif
-- * Abstract syntax elements
-- ** Names
Name,
- nameModule, nameParent_maybe, pprParenSymName, nameSrcLoc,
+ isExternalName, nameModule, pprParenSymName, nameSrcSpan,
NamedThing(..),
RdrName(Qual,Unqual),
instanceDFunId, pprInstance, pprInstanceHdr,
-- ** Types and Kinds
- Type, dropForAlls, splitForAllTys, funResultTy, pprParendType,
+ Type, 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,
+
+ -- ** Located
+ Located(..),
+
+ -- *** Constructing Located
+ noLoc, mkGeneralLocated,
+
+ -- *** Deconstructing Located
+ getLoc, unLoc,
+
+ -- *** Combining and comparing Located values
+ eqLocated, cmpLocated, combineLocs, addCLoc,
+ leftmost_smallest, leftmost_largest, rightmost,
+ spans, isSubspanOf,
-- * Exceptions
GhcException(..), showGhcException,
+ -- * Token stream manipulations
+ Token,
+ getTokenStream, getRichTokenStream,
+ showRichTokenStream, addSourceToTokens,
+
-- * Miscellaneous
- sessionHscEnv,
+ --sessionHscEnv,
cyclicModuleErr,
) where
#ifdef GHCI
import qualified Linker
-import Data.Dynamic ( Dynamic )
-import Linker ( HValue, extendLinkEnv )
-import TcRnDriver ( tcRnLookupRdrName, tcRnGetInfo,
- tcRnLookupName, getModuleExports )
-import RdrName ( plusGlobalRdrEnv, Provenance(..),
- ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
- mkGlobalRdrEnv )
-import HscMain ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType )
-import Name ( nameOccName )
-import Type ( tidyType )
-import VarEnv ( emptyTidyEnv )
-import GHC.Exts ( unsafeCoerce# )
+import Linker ( HValue )
+import ByteCodeInstr
+import BreakArray
+import NameSet
+import InteractiveEval
+import TcRnDriver
#endif
-import Packages ( initPackages )
-import NameSet ( NameSet, nameSetToList, elemNameSet )
-import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..),
- globalRdrEnvElts, extendGlobalRdrEnv,
- emptyGlobalRdrEnv )
-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 TcIface
+import TcRnTypes hiding (LIE)
+import TcRnMonad ( initIfaceCheck )
+import Packages
+import NameSet
+import RdrName
+import qualified HsSyn -- hack as we want to reexport the whole module
+import HsSyn hiding ((<.>))
+import Type hiding (typeKind)
+import TcType hiding (typeKind)
+import Id
+import Var
import TysPrim ( alphaTyVars )
-import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
- isPrimTyCon, isFunTyCon, isOpenTyCon, tyConArity,
- tyConTyVars, tyConDataCons, synTyConDefn,
- synTyConType, synTyConResKind )
-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 )
+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 InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr,
+ emptyInstEnv )
+import FamInstEnv ( emptyFamInstEnv )
import SrcLoc
+--import CoreSyn
+import TidyPgm
import DriverPipeline
-import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase )
-import HeaderInfo ( getImports, getOptions )
+import DriverPhases ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase )
+import HeaderInfo
import Finder
-import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) )
+import HscMain
import HscTypes
import DynFlags
+import StaticFlagParser
+import qualified StaticFlags
import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
cleanTempDirs )
+import Annotations
import Module
-import UniqFM
-import PackageConfig ( PackageId, stringToPackageId )
+import LazyUniqFM
+import qualified UniqFM as UFM
+import UniqSet
+import Unique
import FiniteMap
import Panic
import Digraph
-import Bag ( unitBag, listToBag )
-import ErrUtils ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg,
- mkPlainErrMsg, printBagOfErrors, printBagOfWarnings,
- WarnMsg )
-import qualified ErrUtils
+import Bag ( unitBag, listToBag, emptyBag, isEmptyBag )
+import ErrUtils
+import MonadUtils
import Util
-import StringBuffer ( StringBuffer, hGetStringBuffer )
+import StringBuffer ( StringBuffer, hGetStringBuffer, nextChar )
import Outputable
import BasicTypes
-import TcType ( tcSplitSigmaTy, isDictTy )
import Maybes ( expectJust, mapCatMaybes )
-import HaddockParse ( parseHaddockParagraphs, parseHaddockString )
+import HaddockParse
import HaddockLex ( tokenise )
+import FastString
+import Lexer
import Control.Concurrent
-import System.Directory ( getModificationTime, doesFileExist )
-import Data.Maybe ( isJust, isNothing )
-import Data.List ( partition, nub )
+import System.Directory ( getModificationTime, doesFileExist,
+ getCurrentDirectory )
+import Data.Maybe
+import Data.List
import qualified Data.List as List
-import Control.Monad ( unless, when )
+import Data.Typeable ( Typeable )
+import Data.Word ( Word8 )
+import Control.Monad
import System.Exit ( exitWith, ExitCode(..) )
-import System.Time ( ClockTime )
-import Control.Exception as Exception hiding (handle)
+import System.Time ( ClockTime, getClockTime )
+import Exception
import Data.IORef
+import System.FilePath
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
-- Unless you want to handle exceptions yourself, you should wrap this around
-- the top level of your program. The default handlers output the error
-- message(s) to stderr and exit cleanly.
-defaultErrorHandler :: DynFlags -> IO a -> IO a
-defaultErrorHandler dflags inner =
+defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => DynFlags -> m a -> m a
+defaultErrorHandler dflags inner =
-- top-level exception handler: any unrecognised exception is a compiler bug.
- handle (\exception -> do
- hFlush stdout
- case exception of
- -- an IO exception probably isn't our fault, so don't panic
- IOException _ ->
- fatalErrorMsg dflags (text (show exception))
- AsyncException StackOverflow ->
- fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
- _other ->
- fatalErrorMsg dflags (text (show (Panic (show exception))))
- exitWith (ExitFailure 1)
+ ghandle (\exception -> liftIO $ do
+ hFlush stdout
+ case fromException exception of
+ -- an IO exception probably isn't our fault, so don't panic
+ Just (ioe :: IOException) ->
+ fatalErrorMsg dflags (text (show ioe))
+ _ -> case fromException exception of
+ Just StackOverflow ->
+ fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
+ _ -> case fromException exception of
+ Just (ex :: ExitCode) -> throw ex
+ _ ->
+ fatalErrorMsg dflags
+ (text (show (Panic (show exception))))
+ exitWith (ExitFailure 1)
) $
- -- program errors: messages with locations attached. Sometimes it is
- -- convenient to just throw these as exceptions.
- handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn)
- exitWith (ExitFailure 1)) $
-
-- error messages propagated as exceptions
- handleDyn (\dyn -> do
+ handleGhcException
+ (\ge -> liftIO $ do
hFlush stdout
- case dyn of
+ case ge of
PhaseFailed _ code -> exitWith code
Interrupted -> exitWith (ExitFailure 1)
- _ -> do fatalErrorMsg dflags (text (show (dyn :: GhcException)))
+ _ -> do fatalErrorMsg dflags (text (show ge))
exitWith (ExitFailure 1)
) $
inner
--- | Install a default cleanup handler to remove temporary files
--- deposited by a GHC run. This is seperate from
--- 'defaultErrorHandler', because you might want to override the error
--- handling, but still get the ordinary cleanup behaviour.
-defaultCleanupHandler :: DynFlags -> IO a -> IO a
-defaultCleanupHandler dflags inner =
+-- | Install a default cleanup handler to remove temporary files deposited by
+-- a GHC run. This is seperate from 'defaultErrorHandler', because you might
+-- want to override the error handling, but still get the ordinary cleanup
+-- behaviour.
+defaultCleanupHandler :: (ExceptionMonad m, MonadIO m) =>
+ DynFlags -> m a -> m a
+defaultCleanupHandler dflags inner =
-- make sure we clean up after ourselves
- later (unless (dopt Opt_KeepTmpFiles dflags) $
- do cleanTempFiles dflags
- cleanTempDirs dflags
+ inner `gonException`
+ (liftIO $ do
+ cleanTempFiles dflags
+ cleanTempDirs dflags
)
- -- exceptions will be blocked while we clean the temporary files,
+ -- 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 -> Maybe FilePath -> IO Session
-newSession mode mb_top_dir = do
+-- | Print the error message and all warnings. Useful inside exception
+-- handlers. Clears warnings after printing.
+printExceptionAndWarnings :: GhcMonad m => SourceError -> m ()
+printExceptionAndWarnings err = do
+ let errs = srcErrorMessages err
+ warns <- getWarnings
+ dflags <- getSessionDynFlags
+ if isEmptyBag errs
+ -- Empty errors means we failed due to -Werror. (Since this function
+ -- takes a source error as argument, we know for sure _some_ error
+ -- did indeed happen.)
+ then liftIO $ do
+ printBagOfWarnings dflags warns
+ printBagOfErrors dflags (unitBag warnIsErrorMsg)
+ else liftIO $ printBagOfErrors dflags errs
+ clearWarnings
+
+-- | Print all accumulated warnings using 'log_action'.
+printWarnings :: GhcMonad m => m ()
+printWarnings = do
+ dflags <- getSessionDynFlags
+ warns <- getWarnings
+ liftIO $ printBagOfWarnings dflags warns
+ clearWarnings
+
+-- | Run function for the 'Ghc' monad.
+--
+-- It initialises the GHC session and warnings via 'initGhcMonad'. Each call
+-- to this function will create a new session which should not be shared among
+-- several threads.
+--
+-- Any errors not handled inside the 'Ghc' action are propagated as IO
+-- exceptions.
+
+runGhc :: Maybe FilePath -- ^ See argument to 'initGhcMonad'.
+ -> Ghc a -- ^ The action to perform.
+ -> IO a
+runGhc mb_top_dir ghc = do
+ wref <- newIORef emptyBag
+ ref <- newIORef undefined
+ let session = Session ref wref
+ flip unGhc session $ do
+ initGhcMonad mb_top_dir
+ ghc
+ -- XXX: unregister interrupt handlers here?
+
+-- | Run function for 'GhcT' monad transformer.
+--
+-- It initialises the GHC session and warnings via 'initGhcMonad'. Each call
+-- to this function will create a new session which should not be shared among
+-- several threads.
+
+runGhcT :: (ExceptionMonad m, Functor m, MonadIO m) =>
+ Maybe FilePath -- ^ See argument to 'initGhcMonad'.
+ -> GhcT m a -- ^ The action to perform.
+ -> m a
+runGhcT mb_top_dir ghct = do
+ wref <- liftIO $ newIORef emptyBag
+ ref <- liftIO $ newIORef undefined
+ let session = Session ref wref
+ flip unGhcT session $ do
+ initGhcMonad mb_top_dir
+ ghct
+
+-- | Initialise a GHC session.
+--
+-- If you implement a custom 'GhcMonad' you must call this function in the
+-- monad run function. It will initialise the session variable and clear all
+-- warnings.
+--
+-- The first argument should point to the directory where GHC's library files
+-- reside. More precisely, this should be the output of @ghc --print-libdir@
+-- of the version of GHC the module using this API is compiled with. For
+-- portability, you should use the @ghc-paths@ package, available at
+-- <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/ghc-paths>.
+
+initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
+initGhcMonad mb_top_dir = do
-- catch ^C
- main_thread <- myThreadId
- putMVar interruptTargetThread [main_thread]
- installSignalHandlers
-
- dflags0 <- initSysTools mb_top_dir defaultDynFlags
- dflags <- initDynFlags dflags0
- env <- newHscEnv dflags{ ghcMode=mode }
- ref <- newIORef env
- return (Session ref)
-
--- tmp: this breaks the abstraction, but required because DriverMkDepend
--- needs to call the Finder. ToDo: untangle this.
-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
+ main_thread <- liftIO $ myThreadId
+ liftIO $ modifyMVar_ interruptTargetThread (return . (main_thread :))
+ liftIO $ installSignalHandlers
+
+ liftIO $ StaticFlags.initStaticOpts
+
+ dflags0 <- liftIO $ initDynFlags defaultDynFlags
+ dflags <- liftIO $ initSysTools mb_top_dir dflags0
+ env <- liftIO $ newHscEnv defaultCallbacks dflags
+ setSession env
+ clearWarnings
+
+defaultCallbacks :: GhcApiCallbacks
+defaultCallbacks =
+ GhcApiCallbacks {
+ reportModuleCompilationResult =
+ \_ mb_err -> defaultWarnErrLogger mb_err
+ }
-- -----------------------------------------------------------------------------
-- Flags & settings
-- | Grabs the DynFlags from the Session
-getSessionDynFlags :: Session -> IO DynFlags
-getSessionDynFlags s = withSession s (return . hsc_dflags)
+getSessionDynFlags :: GhcMonad m => m DynFlags
+getSessionDynFlags = withSession (return . hsc_dflags)
-- | Updates the DynFlags in a Session. This also reads
-- the package database (unless it has already been read),
-- 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' }
+setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageId]
+setSessionDynFlags dflags = do
+ (dflags', preload) <- liftIO $ initPackages dflags
+ modifySession (\h -> h{ 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.
-guessOutputFile :: Session -> IO ()
-guessOutputFile s = modifySession s $ \env ->
+guessOutputFile :: GhcMonad m => m ()
+guessOutputFile = modifySession $ \env ->
let dflags = hsc_dflags env
mod_graph = hsc_mod_graph env
- mainModuleSrcPath, guessedName :: Maybe String
+ mainModuleSrcPath :: Maybe String
mainModuleSrcPath = do
let isMain = (== mainModIs dflags) . ms_mod
[ms] <- return (filter isMain mod_graph)
ml_hs_file (ms_location ms)
- guessedName = fmap basenameOf mainModuleSrcPath
+ name = fmap dropExtension mainModuleSrcPath
+
+#if defined(mingw32_HOST_OS)
+ -- we must add the .exe extention unconditionally here, otherwise
+ -- when name has an extension of its own, the .exe extension will
+ -- not be added by DriverPipeline.exeFileName. See #2248
+ name_exe = fmap (<.> "exe") name
+#else
+ name_exe = name
+#endif
in
case outputFile dflags of
Just _ -> env
- Nothing -> env { hsc_dflags = dflags { outputFile = guessedName } }
+ Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } }
-- -----------------------------------------------------------------------------
-- Targets
-- | Sets the targets for this session. Each target may be a module name
-- or a filename. The targets correspond to the set of root modules for
-- the program\/library. Unloading the current program is achieved by
--- setting the current set of targets to be empty, followed by load.
-setTargets :: Session -> [Target] -> IO ()
-setTargets s targets = modifySession s (\h -> h{ hsc_targets = targets })
+-- setting the current set of targets to be empty, followed by 'load'.
+setTargets :: GhcMonad m => [Target] -> m ()
+setTargets targets = modifySession (\h -> h{ hsc_targets = targets })
--- | returns the current set of targets
-getTargets :: Session -> IO [Target]
-getTargets s = withSession s (return . hsc_targets)
+-- | Returns the current set of targets
+getTargets :: GhcMonad m => m [Target]
+getTargets = withSession (return . hsc_targets)
--- | Add another target
-addTarget :: Session -> Target -> IO ()
-addTarget s target
- = modifySession s (\h -> h{ hsc_targets = target : hsc_targets h })
+-- | Add another target.
+addTarget :: GhcMonad m => Target -> m ()
+addTarget target
+ = modifySession (\h -> h{ hsc_targets = target : hsc_targets h })
-- | Remove a target
-removeTarget :: Session -> TargetId -> IO ()
-removeTarget s target_id
- = modifySession s (\h -> h{ hsc_targets = filter (hsc_targets h) })
+removeTarget :: GhcMonad m => TargetId -> m ()
+removeTarget target_id
+ = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) })
where
- filter targets = [ t | t@(Target id _) <- targets, id /= target_id ]
+ filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ]
--- Attempts to guess what Target a string refers to. This function implements
--- the --make/GHCi command-line syntax for filenames:
+-- | Attempts to guess what Target a string refers to. This function
+-- implements the @--make@/GHCi command-line syntax for filenames:
+--
+-- - if the string looks like a Haskell source filename, then interpret it
+-- as such
--
--- - if the string looks like a Haskell source filename, then interpret
--- it as such
--- - if adding a .hs or .lhs suffix yields the name of an existing file,
--- then use that
--- - otherwise interpret the string as a module name
+-- - if adding a .hs or .lhs suffix yields the name of an existing file,
+-- then use that
--
-guessTarget :: String -> Maybe Phase -> IO Target
-guessTarget file (Just phase)
- = return (Target (TargetFile file (Just phase)) Nothing)
-guessTarget file Nothing
+-- - otherwise interpret the string as a module name
+--
+guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target
+guessTarget str (Just phase)
+ = return (Target (TargetFile str (Just phase)) True Nothing)
+guessTarget str Nothing
| isHaskellSrcFilename file
- = return (Target (TargetFile file Nothing) Nothing)
+ = return (target (TargetFile file Nothing))
| otherwise
- = do exists <- doesFileExist hs_file
+ = do exists <- liftIO $ doesFileExist hs_file
if exists
- then return (Target (TargetFile hs_file Nothing) Nothing)
+ then return (target (TargetFile hs_file Nothing))
else do
- exists <- doesFileExist lhs_file
+ exists <- liftIO $ doesFileExist lhs_file
if exists
- then return (Target (TargetFile lhs_file Nothing) Nothing)
+ then return (target (TargetFile lhs_file Nothing))
else do
- return (Target (TargetModule (mkModuleName file)) Nothing)
+ if looksLikeModuleName file
+ then return (target (TargetModule (mkModuleName file)))
+ else do
+ throwGhcException
+ (ProgramError (showSDoc $
+ text "target" <+> quotes (text file) <+>
+ text "is not a module name or a source file"))
where
- hs_file = file `joinFileExt` "hs"
- lhs_file = file `joinFileExt` "lhs"
+ (file,obj_allowed)
+ | '*':rest <- str = (rest, False)
+ | otherwise = (str, True)
+
+ hs_file = file <.> "hs"
+ lhs_file = file <.> "lhs"
+
+ target tid = Target tid obj_allowed Nothing
-- -----------------------------------------------------------------------------
-- Extending the program scope
-extendGlobalRdrScope :: Session -> [GlobalRdrElt] -> IO ()
-extendGlobalRdrScope session rdrElts
- = modifySession session $ \hscEnv ->
+extendGlobalRdrScope :: GhcMonad m => [GlobalRdrElt] -> m ()
+extendGlobalRdrScope rdrElts
+ = modifySession $ \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 ->
+setGlobalRdrScope :: GhcMonad m => [GlobalRdrElt] -> m ()
+setGlobalRdrScope rdrElts
+ = modifySession $ \hscEnv ->
hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv emptyGlobalRdrEnv rdrElts }
-extendGlobalTypeScope :: Session -> [Id] -> IO ()
-extendGlobalTypeScope session ids
- = modifySession session $ \hscEnv ->
+extendGlobalTypeScope :: GhcMonad m => [Id] -> m ()
+extendGlobalTypeScope ids
+ = modifySession $ \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 ->
+setGlobalTypeScope :: GhcMonad m => [Id] -> m ()
+setGlobalTypeScope ids
+ = modifySession $ \hscEnv ->
hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids }
-- -----------------------------------------------------------------------------
-- Parsing Haddock comments
parseHaddockComment :: String -> Either String (HsDoc RdrName)
-parseHaddockComment string = parseHaddockParagraphs (tokenise string)
+parseHaddockComment string =
+ case parseHaddockParagraphs (tokenise string) of
+ MyLeft x -> Left x
+ MyRight x -> Right x
-- -----------------------------------------------------------------------------
-- Loading the program
--- Perform a dependency analysis starting from the current targets
+-- | Perform a dependency analysis starting from the current targets
-- and update the session with the new module graph.
-depanal :: Session -> [ModuleName] -> Bool -> IO (Maybe ModuleGraph)
-depanal (Session ref) excluded_mods allow_dup_roots = do
- hsc_env <- readIORef ref
+--
+-- Dependency analysis entails parsing the @import@ directives and may
+-- therefore require running certain preprocessors.
+--
+-- Note that each 'ModSummary' in the module graph caches its 'DynFlags'.
+-- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the
+-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want to
+-- changes to the 'DynFlags' to take effect you need to call this function
+-- again.
+--
+depanal :: GhcMonad m =>
+ [ModuleName] -- ^ excluded modules
+ -> Bool -- ^ allow duplicate roots
+ -> m ModuleGraph
+depanal excluded_mods allow_dup_roots = do
+ hsc_env <- getSession
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 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
- Just mod_graph -> writeIORef ref hsc_env{ hsc_mod_graph = mod_graph }
- _ -> return ()
- return r
+ liftIO $ showPass dflags "Chasing dependencies"
+ liftIO $ debugTraceMsg dflags 2 (hcat [
+ text "Chasing modules from: ",
+ hcat (punctuate comma (map pprTarget targets))])
-{-
--- | The result of load.
-data LoadResult
- = LoadOk Errors -- ^ all specified targets were loaded successfully.
- | LoadFailed Errors -- ^ not all modules were loaded.
-
-type Errors = [String]
-
-data ErrMsg = ErrMsg {
- errMsgSeverity :: Severity, -- warning, error, etc.
- errMsgSpans :: [SrcSpan],
- errMsgShortDoc :: Doc,
- errMsgExtraInfo :: Doc
- }
--}
+ mod_graph <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
+ modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph }
+ return mod_graph
+-- | Describes which modules of the module graph need to be loaded.
data LoadHowMuch
= LoadAllTargets
+ -- ^ Load all targets and its dependencies.
| LoadUpTo ModuleName
+ -- ^ Load only the given module and its dependencies.
| LoadDependenciesOf ModuleName
+ -- ^ Load only the dependencies of the given module, but not the module
+ -- itself.
+
+-- | Try to load the program. See 'LoadHowMuch' for the different modes.
+--
+-- This function implements the core of GHC's @--make@ mode. It preprocesses,
+-- compiles and loads the specified modules, avoiding re-compilation wherever
+-- possible. Depending on the target (see 'DynFlags.hscTarget') compilating
+-- and loading may result in files being created on disk.
+--
+-- Calls the 'reportModuleCompilationResult' callback after each compiling
+-- each module, whether successful or not.
+--
+-- Throw a 'SourceError' if errors are encountered before the actual
+-- compilation starts (e.g., during dependency analysis). All other errors
+-- are reported using the callback.
+--
+load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
+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 ()
+
+defaultWarnErrLogger :: WarnErrLogger
+defaultWarnErrLogger Nothing = printWarnings
+defaultWarnErrLogger (Just e) = printExceptionAndWarnings e
-- | Try to load the program. If a Module is supplied, then just
-- 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
- = do
- -- Dependency analysis first. Note that this fixes the module graph:
- -- 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.
- mb_graph <- depanal s [] False
- case mb_graph of
- Just mod_graph -> load2 s how_much mod_graph
- Nothing -> return Failed
-
-load2 s@(Session ref) how_much mod_graph = do
- guessOutputFile s
- hsc_env <- readIORef ref
+--
+-- The first argument is a function that is called after compiling each
+-- module to print wanrings and errors.
+--
+-- While compiling a module, all 'SourceError's are caught and passed to the
+-- logger, however, this function may still throw a 'SourceError' if
+-- dependency analysis failed (e.g., due to a parse error).
+--
+loadWithLogger :: GhcMonad m => WarnErrLogger -> LoadHowMuch -> m SuccessFlag
+loadWithLogger logger how_much = do
+ -- Dependency analysis first. Note that this fixes the module graph:
+ -- 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.
+ withLocalCallbacks (\cbs -> cbs { reportModuleCompilationResult =
+ \_ -> logger }) $
+ load how_much
+
+load2 :: GhcMonad m => LoadHowMuch -> [ModSummary]
+ -> m SuccessFlag
+load2 how_much mod_graph = do
+ guessOutputFile
+ hsc_env <- getSession
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
-- (see msDeps)
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_name s `elem` all_home_mods)]
-#endif
ASSERT( null bad_boot_mods ) return ()
+ -- check that the module given in HowMuch actually exists, otherwise
+ -- topSortModuleGraph will bomb later.
+ let checkHowMuch (LoadUpTo m) = checkMod m
+ checkHowMuch (LoadDependenciesOf m) = checkMod m
+ checkHowMuch _ = id
+
+ checkMod m and_then
+ | m `elem` all_home_mods = and_then
+ | otherwise = do
+ liftIO $ errorMsg dflags (text "no such module:" <+>
+ quotes (ppr m))
+ return Failed
+
+ checkHowMuch how_much $ do
+
-- mg2_with_srcimps drops the hi-boot nodes, returning a
-- graph with cycles. Among other things, it is used for
-- backing out partially complete cycles following a failed
-- 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.
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.
(flattenSCCs mg2_with_srcimps)
stable_mods
- evaluate pruned_hpt
+ liftIO $ evaluate pruned_hpt
+
+ -- before we unload anything, make sure we don't leave an old
+ -- interactive context around pointing to dead bindings. Also,
+ -- write the pruned HPT to allow the old HPT to be GC'd.
+ modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext,
+ hsc_HPT = pruned_hpt }
- debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
+ liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
text "Stable BCO:" <+> ppr stable_bco)
-- Unload any modules which are going to be re-linked this time around.
| m <- stable_obj++stable_bco,
Just hmi <- [lookupUFM pruned_hpt m],
Just linkable <- [hm_linkable hmi] ]
- unload hsc_env stable_linkables
+ liftIO $ unload hsc_env stable_linkables
-- We could at this point detect cycles which aren't broken by
-- a source-import, and complain immediately, but it seems better
-- short of the specified module (unless the specified module
-- is stable).
partial_mg
- | LoadDependenciesOf mod <- how_much
+ | LoadDependenciesOf _mod <- how_much
= ASSERT( case last partial_mg0 of
- AcyclicSCC ms -> ms_mod_name ms == mod; _ -> False )
+ AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )
List.init partial_mg0
| otherwise
= partial_mg0
let cleanup = cleanTempFilesExcept dflags
(ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))
- debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
+ liftIO $ 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
+ pruned_hpt stable_mods cleanup mg
-- Make modsDone be the summaries for each home module now
-- available; this should equal the domain of hpt3.
then
-- Easy; just relink it all.
- do debugTraceMsg dflags 2 (text "Upsweep completely successful.")
+ do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.")
-- Clean up after ourselves
- cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
+ liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
-- Issue a warning for the confusing case where the user
-- said '-o foo' but we're not going to do any linking.
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 " ++ moduleNameString (moduleName main_mod) ++ " module."))
+ when (ghcLink dflags == LinkBinary
+ && isJust ofile && not do_linking) $
+ liftIO $ 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 <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)
- loadFinish Succeeded linkresult ref hsc_env1
+ loadFinish Succeeded linkresult hsc_env1
else
-- Tricky. We need to back out the effects of compiling any
-- half-done cycles, both so as to clean up the top level envs
-- and to avoid telling the interactive linker to link them.
- do debugTraceMsg dflags 2 (text "Upsweep partially successful.")
+ do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.")
let modsDone_names
= map ms_mod modsDone
(hsc_HPT hsc_env1)
-- Clean up after ourselves
- cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)
+ liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)
-- there should be no Nothings where linkables should be, now
ASSERT(all (isJust.hm_linkable)
(eltsUFM (hsc_HPT hsc_env))) do
-- Link everything together
- linkresult <- link ghci_mode dflags False hpt4
+ linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4
let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
- loadFinish Failed linkresult ref hsc_env4
+ loadFinish Failed linkresult hsc_env4
-- Finish up after a load.
-- If the link failed, unload everything and return.
-loadFinish all_ok Failed ref hsc_env
- = do unload hsc_env []
- writeIORef ref $! discardProg hsc_env
+loadFinish :: GhcMonad m =>
+ SuccessFlag -> SuccessFlag -> HscEnv
+ -> m SuccessFlag
+loadFinish _all_ok Failed hsc_env
+ = do liftIO $ unload hsc_env []
+ modifySession $ \_ -> discardProg hsc_env
return Failed
-- Empty the interactive context and set the module context to the topmost
-- newly loaded module, or the Prelude if none were loaded.
-loadFinish all_ok Succeeded ref hsc_env
- = do writeIORef ref $! hsc_env{ hsc_IC = emptyInteractiveContext }
+loadFinish all_ok Succeeded hsc_env
+ = do modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext }
return all_ok
-- used to fish out the preprocess output files for the purposes of
-- cleaning up. The preprocessed file *might* be the same as the
-- source file, but that doesn't do any harm.
+ppFilesFromSummaries :: [ModSummary] -> [FilePath]
ppFilesFromSummaries summaries = map ms_hspp_file summaries
-- -----------------------------------------------------------------------------
--- Check module
-
-data CheckedModule =
- CheckedModule { parsedSource :: ParsedSource,
- renamedSource :: Maybe RenamedSource,
- typecheckedSource :: Maybe TypecheckedSource,
- checkedModuleInfo :: Maybe ModuleInfo
- }
+
+class ParsedMod m where
+ modSummary :: m -> ModSummary
+ parsedSource :: m -> ParsedSource
+
+class ParsedMod m => TypecheckedMod m where
+ renamedSource :: m -> Maybe RenamedSource
+ typecheckedSource :: m -> TypecheckedSource
+ moduleInfo :: m -> ModuleInfo
+ tm_internals :: m -> (TcGblEnv, ModDetails)
-- ToDo: improvements that could be made here:
-- if the module succeeded renaming but not typechecking,
-- we can still get back the GlobalRdrEnv and exports, so
-- perhaps the ModuleInfo should be split up into separate
- -- fields within CheckedModule.
+ -- fields.
+
+class TypecheckedMod m => DesugaredMod m where
+ coreModule :: m -> ModGuts
+
+-- | The result of successful parsing.
+data ParsedModule =
+ ParsedModule { pm_mod_summary :: ModSummary
+ , pm_parsed_source :: ParsedSource }
+
+instance ParsedMod ParsedModule where
+ modSummary m = pm_mod_summary m
+ parsedSource m = pm_parsed_source m
+
+-- | The result of successful typechecking. It also contains the parser
+-- result.
+data TypecheckedModule =
+ TypecheckedModule { tm_parsed_module :: ParsedModule
+ , tm_renamed_source :: Maybe RenamedSource
+ , tm_typechecked_source :: TypecheckedSource
+ , tm_checked_module_info :: ModuleInfo
+ , tm_internals_ :: (TcGblEnv, ModDetails)
+ }
+
+instance ParsedMod TypecheckedModule where
+ modSummary m = modSummary (tm_parsed_module m)
+ parsedSource m = parsedSource (tm_parsed_module m)
+
+instance TypecheckedMod TypecheckedModule where
+ renamedSource m = tm_renamed_source m
+ typecheckedSource m = tm_typechecked_source m
+ moduleInfo m = tm_checked_module_info m
+ tm_internals m = tm_internals_ m
+
+-- | The result of successful desugaring (i.e., translation to core). Also
+-- contains all the information of a typechecked module.
+data DesugaredModule =
+ DesugaredModule { dm_typechecked_module :: TypecheckedModule
+ , dm_core_module :: ModGuts
+ }
+
+instance ParsedMod DesugaredModule where
+ modSummary m = modSummary (dm_typechecked_module m)
+ parsedSource m = parsedSource (dm_typechecked_module m)
+
+instance TypecheckedMod DesugaredModule where
+ renamedSource m = renamedSource (dm_typechecked_module m)
+ typecheckedSource m = typecheckedSource (dm_typechecked_module m)
+ moduleInfo m = moduleInfo (dm_typechecked_module m)
+ tm_internals m = tm_internals_ (dm_typechecked_module m)
+
+instance DesugaredMod DesugaredModule where
+ coreModule m = dm_core_module m
type ParsedSource = Located (HsModule RdrName)
type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
-- - default methods are turned into top-level decls.
-- - dictionary bindings
-
--- | 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
--- successful, it returns the abstract syntax for the module.
-checkModule :: Session -> ModuleName -> 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
- hsc_env <- readIORef ref
- let mg = hsc_mod_graph hsc_env
- 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
- case mbChecked of
- Nothing -> return Nothing
- Just (HscChecked parsed renamed Nothing) ->
- return (Just (CheckedModule {
- parsedSource = parsed,
- renamedSource = renamed,
- typecheckedSource = Nothing,
- checkedModuleInfo = Nothing }))
- Just (HscChecked parsed renamed
- (Just (tc_binds, rdr_env, details))) -> do
- let minf = ModuleInfo {
- minf_type_env = md_types details,
- minf_exports = md_exports details,
- minf_rdr_env = Just rdr_env,
- minf_instances = md_insts details
- }
- return (Just (CheckedModule {
- parsedSource = parsed,
- renamedSource = renamed,
- typecheckedSource = Just tc_binds,
- checkedModuleInfo = Just minf }))
+-- | Return the 'ModSummary' of a module with the given name.
+--
+-- The module must be part of the module graph (see 'hsc_mod_graph' and
+-- 'ModuleGraph'). If this is not the case, this function will throw a
+-- 'GhcApiError'.
+--
+-- This function ignores boot modules and requires that there is only one
+-- non-boot module with the given name.
+getModSummary :: GhcMonad m => ModuleName -> m ModSummary
+getModSummary mod = do
+ mg <- liftM hsc_mod_graph getSession
+ case [ ms | ms <- mg, ms_mod_name ms == mod, not (isBootSummary ms) ] of
+ [] -> throw $ mkApiErr (text "Module not part of module graph")
+ [ms] -> return ms
+ multiple -> throw $ mkApiErr (text "getModSummary is ambiguous: " <+> ppr multiple)
+
+-- | Parse a module.
+--
+-- Throws a 'SourceError' on parse error.
+parseModule :: GhcMonad m => ModSummary -> m ParsedModule
+parseModule ms = do
+ rdr_module <- withTempSession
+ (\e -> e { hsc_dflags = ms_hspp_opts ms }) $
+ hscParse ms
+ return (ParsedModule ms rdr_module)
+
+-- | Typecheck and rename a parsed module.
+--
+-- Throws a 'SourceError' if either fails.
+typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
+typecheckModule pmod = do
+ let ms = modSummary pmod
+ withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do
+ (tc_gbl_env, rn_info)
+ <- hscTypecheckRename ms (parsedSource pmod)
+ details <- makeSimpleDetails tc_gbl_env
+ return $
+ TypecheckedModule {
+ tm_internals_ = (tc_gbl_env, details),
+ tm_parsed_module = pmod,
+ tm_renamed_source = rn_info,
+ tm_typechecked_source = tcg_binds tc_gbl_env,
+ tm_checked_module_info =
+ ModuleInfo {
+ minf_type_env = md_types details,
+ minf_exports = availsToNameSet $ md_exports details,
+ minf_rdr_env = Just (tcg_rdr_env tc_gbl_env),
+ minf_instances = md_insts details
+#ifdef GHCI
+ ,minf_modBreaks = emptyModBreaks
+#endif
+ }}
+
+-- | Desugar a typechecked module.
+desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
+desugarModule tcm = do
+ let ms = modSummary tcm
+ withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do
+ let (tcg, _) = tm_internals tcm
+ guts <- hscDesugar ms tcg
+ return $
+ DesugaredModule {
+ dm_typechecked_module = tcm,
+ dm_core_module = guts
+ }
+
+-- | Load a module. Input doesn't need to be desugared.
+--
+-- A module must be loaded before dependent modules can be typechecked. This
+-- always includes generating a 'ModIface' and, depending on the
+-- 'DynFlags.hscTarget', may also include code generation.
+--
+-- This function will always cause recompilation and will always overwrite
+-- previous compilation results (potentially files on disk).
+--
+loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod
+loadModule tcm = do
+ let ms = modSummary tcm
+ let mod = ms_mod_name ms
+ let (tcg, _details) = tm_internals tcm
+ hpt_new <-
+ withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do
+
+ 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
+
+-- | This is the way to get access to the Core bindings corresponding
+-- to a module. 'compileToCore' parses, typechecks, and
+-- desugars the module, then returns the resulting Core module (consisting of
+-- the module name, type declarations, and function declarations) if
+-- successful.
+compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule
+compileToCoreModule = compileCore False
+
+-- | Like compileToCoreModule, but invokes the simplifier, so
+-- as to return simplified and tidied Core.
+compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule
+compileToCoreSimplified = compileCore True
+{-
+-- | Provided for backwards-compatibility: compileToCore returns just the Core
+-- bindings, but for most purposes, you probably want to call
+-- compileToCoreModule.
+compileToCore :: GhcMonad m => FilePath -> m [CoreBind]
+compileToCore fn = do
+ mod <- compileToCoreModule session fn
+ return $ cm_binds mod
+-}
+-- | Takes a CoreModule and compiles the bindings therein
+-- to object code. The first argument is a bool flag indicating
+-- whether to run the simplifier.
+-- The resulting .o, .hi, and executable files, if any, are stored in the
+-- current directory, and named according to the module name.
+-- This has only so far been tested with a single self-contained module.
+compileCoreToObj :: GhcMonad m => Bool -> CoreModule -> m ()
+compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do
+ dflags <- getSessionDynFlags
+ currentTime <- liftIO $ getClockTime
+ cwd <- liftIO $ getCurrentDirectory
+ modLocation <- liftIO $ mkHiOnlyModLocation dflags (hiSuf dflags) cwd
+ ((moduleNameSlashes . moduleName) mName)
+
+ let modSummary = ModSummary { ms_mod = mName,
+ ms_hsc_src = ExtCoreFile,
+ ms_location = modLocation,
+ -- By setting the object file timestamp to Nothing,
+ -- we always force recompilation, which is what we
+ -- want. (Thus it doesn't matter what the timestamp
+ -- for the (nonexistent) source file is.)
+ ms_hs_date = currentTime,
+ ms_obj_date = Nothing,
+ -- Only handling the single-module case for now, so no imports.
+ ms_srcimps = [],
+ ms_imps = [],
+ -- No source file
+ ms_hspp_file = "",
+ ms_hspp_opts = dflags,
+ ms_hspp_buf = Nothing
+ }
+
+ let maybe_simplify mod_guts | simplify = hscSimplify mod_guts
+ | otherwise = return mod_guts
+ guts <- maybe_simplify (mkModGuts cm)
+ (iface, changed, _details, cgguts)
+ <- hscNormalIface guts Nothing
+ hscWriteIface iface changed modSummary
+ hscGenHardCode cgguts modSummary
+ return ()
+
+-- Makes a "vanilla" ModGuts.
+mkModGuts :: CoreModule -> ModGuts
+mkModGuts coreModule = ModGuts {
+ mg_module = cm_module coreModule,
+ mg_boot = False,
+ mg_exports = [],
+ mg_deps = noDependencies,
+ mg_dir_imps = emptyModuleEnv,
+ mg_used_names = emptyNameSet,
+ mg_rdr_env = emptyGlobalRdrEnv,
+ mg_fix_env = emptyFixityEnv,
+ mg_types = emptyTypeEnv,
+ mg_insts = [],
+ mg_fam_insts = [],
+ mg_rules = [],
+ mg_binds = cm_binds coreModule,
+ mg_foreign = NoStubs,
+ mg_warns = NoWarnings,
+ mg_anns = [],
+ mg_hpc_info = emptyHpcInfo False,
+ mg_modBreaks = emptyModBreaks,
+ mg_vect_info = noVectInfo,
+ mg_inst_env = emptyInstEnv,
+ mg_fam_inst_env = emptyFamInstEnv
+}
+
+compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
+compileCore simplify fn = do
+ -- First, set the target to the desired filename
+ target <- guessTarget fn Nothing
+ addTarget target
+ load LoadAllTargets
+ -- Then find dependencies
+ modGraph <- depanal [] True
+ case find ((== fn) . msHsFilePath) modGraph of
+ Just modSummary -> do
+ -- Now we have the module name;
+ -- parse, typecheck and desugar the module
+ mod_guts <- coreModule `fmap`
+ -- TODO: space leaky: call hsc* directly?
+ (desugarModule =<< typecheckModule =<< parseModule modSummary)
+ liftM gutsToCoreModule $
+ if simplify
+ then do
+ -- If simplify is true: simplify (hscSimplify), then tidy
+ -- (tidyProgram).
+ hsc_env <- getSession
+ simpl_guts <- hscSimplify mod_guts
+ tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts
+ return $ Left tidy_guts
+ else
+ return $ Right mod_guts
+
+ Nothing -> panic "compileToCoreModule: target FilePath not found in\
+ module dependency graph"
+ where -- two versions, based on whether we simplify (thus run tidyProgram,
+ -- which returns a (CgGuts, ModDetails) pair, or not (in which case
+ -- we just have a ModGuts.
+ gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule
+ gutsToCoreModule (Left (cg, md)) = CoreModule {
+ cm_module = cg_module cg, cm_types = md_types md,
+ cm_imports = cg_dir_imps cg, cm_binds = cg_binds cg
+ }
+ gutsToCoreModule (Right mg) = CoreModule {
+ cm_module = mg_module mg, cm_types = mg_types mg,
+ cm_imports = moduleEnvKeys (mg_dir_imps mg), cm_binds = mg_binds mg
+ }
-- ---------------------------------------------------------------------------
-- 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"
+ -- urgh. avoid warnings:
+ hsc_env stable_linkables
#endif
- other -> panic "unload: strange mode"
+ _other -> return ()
-- -----------------------------------------------------------------------------
--- checkStability
-{-
+{- |
+
Stability tells us which modules definitely do not need to be recompiled.
There are two main reasons for having stability:
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.
- -------------------
+@
stable m = stableObject m || stableBCO m
stableObject m =
stableBCO m =
all stable (imports m)
&& date(BCO) > date(.hs)
- -------------------
+@
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,
then we only need to read its .hi file from disk and
- link it to produce a ModDetails.
+ link it to produce a 'ModDetails'.
- if a modules is not stable, we will definitely be at least
- re-linking, and possibly re-compiling it during the upsweep.
+ re-linking, and possibly re-compiling it during the 'upsweep'.
All non-stable modules can (and should) therefore be unlinked
- before the upsweep.
+ before the 'upsweep'.
- Note that objects are only considered stable if they only depend
on other objects. We can't link object code against byte code.
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
+-- | Prune the HomePackageTable
+--
-- Before doing an upsweep, we can throw away:
--
-- - For non-stable modules:
= chew theGraph
where
chew [] = []
- chew ((AcyclicSCC v):rest) = chew rest -- acyclic? not interesting.
+ chew ((AcyclicSCC _):rest) = chew rest -- acyclic? not interesting.
chew ((CyclicSCC vs):rest)
= let names_in_this_cycle = nub (map ms_mod vs)
mods_in_this_cycle
else chewed_rest
-- -----------------------------------------------------------------------------
--- The upsweep
+-- | The upsweep
+--
-- This is where we compile each module in the module graph, in a pass
-- from the bottom to the top of the graph.
-
+--
-- There better had not be any cyclic groups here -- we check for them.
upsweep
- :: 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
- -> [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 mods
- = upsweep' hsc_env old_hpt stable_mods cleanup mods 1 (length mods)
-
-upsweep' hsc_env old_hpt stable_mods cleanup
+ :: GhcMonad m =>
+ 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
+ -> [SCC ModSummary] -- ^ Mods to do (the worklist)
+ -> m (SuccessFlag,
+ HscEnv,
+ [ModSummary])
+ -- ^ Returns:
+ --
+ -- 1. A flag whether the complete upsweep was successful.
+ -- 2. The 'HscEnv' with an updated HPT
+ -- 3. A list of modules which succeeded loading.
+
+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
+
+ upsweep' hsc_env _old_hpt done
[] _ _
- = return (Succeeded, hsc_env, [])
+ = return (Succeeded, hsc_env, done)
-upsweep' hsc_env old_hpt stable_mods cleanup
+ upsweep' hsc_env _old_hpt done
(CyclicSCC ms:_) _ _
- = do fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms)
- return (Failed, hsc_env, [])
+ = do liftIO $ fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms)
+ return (Failed, hsc_env, done)
-upsweep' hsc_env old_hpt stable_mods cleanup
+ upsweep' hsc_env old_hpt done
(AcyclicSCC mod:mods) mod_index nmods
= 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 <- upsweep_mod hsc_env old_hpt stable_mods mod
- mod_index nmods
+ mb_mod_info
+ <- handleSourceError
+ (\err -> do logger mod (Just err); return Nothing) $ do
+ mod_info <- upsweep_mod hsc_env old_hpt stable_mods
+ mod mod_index nmods
+ logger mod Nothing -- log warnings
+ return (Just mod_info)
- cleanup -- Remove unwanted tmp files between compilations
+ liftIO cleanup -- Remove unwanted tmp files between compilations
case mb_mod_info of
- Nothing -> return (Failed, hsc_env, [])
- Just mod_info -> do
- { let this_mod = ms_mod_name mod
+ Nothing -> return (Failed, hsc_env, done)
+ Just mod_info -> do
+ let this_mod = ms_mod_name mod
-- Add new info to hsc_env
- hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info
- hsc_env1 = hsc_env { hsc_HPT = hpt1 }
+ hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info
+ hsc_env1 = hsc_env { hsc_HPT = hpt1 }
-- Space-saving: delete the old HPT entry
-- for mod BUT if mod is a hs-boot
-- node, don't delete it. For the
-- interface, the HPT entry is probaby for the
-- main Haskell source file. Deleting it
- -- would force .. (what?? --SDM)
- old_hpt1 | isBootSummary mod = old_hpt
- | otherwise = delFromUFM old_hpt this_mod
+ -- would force the real module to be recompiled
+ -- every time.
+ old_hpt1 | isBootSummary mod = old_hpt
+ | otherwise = delFromUFM old_hpt this_mod
+
+ done' = mod:done
- ; (restOK, hsc_env2, modOKs)
- <- upsweep' hsc_env1 old_hpt1 stable_mods cleanup
- mods (mod_index+1) nmods
- ; return (restOK, hsc_env2, mod:modOKs)
- }
+ -- fixup our HomePackageTable after we've finished compiling
+ -- a mutually-recursive loop. See reTypecheckLoop, below.
+ hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done'
+ upsweep' hsc_env2 old_hpt1 done' mods (mod_index+1) nmods
--- Compile a single module. Always produce a Linkable for it if
+-- | Compile a single module. Always produce a Linkable for it if
-- successful. If no compilation happened, return the old Linkable.
-upsweep_mod :: HscEnv
+upsweep_mod :: GhcMonad m =>
+ HscEnv
-> HomePackageTable
-> ([ModuleName],[ModuleName])
-> ModSummary
-> Int -- index of module
-> Int -- total number of modules
- -> IO (Maybe HomeModInfo) -- Nothing => Failed
+ -> m HomeModInfo
upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
- = do
- let
- this_mod_name = ms_mod_name summary
+ = 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
- compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo)
- compile_it = upsweep_compile hsc_env old_hpt this_mod_name
- 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
- -- 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
- (expectJust "upseep1" mb_obj_date)
- 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
- -- 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)
- -- 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
- -- no existing code at all: we must recompile.
- where
- 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
-
--- 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 lookupUFM 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
- mod_index nmods
-
- case compresult of
- -- Compilation failed. Compile may still have updated the PCS, tho.
- CompErrs -> return Nothing
-
- -- 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_iface new_linkable
- -> do let new_info = HomeModInfo { hm_iface = new_iface,
- hm_details = new_details,
- hm_linkable = new_linkable }
- return (Just new_info)
+ 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 :: GhcMonad m => Maybe Linkable -> m HomeModInfo
+ compile_it = compile hsc_env summary' mod_index nmods mb_old_iface
+
+ compile_it_discard_iface :: GhcMonad m =>
+ Maybe Linkable -> m HomeModInfo
+ compile_it_discard_iface
+ = compile hsc_env summary' mod_index nmods Nothing
+
+ -- With the HscNothing target we create empty linkables to avoid
+ -- recompilation. We have to detect these to recompile anyway if
+ -- the target changed since the last compile.
+ is_fake_linkable
+ | Just hmi <- old_hmi, Just l <- hm_linkable hmi =
+ null (linkableUnlinked l)
+ | otherwise =
+ -- we have no linkable, so it cannot be fake
+ False
+
+ implies False _ = True
+ implies True x = x
+
+ in
+ case () of
+ _
+ -- 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, Just hmi <- old_hmi -> do
+ liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+ (text "skipping stable obj mod:" <+> ppr this_mod_name)
+ return hmi
+ -- object is stable, and we have an entry in the
+ -- old HPT: nothing to do
+
+ | is_stable_obj, isNothing old_hmi -> do
+ liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+ (text "compiling stable on-disk mod:" <+> ppr this_mod_name)
+ linkable <- liftIO $ findObjectLinkable this_mod obj_fn
+ (expectJust "upsweep1" mb_obj_date)
+ compile_it (Just linkable)
+ -- object is stable, but we need to load the interface
+ -- off disk to make a HMI.
+
+ | not (isObjectTarget target), is_stable_bco,
+ (target /= HscNothing) `implies` not is_fake_linkable ->
+ ASSERT(isJust old_hmi) -- must be in the old_hpt
+ let Just hmi = old_hmi in do
+ liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+ (text "skipping stable BCO mod:" <+> ppr this_mod_name)
+ return hmi
+ -- BCO is stable: nothing to do
+
+ | not (isObjectTarget target),
+ Just hmi <- old_hmi,
+ Just l <- hm_linkable hmi,
+ not (isObjectLinkable l),
+ (target /= HscNothing) `implies` not is_fake_linkable,
+ linkableTime l >= ms_hs_date summary -> do
+ liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+ (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)
+ 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.
+
+ -- 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.
+ --
+ | isObjectTarget target,
+ 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 -> do
+ liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+ (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)
+ compile_it (Just l)
+ _otherwise -> do
+ liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+ (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)
+ linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date
+ compile_it_discard_iface (Just linkable)
+
+ _otherwise -> do
+ liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+ (text "compiling mod:" <+> ppr this_mod_name)
+ compile_it Nothing
+
-- Filter modules in the HPT
, isJust mb_mod_info ]
-- ---------------------------------------------------------------------------
+-- Typecheck module loops
+
+{-
+See bug #930. This code fixes a long-standing bug in --make. The
+problem is that when compiling the modules *inside* a loop, a data
+type that is only defined at the top of the loop looks opaque; but
+after the loop is done, the structure of the data type becomes
+apparent.
+
+The difficulty is then that two different bits of code have
+different notions of what the data type looks like.
+
+The idea is that after we compile a module which also has an .hs-boot
+file, we re-generate the ModDetails for each of the modules that
+depends on the .hs-boot file, so that everyone points to the proper
+TyCons, Ids etc. defined by the real module, not the boot module.
+Fortunately re-generating a ModDetails from a ModIface is easy: the
+function TcIface.typecheckIface does exactly that.
+
+Picking the modules to re-typecheck is slightly tricky. Starting from
+the module graph consisting of the modules that have already been
+compiled, we reverse the edges (so they point from the imported module
+to the importing module), and depth-first-search from the .hs-boot
+node. This gives us all the modules that depend transitively on the
+.hs-boot module, and those are exactly the modules that we need to
+re-typecheck.
+
+Following this fix, GHC can compile itself with --make -O2.
+-}
+
+reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
+reTypecheckLoop hsc_env ms graph
+ | not (isBootSummary ms) &&
+ any (\m -> ms_mod m == this_mod && isBootSummary m) graph
+ = do
+ let mss = reachableBackwards (ms_mod_name ms) graph
+ non_boot = filter (not.isBootSummary) mss
+ debugTraceMsg (hsc_dflags hsc_env) 2 $
+ text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot)
+ typecheckLoop hsc_env (map ms_mod_name non_boot)
+ | otherwise
+ = return hsc_env
+ where
+ this_mod = ms_mod ms
+
+typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv
+typecheckLoop hsc_env mods = do
+ new_hpt <-
+ fixIO $ \new_hpt -> do
+ let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }
+ mds <- initIfaceCheck new_hsc_env $
+ mapM (typecheckIface . hm_iface) hmis
+ let new_hpt = addListToUFM old_hpt
+ (zip mods [ hmi{ hm_details = details }
+ | (hmi,details) <- zip hmis mds ])
+ return new_hpt
+ return hsc_env{ hsc_HPT = new_hpt }
+ where
+ old_hpt = hsc_HPT hsc_env
+ hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods
+
+reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
+reachableBackwards mod summaries
+ = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ]
+ where -- the rest just sets up the graph:
+ (graph, lookup_node) = moduleGraphNodes False summaries
+ root = expectJust "reachableBackwards" (lookup_node HsBootFile mod)
+
+-- ---------------------------------------------------------------------------
-- Topological sort of the module graph
+type SummaryNode = (ModSummary, Int, [Int])
+
topSortModuleGraph
- :: Bool -- Drop hi-boot nodes? (see below)
+ :: Bool
+ -- ^ Drop hi-boot nodes? (see below)
-> [ModSummary]
-> Maybe ModuleName
+ -- ^ Root module name. If @Nothing@, use the full graph.
-> [SCC ModSummary]
--- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
+-- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
-- The resulting list of strongly-connected-components is in topologically
-- sorted order, starting with the module(s) at the bottom of the
-- dependency graph (ie compile them first) and ending with the ones at
--
-- Drop hi-boot nodes (first boolean arg)?
--
--- False: treat the hi-boot summaries as nodes of the graph,
+-- - @False@: treat the hi-boot summaries as nodes of the graph,
-- so the graph must be acyclic
--
--- True: eliminate the hi-boot nodes, and instead pretend
+-- - @True@: eliminate the hi-boot nodes, and instead pretend
-- the a source-import of Foo is an import of Foo
--- The resulting graph has no hi-boot nodes, but can by cyclic
-
-topSortModuleGraph drop_hs_boot_nodes summaries Nothing
- = stronglyConnComp (fst (moduleGraphNodes drop_hs_boot_nodes summaries))
-topSortModuleGraph drop_hs_boot_nodes summaries (Just mod)
- = stronglyConnComp (map vertex_fn (reachable graph root))
- where
- -- restrict the graph to just those modules reachable from
- -- the specified module. We do this by building a graph with
- -- the full set of nodes, and determining the reachable set from
- -- the specified node.
- (nodes, lookup_key) = moduleGraphNodes drop_hs_boot_nodes summaries
- (graph, vertex_fn, key_fn) = graphFromEdges' nodes
- root
- | Just key <- lookup_key HsSrcFile mod, Just v <- key_fn key = v
- | otherwise = throwDyn (ProgramError "module does not exist")
+-- The resulting graph has no hi-boot nodes, but can be cyclic
+
+topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod
+ = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph
+ where
+ (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries
+
+ initial_graph = case mb_root_mod of
+ Nothing -> graph
+ Just root_mod ->
+ -- restrict the graph to just those modules reachable from
+ -- the specified module. We do this by building a graph with
+ -- the full set of nodes, and determining the reachable set from
+ -- the specified node.
+ let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node
+ | otherwise = ghcError (ProgramError "module does not exist")
+ in graphFromEdgedVertices (seq root (reachableG graph root))
+
+summaryNodeKey :: SummaryNode -> Int
+summaryNodeKey (_, k, _) = k
+
+summaryNodeSummary :: SummaryNode -> ModSummary
+summaryNodeSummary (s, _, _) = s
moduleGraphNodes :: Bool -> [ModSummary]
- -> ([(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
- hs_boot_key | drop_hs_boot_nodes = HsSrcFile
- | otherwise = HsBootFile
-
- -- 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_name s),
- out_edge_keys hs_boot_key (map unLoc (ms_srcimps 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 ([(moduleName (ms_mod s), ms_hsc_src s)
- | s <- summaries]
- `zip` [1..])
-
- lookup_key :: HscSource -> ModuleName -> Maybe Int
- lookup_key hs_src mod = lookupFM key_map (mod, hs_src)
-
- 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
+ -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)
+moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node)
+ where
+ numbered_summaries = zip summaries [1..]
+
+ lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
+ lookup_node hs_src mod = lookupFM node_map (mod, hs_src)
+
+ lookup_key :: HscSource -> ModuleName -> Maybe Int
+ lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)
+
+ node_map :: NodeMap SummaryNode
+ node_map = listToFM [ ((moduleName (ms_mod s), ms_hsc_src s), node)
+ | node@(s, _, _) <- nodes ]
+
+ -- We use integers as the keys for the SCC algorithm
+ nodes :: [SummaryNode]
+ nodes = [ (s, key, out_keys)
+ | (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_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 []
+ else case lookup_key HsBootFile (ms_mod_name s) of
+ Nothing -> []
+ Just k -> [k]) ]
+
+ -- [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.
+
+ -- Drop hs-boot nodes by using HsSrcFile as the key
+ hs_boot_key | drop_hs_boot_nodes = HsSrcFile
+ | otherwise = HsBootFile
+
+ 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 = (ModuleName, HscSource) -- The nodes of the graph are
nodeMapElts :: NodeMap a -> [a]
nodeMapElts = eltsFM
-ms_mod_name :: ModSummary -> ModuleName
-ms_mod_name = moduleName . ms_mod
-
--- If there are {-# SOURCE #-} imports between strongly connected
+-- | 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)))
+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 m 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 :: ModSummary -> Located ModuleName -> WarnMsg
- warn ms (L loc mod) =
+ warn :: Located ModuleName -> WarnMsg
+ warn (L loc mod) =
mkPlainErrMsg loc
- (ptext SLIT("Warning: {-# SOURCE #-} unnecessary in import of ")
+ (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ")
<+> quotes (ppr mod))
-----------------------------------------------------------------------------
-- module, plus one for any hs-boot files. The imports of these nodes
-- are all there, including the imports of non-home-package modules.
-downsweep :: HscEnv
+downsweep :: GhcMonad m =>
+ HscEnv
-> [ModSummary] -- Old summaries
-> [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
-- very useful for ghc -M
- -> IO (Maybe [ModSummary])
+ -> m [ModSummary]
-- The elts of [ModSummary] all have distinct
-- (Modules, IsBoot) identifiers, unless the Bool is true
-- in which case there can be repeats
downsweep hsc_env old_summaries excl_mods allow_dup_roots
- = -- catch error messages and return them
- handleDyn (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do
+ = do -- catch error messages and return them
+ --handleErrMsg -- should be covered by GhcMonad now
+ -- (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do
rootSummaries <- mapM getRootSummary roots
let root_map = mkRootMap rootSummaries
checkDuplicates root_map
summs <- loop (concatMap msDeps rootSummaries) root_map
- return (Just summs)
+ return summs
where
roots = hsc_targets hsc_env
old_summary_map :: NodeMap ModSummary
old_summary_map = mkNodeMap old_summaries
- getRootSummary :: Target -> IO ModSummary
- getRootSummary (Target (TargetFile file mb_phase) maybe_buf)
- = do exists <- doesFileExist file
+ getRootSummary :: GhcMonad m => Target -> m ModSummary
+ getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)
+ = do exists <- liftIO $ doesFileExist file
if exists
- then summariseFile hsc_env old_summaries file mb_phase maybe_buf
- else throwDyn $ mkPlainErrMsg noSrcSpan $
+ then summariseFile hsc_env old_summaries file mb_phase
+ obj_allowed maybe_buf
+ else throwOneError $ mkPlainErrMsg noSrcSpan $
text "can't find file:" <+> text file
- getRootSummary (Target (TargetModule modl) maybe_buf)
+ getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)
= do maybe_summary <- summariseModule hsc_env old_summary_map False
- (L rootLoc modl) maybe_buf excl_mods
+ (L rootLoc modl) obj_allowed
+ maybe_buf excl_mods
case maybe_summary of
Nothing -> packageModErr modl
Just s -> return s
- rootLoc = mkGeneralSrcSpan FSLIT("<command line>")
+ rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
-- In a root module, the filename is allowed to diverge from the module
-- name, so we have to check that there aren't multiple root files
-- defining the same module (otherwise the duplicates will be silently
-- ignored, leading to confusing behaviour).
- checkDuplicates :: NodeMap [ModSummary] -> IO ()
+ checkDuplicates :: GhcMonad m => NodeMap [ModSummary] -> m ()
checkDuplicates root_map
| allow_dup_roots = return ()
| null dup_roots = return ()
- | otherwise = multiRootsErr (head dup_roots)
+ | otherwise = liftIO $ multiRootsErr (head dup_roots)
where
dup_roots :: [[ModSummary]] -- Each at least of length 2
dup_roots = filterOut isSingleton (nodeMapElts root_map)
- loop :: [(Located ModuleName,IsBootInterface)]
+ loop :: GhcMonad m =>
+ [(Located ModuleName,IsBootInterface)]
-- Work list: process these modules
-> NodeMap [ModSummary]
-- Visited set; the range is a list because
-- the roots can have the same module names
-- if allow_dup_roots is True
- -> IO [ModSummary]
+ -> m [ModSummary]
-- The result includes the worklist, except
-- for those mentioned in the visited set
loop [] done = return (concat (nodeMapElts done))
= if isSingleton summs then
loop ss done
else
- do { multiRootsErr summs; return [] }
- | otherwise = do { mb_s <- summariseModule hsc_env old_summary_map
- is_boot wanted_mod Nothing excl_mods
- ; case mb_s of
- Nothing -> loop ss done
- Just s -> loop (msDeps s ++ ss)
- (addToFM done key [s]) }
+ do { liftIO $ multiRootsErr summs; return [] }
+ | otherwise
+ = do mb_s <- summariseModule hsc_env old_summary_map
+ is_boot wanted_mod True
+ Nothing excl_mods
+ case mb_s of
+ Nothing -> loop ss done
+ Just s -> loop (msDeps s ++ ss) (addToFM done key [s])
where
key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
-- 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
-- resides.
summariseFile
- :: HscEnv
+ :: GhcMonad m =>
+ HscEnv
-> [ModSummary] -- old summaries
-> FilePath -- source file name
-> Maybe Phase -- start phase
+ -> Bool -- object code allowed?
-> Maybe (StringBuffer,ClockTime)
- -> IO ModSummary
+ -> m ModSummary
-summariseFile hsc_env old_summaries file mb_phase maybe_buf
+summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
-- we can use a cached summary if one is available and the
-- source file hasn't changed, But we have to look up the summary
-- by source file, rather than module name as we do in summarise.
-- return the cached summary if the source didn't change
src_timestamp <- case maybe_buf of
Just (_,t) -> return t
- Nothing -> getModificationTime file
+ Nothing -> liftIO $ getModificationTime file
-- The file exists; we checked in getRootSummary above.
-- If it gets removed subsequently, then this
-- getModificationTime may fail, but that's the right
if ms_hs_date old_summary == src_timestamp
then do -- update the object-file timestamp
- obj_timestamp <- getObjTimestamp location False
+ obj_timestamp <-
+ if isObjectTarget (hscTarget (hsc_dflags hsc_env))
+ || obj_allowed -- bug #1205
+ then liftIO $ getObjTimestamp location False
+ else return Nothing
return old_summary{ ms_obj_date = obj_timestamp }
else
new_summary
let dflags = hsc_dflags hsc_env
(dflags', hspp_fn, buf)
- <- preprocessFile dflags file mb_phase maybe_buf
+ <- preprocessFile hsc_env file mb_phase maybe_buf
- (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn
+ (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file
-- Make a ModLocation for this file
- location <- mkHomeModLocation dflags mod_name file
+ location <- liftIO $ 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
- mod <- addHomeModuleToFinder hsc_env mod_name location
+ mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
src_timestamp <- case maybe_buf of
Just (_,t) -> return t
- Nothing -> getModificationTime file
+ Nothing -> liftIO $ getModificationTime file
-- getMofificationTime may fail
- obj_timestamp <- modificationTimeIfExists (ml_obj_file location)
+ -- when the user asks to load a source file by name, we only
+ -- use an object file if -fobject-code is on. See #1205.
+ obj_timestamp <-
+ if isObjectTarget (hscTarget (hsc_dflags hsc_env))
+ || obj_allowed -- bug #1205
+ then liftIO $ modificationTimeIfExists (ml_obj_file location)
+ else return Nothing
return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
ms_location = location,
= case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
[] -> Nothing
- (x:xs) -> Just x
+ (x:_) -> Just x
-- Summarise a module, and pick up source and timestamp.
summariseModule
- :: HscEnv
+ :: GhcMonad m =>
+ HscEnv
-> NodeMap ModSummary -- Map of old summaries
-> IsBootInterface -- True <=> a {-# SOURCE #-} import
-> Located ModuleName -- Imported module to be summarised
+ -> Bool -- object code allowed?
-> Maybe (StringBuffer, ClockTime)
-> [ModuleName] -- Modules to exclude
- -> IO (Maybe ModSummary) -- Its new summary
+ -> m (Maybe ModSummary) -- Its new summary
-summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf excl_mods
+summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
+ obj_allowed maybe_buf excl_mods
| wanted_mod `elem` excl_mods
= return Nothing
case maybe_buf of
Just (_,t) -> check_timestamp old_summary location src_fn t
Nothing -> do
- m <- System.IO.Error.try (getModificationTime src_fn)
+ m <- liftIO $ System.IO.Error.try (getModificationTime src_fn)
case m of
Right t -> check_timestamp old_summary location src_fn t
Left e | isDoesNotExistError e -> find_it
- | otherwise -> ioError e
+ | otherwise -> liftIO $ ioError e
| otherwise = find_it
where
check_timestamp old_summary location src_fn src_timestamp
| ms_hs_date old_summary == src_timestamp = do
-- update the object-file timestamp
- obj_timestamp <- getObjTimestamp location is_boot
+ obj_timestamp <- liftIO $
+ if isObjectTarget (hscTarget (hsc_dflags hsc_env))
+ || obj_allowed -- bug #1205
+ then getObjTimestamp location is_boot
+ else return Nothing
return (Just old_summary{ ms_obj_date = obj_timestamp })
| otherwise =
-- source changed: re-summarise.
-- previously a package module, it may have now appeared on the
-- 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 <- findImportedModule hsc_env wanted_mod Nothing
+ liftIO $ uncacheModule hsc_env wanted_mod
+ found <- liftIO $ findImportedModule hsc_env wanted_mod Nothing
case found of
Found location mod
| isJust (ml_hs_file location) ->
-- Drop external-pkg
ASSERT(modulePackageId mod /= thisPackage dflags)
return Nothing
- where
- err -> noModError dflags loc wanted_mod err
+ err -> liftIO $ noModError dflags loc wanted_mod err
-- Not found
just_found location mod = do
-- Check that it exists
-- It might have been deleted since the Finder last found it
- maybe_t <- modificationTimeIfExists src_fn
+ maybe_t <- liftIO $ modificationTimeIfExists src_fn
case maybe_t of
Nothing -> noHsFileErr loc src_fn
Just t -> new_summary location' mod src_fn t
= do
-- Preprocess the source file and get its imports
-- The dflags' contains the OPTIONS pragmas
- (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn Nothing maybe_buf
- (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn
+ (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf
+ (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
when (mod_name /= wanted_mod) $
- throwDyn $ mkPlainErrMsg mod_loc $
- text "file name does not match module name"
- <+> quotes (ppr mod_name)
+ throwOneError $ mkPlainErrMsg mod_loc $
+ text "File name does not match module name:"
+ $$ text "Saw:" <+> quotes (ppr mod_name)
+ $$ text "Expected:" <+> quotes (ppr wanted_mod)
-- Find the object timestamp, and return the summary
- obj_timestamp <- getObjTimestamp location is_boot
-
- return (Just ( ModSummary { ms_mod = mod,
- ms_hsc_src = hsc_src,
- ms_location = location,
- ms_hspp_file = hspp_fn,
- ms_hspp_opts = dflags',
- ms_hspp_buf = Just buf,
- ms_srcimps = srcimps,
- ms_imps = the_imps,
- ms_hs_date = src_timestamp,
- ms_obj_date = obj_timestamp }))
-
-
+ obj_timestamp <- liftIO $
+ if isObjectTarget (hscTarget (hsc_dflags hsc_env))
+ || obj_allowed -- bug #1205
+ then getObjTimestamp location is_boot
+ else return Nothing
+
+ return (Just (ModSummary { ms_mod = mod,
+ ms_hsc_src = hsc_src,
+ ms_location = location,
+ ms_hspp_file = hspp_fn,
+ ms_hspp_opts = dflags',
+ ms_hspp_buf = Just buf,
+ ms_srcimps = srcimps,
+ ms_imps = the_imps,
+ ms_hs_date = src_timestamp,
+ ms_obj_date = obj_timestamp }))
+
+
+getObjTimestamp :: ModLocation -> Bool -> IO (Maybe ClockTime)
getObjTimestamp location is_boot
= if is_boot then return Nothing
else modificationTimeIfExists (ml_obj_file location)
-preprocessFile :: DynFlags -> FilePath -> Maybe Phase -> Maybe (StringBuffer,ClockTime)
- -> IO (DynFlags, FilePath, StringBuffer)
-preprocessFile dflags src_fn mb_phase Nothing
+preprocessFile :: GhcMonad m =>
+ HscEnv
+ -> FilePath
+ -> Maybe Phase -- ^ Starting phase
+ -> Maybe (StringBuffer,ClockTime)
+ -> m (DynFlags, FilePath, StringBuffer)
+preprocessFile hsc_env src_fn mb_phase Nothing
= do
- (dflags', hspp_fn) <- preprocess dflags (src_fn, mb_phase)
- buf <- hGetStringBuffer hspp_fn
+ (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)
+ buf <- liftIO $ hGetStringBuffer hspp_fn
return (dflags', hspp_fn, buf)
-preprocessFile dflags src_fn mb_phase (Just (buf, time))
+preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
= do
+ let dflags = hsc_dflags hsc_env
-- case we bypass the preprocessing stage?
let
- local_opts = getOptions buf src_fn
+ local_opts = getOptions dflags buf src_fn
--
- (dflags', errs) <- parseDynamicFlags dflags (map unLoc local_opts)
+ (dflags', leftovers, warns)
+ <- parseDynamicNoPackageFlags dflags local_opts
+ checkProcessArgsResult leftovers
+ handleFlagWarnings dflags' warns
let
needs_preprocessing
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 $ cannotFindModule dflags wanted_mod err
+ = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
+noHsFileErr :: GhcMonad m => SrcSpan -> String -> m a
noHsFileErr loc path
- = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path
+ = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path
+packageModErr :: GhcMonad m => ModuleName -> m a
packageModErr mod
- = throwDyn $ mkPlainErrMsg noSrcSpan $
+ = throwOneError $ mkPlainErrMsg noSrcSpan $
text "module" <+> quotes (ppr mod) <+> text "is a package module"
multiRootsErr :: [ModSummary] -> IO ()
+multiRootsErr [] = panic "multiRootsErr"
multiRootsErr summs@(summ1:_)
- = throwDyn $ mkPlainErrMsg noSrcSpan $
+ = throwOneError $ mkPlainErrMsg noSrcSpan $
text "module" <+> quotes (ppr mod) <+>
text "is defined in multiple files:" <+>
sep (map text files)
cyclicModuleErr :: [ModSummary] -> SDoc
cyclicModuleErr ms
- = hang (ptext SLIT("Module imports form a cycle for modules:"))
+ = hang (ptext (sLit "Module imports form a cycle for modules:"))
2 (vcat (map show_one ms))
where
show_one ms = sep [ show_mod (ms_hsc_src ms) (ms_mod ms),
- nest 2 $ ptext SLIT("imports:") <+>
+ nest 2 $ ptext (sLit "imports:") <+>
(pp_imps HsBootFile (ms_srcimps ms)
$$ pp_imps HsSrcFile (ms_imps ms))]
show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
-- its cache of module locations, since it may no longer be valid.
-- 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 $ flushFinderCaches
+workingDirectoryChanged :: GhcMonad m => m ()
+workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches)
-- -----------------------------------------------------------------------------
-- inspecting the session
-- | Get the module dependency graph.
-getModuleGraph :: Session -> IO ModuleGraph -- ToDo: DiGraph ModSummary
-getModuleGraph s = withSession s (return . hsc_mod_graph)
+getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary
+getModuleGraph = liftM hsc_mod_graph getSession
-isLoaded :: Session -> ModuleName -> IO Bool
-isLoaded s m = withSession s $ \hsc_env ->
+-- | Determines whether a set of modules requires Template Haskell.
+--
+-- Note that if the session's 'DynFlags' enabled Template Haskell when
+-- 'depanal' was called, then each module in the returned module graph will
+-- have Template Haskell enabled whether it is actually needed or not.
+needsTemplateHaskell :: ModuleGraph -> Bool
+needsTemplateHaskell ms =
+ any (dopt Opt_TemplateHaskell . ms_hspp_opts) ms
+
+-- | Return @True@ <==> module is loaded.
+isLoaded :: GhcMonad m => ModuleName -> m Bool
+isLoaded m = withSession $ \hsc_env ->
return $! isJust (lookupUFM (hsc_HPT hsc_env) m)
-getBindings :: Session -> IO [TyThing]
-getBindings s = withSession s (return . nameEnvElts . ic_type_env . hsc_IC)
-
-getPrintUnqual :: Session -> IO PrintUnqualified
-getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC)
+-- | Return the bindings for the current interactive session.
+getBindings :: GhcMonad m => m [TyThing]
+getBindings = withSession $ \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 :: GhcMonad m => m PrintUnqualified
+getPrintUnqual = withSession $ \hsc_env ->
+ return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env))
-- | 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
-- to package modules too.
-- | Request information about a loaded 'Module'
-getModuleInfo :: Session -> Module -> IO (Maybe ModuleInfo)
-getModuleInfo s mdl = withSession s $ \hsc_env -> do
+getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X
+getModuleInfo mdl = withSession $ \hsc_env -> do
let mg = hsc_mod_graph hsc_env
if mdl `elem` map ms_mod mg
- then getHomeModuleInfo hsc_env (moduleName mdl)
+ then liftIO $ getHomeModuleInfo hsc_env (moduleName mdl)
else do
{- if isHomeModule (hsc_dflags hsc_env) mdl
then return Nothing
- else -} getPackageModuleInfo hsc_env mdl
+ else -} liftIO $ getPackageModuleInfo hsc_env mdl
-- getPackageModuleInfo will attempt to find the interface, so
-- we don't want to call it for a home module, just in case there
-- was a problem loading the module and the interface doesn't
-- exist... hence the isHomeModule test here. (ToDo: reinstate)
getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
-getPackageModuleInfo hsc_env mdl = do
#ifdef GHCI
- (_msgs, mb_names) <- getModuleExports hsc_env mdl
- case mb_names of
+getPackageModuleInfo hsc_env mdl = do
+ (_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 (moduleName mdl),
- minf_instances = error "getModuleInfo: instances for package module unimplemented"
+ minf_instances = error "getModuleInfo: instances for package module unimplemented",
+ minf_modBreaks = emptyModBreaks
}))
#else
+getPackageModuleInfo _hsc_env _mdl = do
-- bogusly different for non-GHCI (ToDo)
return Nothing
#endif
+getHomeModuleInfo :: HscEnv -> ModuleName -> IO (Maybe ModuleInfo)
getHomeModuleInfo hsc_env mdl =
case lookupUFM (hsc_HPT hsc_env) mdl of
Nothing -> return Nothing
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 = getModBreaks hmi
+#endif
}))
-- | The list of top-level entities defined in a module
modInfoIsExportedName :: ModuleInfo -> Name -> Bool
modInfoIsExportedName minf name = elemNameSet name (minf_exports minf)
-modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified
-modInfoPrintUnqualified minf = fmap mkPrintUnqualified (minf_rdr_env minf)
+mkPrintUnqualifiedForModule :: GhcMonad m =>
+ ModuleInfo
+ -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X
+mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do
+ return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf))
-modInfoLookupName :: Session -> ModuleInfo -> Name -> IO (Maybe TyThing)
-modInfoLookupName s minf name = withSession s $ \hsc_env -> do
+modInfoLookupName :: GhcMonad m =>
+ ModuleInfo -> Name
+ -> m (Maybe TyThing) -- XXX: returns a Maybe X
+modInfoLookupName minf name = withSession $ \hsc_env -> do
case lookupTypeEnv (minf_type_env minf) name of
Just tyThing -> return (Just tyThing)
Nothing -> do
- eps <- readIORef (hsc_EPS hsc_env)
+ eps <- liftIO $ readIORef (hsc_EPS hsc_env)
return $! lookupType (hsc_dflags hsc_env)
(hsc_HPT hsc_env) (eps_PTE eps) name
+#ifdef GHCI
+modInfoModBreaks :: ModuleInfo -> ModBreaks
+modInfoModBreaks = minf_modBreaks
+#endif
+
isDictonaryId :: Id -> Bool
isDictonaryId id
- = case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau }
+ = case tcSplitSigmaTy (idType id) of { (_tvs, _theta, tau) -> isDictTy tau }
-- | Looks up a global name: that is, any top-level name in any
-- visible module. Unlike 'lookupName', lookupGlobalName does not use
-- the interactive context, and therefore does not require a preceding
-- 'setContext'.
-lookupGlobalName :: Session -> Name -> IO (Maybe TyThing)
-lookupGlobalName s name = withSession s $ \hsc_env -> do
- eps <- readIORef (hsc_EPS hsc_env)
- return $! lookupType (hsc_dflags hsc_env)
- (hsc_HPT hsc_env) (eps_PTE eps) name
+lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing)
+lookupGlobalName name = withSession $ \hsc_env -> do
+ liftIO $ lookupTypeHscEnv hsc_env name
+
+findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a]
+findGlobalAnns deserialize target = withSession $ \hsc_env -> do
+ ann_env <- liftIO $ prepareAnnotations hsc_env Nothing
+ return (findAnns deserialize ann_env target)
+
+#ifdef GHCI
+-- | get the GlobalRdrEnv for a session
+getGRE :: GhcMonad m => m GlobalRdrEnv
+getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env)
+#endif
+
+-- -----------------------------------------------------------------------------
+
+-- | Return all /external/ modules available in the package database.
+-- Modules from the current session (i.e., from the 'HomePackageTable') are
+-- not included.
+packageDbModules :: GhcMonad m =>
+ Bool -- ^ Only consider exposed packages.
+ -> m [Module]
+packageDbModules only_exposed = do
+ dflags <- getSessionDynFlags
+ let pkgs = UFM.eltsUFM (pkgIdMap (pkgState dflags))
+ return $
+ [ mkModule pid modname | p <- pkgs
+ , not only_exposed || exposed p
+ , pid <- [mkPackageId (package p)]
+ , modname <- exposedModules p ]
-- -----------------------------------------------------------------------------
-- Misc exported utils
-- :browse will use either lm_toplev or inspect lm_interface, depending
-- on whether the module is interpreted or not.
--- This is for reconstructing refactored source code
--- Calls the lexer repeatedly.
--- ToDo: add comment tokens to token stream
-getTokenStream :: Session -> Module -> IO [Located Token]
#endif
+-- Extract the filename, stringbuffer content and dynflags associed to a module
+--
+-- XXX: Explain pre-conditions
+getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags)
+getModuleSourceAndFlags mod = do
+ m <- getModSummary (moduleName mod)
+ case ml_hs_file $ ms_location m of
+ Nothing -> throw $ mkApiErr (text "No source available for module " <+> ppr mod)
+ Just sourceFile -> do
+ source <- liftIO $ hGetStringBuffer sourceFile
+ return (sourceFile, source, ms_hspp_opts m)
+
+
+-- | Return module source as token stream, including comments.
+--
+-- The module must be in the module graph and its source must be available.
+-- Throws a 'HscTypes.SourceError' on parse error.
+getTokenStream :: GhcMonad m => Module -> m [Located Token]
+getTokenStream mod = do
+ (sourceFile, source, flags) <- getModuleSourceAndFlags mod
+ let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0
+ case lexTokenStream source startLoc flags of
+ POk _ ts -> return ts
+ PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
+
+-- | Give even more information on the source than 'getTokenStream'
+-- This function allows reconstructing the source completely with
+-- 'showRichTokenStream'.
+getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
+getRichTokenStream mod = do
+ (sourceFile, source, flags) <- getModuleSourceAndFlags mod
+ let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0
+ case lexTokenStream source startLoc flags of
+ POk _ ts -> return $ addSourceToTokens startLoc source ts
+ PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
+
+-- | Given a source location and a StringBuffer corresponding to this
+-- location, return a rich token stream with the source associated to the
+-- tokens.
+addSourceToTokens :: SrcLoc -> StringBuffer -> [Located Token]
+ -> [(Located Token, String)]
+addSourceToTokens _ _ [] = []
+addSourceToTokens loc buf (t@(L span _) : ts)
+ | not (isGoodSrcSpan span) = (t,"") : addSourceToTokens loc buf ts
+ | otherwise = (t,str) : addSourceToTokens newLoc newBuf ts
+ where
+ (newLoc, newBuf, str) = go "" loc buf
+ start = srcSpanStart span
+ end = srcSpanEnd span
+ go acc loc buf | loc < start = go acc nLoc nBuf
+ | start <= loc && loc < end = go (ch:acc) nLoc nBuf
+ | otherwise = (loc, buf, reverse acc)
+ where (ch, nBuf) = nextChar buf
+ nLoc = advanceSrcLoc loc ch
+
+
+-- | Take a rich token stream such as produced from 'getRichTokenStream' and
+-- return source code almost identical to the original code (except for
+-- insignificant whitespace.)
+showRichTokenStream :: [(Located Token, String)] -> String
+showRichTokenStream ts = go startLoc ts ""
+ where sourceFile = srcSpanFile (getLoc . fst . head $ ts)
+ startLoc = mkSrcLoc sourceFile 0 0
+ go _ [] = id
+ go loc ((L span _, str):ts)
+ | not (isGoodSrcSpan span) = go loc ts
+ | locLine == tokLine = ((replicate (tokCol - locCol) ' ') ++)
+ . (str ++)
+ . go tokEnd ts
+ | otherwise = ((replicate (tokLine - locLine) '\n') ++)
+ . ((replicate tokCol ' ') ++)
+ . (str ++)
+ . go tokEnd ts
+ where (locLine, locCol) = (srcLocLine loc, srcLocCol loc)
+ (tokLine, tokCol) = (srcSpanStartLine span, srcSpanStartCol span)
+ tokEnd = srcSpanEnd span
+
-- -----------------------------------------------------------------------------
-- Interactive evaluation
-- | 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
-
-findModule' hsc_env mod_name maybe_pkg =
+findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
+findModule mod_name maybe_pkg = withSession $ \hsc_env -> liftIO $ -- XXX
let
dflags = hsc_dflags hsc_env
hpt = hsc_HPT hsc_env
case lookupUFM hpt mod_name of
Just mod_info -> return (mi_module (hm_iface mod_info))
_not_a_home_module -> do
- res <- findImportedModule hsc_env mod_name Nothing
+ res <- findImportedModule hsc_env mod_name maybe_pkg
case res of
Found _ m | modulePackageId m /= this_pkg -> return m
- | otherwise -> throwDyn (CmdLineError (showSDoc $
- text "module" <+> pprModule m <+>
+ | otherwise -> ghcError (CmdLineError (showSDoc $
+ text "module" <+> quotes (ppr (moduleName m)) <+>
text "is not loaded"))
err -> let msg = cannotFindModule dflags mod_name err in
- throwDyn (CmdLineError (showSDoc msg))
+ ghcError (CmdLineError (showSDoc msg))
#ifdef GHCI
+getHistorySpan :: GhcMonad m => History -> m SrcSpan
+getHistorySpan h = withSession $ \hsc_env ->
+ return$ InteractiveEval.getHistorySpan hsc_env h
--- | 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) toplev_mods export_mods = do
- hsc_env <- readIORef ref
- let old_ic = hsc_IC hsc_env
- hpt = hsc_HPT hsc_env
- --
- export_env <- mkExportEnv hsc_env export_mods
- toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods
- let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
- writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
- ic_exports = export_mods,
- 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 (moduleName mod)
- | (Just name_set, mod) <- zip mb_name_sets mods ]
- --
- return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
-
-nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
-nameSetToGlobalRdrEnv names mod =
- mkGlobalRdrEnv [ GRE { gre_name = name, gre_prov = vanillaProv mod }
- | name <- nameSetToList names ]
-
-vanillaProv :: ModuleName -> Provenance
--- We're building a GlobalRdrEnv as if the user imported
--- all the specified modules into the global interactive module
-vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
- where
- decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
- is_qual = False,
- is_dloc = srcLocSpan interactiveSrcLoc }
-
-mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
-mkTopLevEnv hpt modl
- = case lookupUFM hpt (moduleName modl) of
- Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++
- showSDoc (ppr modl)))
- Just details ->
- case mi_globals (hm_iface details) of
- Nothing ->
- throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
- ++ showSDoc (ppr 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 ->
- if modulePackageId modl /= thisPackage (hsc_dflags h)
- then return False
- else case lookupUFM (hsc_HPT h) (moduleName 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
+obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term
+obtainTermFromVal bound force ty a =
+ withSession $ \hsc_env ->
+ liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a
--- | 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)
+obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
+obtainTermFromId bound force id =
+ withSession $ \hsc_env ->
+ liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
------------------------------------------------------------------------------
--- 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"
-
--- -----------------------------------------------------------------------------
--- Compile an expression into a dynamic
-
-dynCompileExpr :: Session -> String -> IO (Maybe Dynamic)
-dynCompileExpr ses expr = do
- (full,exports) <- getContext ses
- setContext ses full $
- (mkModule
- (stringToPackageId "base") (mkModuleName "Data.Dynamic")
- ):exports
- let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
- res <- withSession ses (flip hscStmt stmt)
- setContext ses full exports
- case res of
- Nothing -> return Nothing
- Just (_, names, hvals) -> do
- vals <- (unsafeCoerce# hvals :: IO [Dynamic])
- case (names,vals) of
- (_:[], v:[]) -> return (Just v)
- _ -> panic "dynCompileExpr"
-
--- -----------------------------------------------------------------------------
--- 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 lookupUFM (hsc_HPT hsc_env) (ms_mod_name 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 */
+#endif