Ghc, GhcT, GhcMonad(..),
runGhc, runGhcT, initGhcMonad,
gcatch, gbracket, gfinally,
- clearWarnings, getWarnings, hasWarnings,
- printExceptionAndWarnings, printWarnings,
+ printException,
+ printExceptionAndWarnings,
handleSourceError,
+ needsTemplateHaskell,
-- * Flags and settings
DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt,
removeTarget,
guessTarget,
- -- * Extending the program scope
- extendGlobalRdrScope,
- setGlobalRdrScope,
- extendGlobalTypeScope,
- setGlobalTypeScope,
-
-- * Loading\/compiling the program
depanal,
- load, loadWithLogger, LoadHowMuch(..), SuccessFlag(..), -- also does depanal
+ load, LoadHowMuch(..),
+ SuccessFlag(..), succeeded, failed,
defaultWarnErrLogger, WarnErrLogger,
workingDirectoryChanged,
parseModule, typecheckModule, desugarModule, loadModule,
- ParsedModule, TypecheckedModule, DesugaredModule, -- all abstract
+ ParsedModule(..), TypecheckedModule(..), DesugaredModule(..),
TypecheckedSource, ParsedSource, RenamedSource, -- ditto
+ TypecheckedMod, ParsedMod,
moduleInfo, renamedSource, typecheckedSource,
parsedSource, coreModule,
compileToCoreModule, compileToCoreSimplified,
compileCoreToObj,
-
- -- * Parsing Haddock comments
- parseHaddockComment,
+ getModSummary,
-- * Inspecting the module structure of the program
ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
modInfoIsExportedName,
modInfoLookupName,
lookupGlobalName,
+ findGlobalAnns,
mkPrintUnqualifiedForModule,
+ -- * Querying the environment
+ packageDbModules,
+
-- * Printing
PrintUnqualified, alwaysQualify,
-- * Interactive evaluation
getBindings, getPrintUnqual,
findModule,
+ lookupModule,
#ifdef GHCI
setContext, getContext,
getNamesInScope,
typeKind,
parseName,
RunResult(..),
- runStmt, SingleStep(..),
+ runStmt, parseImportDecl, SingleStep(..),
resume,
Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
resumeHistory, resumeHistoryIx),
- History(historyBreakInfo, historyEnclosingDecl),
+ History(historyBreakInfo, historyEnclosingDecls),
GHC.getHistorySpan, getHistoryModule,
getResumeContext,
abandon, abandonAll,
showModule,
isModuleInterpreted,
InteractiveEval.compileExpr, HValue, dynCompileExpr,
- lookupName,
GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
modInfoModBreaks,
ModBreaks(..), BreakIndex,
BreakInfo(breakInfo_number, breakInfo_module),
BreakArray, setBreakOn, setBreakOff, getBreak,
#endif
+ lookupName,
-- * Abstract syntax elements
TyCon,
tyConTyVars, tyConDataCons, tyConArity,
isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
- isOpenTyCon,
+ isFamilyTyCon,
synTyConDefn, synTyConType, synTyConResKind,
-- ** Type variables
-- ** Data constructors
DataCon,
dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
- dataConIsInfix, isVanillaDataCon,
+ dataConIsInfix, isVanillaDataCon, dataConUserType,
dataConStrictMarks,
StrictnessMark(..), isMarkedStrict,
pprParendType, pprTypeApp,
Kind,
PredType,
- ThetaType, pprThetaArrow,
+ ThetaType, pprForAll, pprThetaArrow,
-- ** Entities
TyThing(..),
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,
getTokenStream, getRichTokenStream,
showRichTokenStream, addSourceToTokens,
+ -- * Pure interface to the parser
+ parser,
+
-- * Miscellaneous
--sessionHscEnv,
cyclicModuleErr,
import Linker ( HValue )
import ByteCodeInstr
import BreakArray
-import NameSet
import InteractiveEval
-import TcRnDriver
#endif
+import GhcMonad
import TcIface
-import TcRnTypes hiding (LIE)
+import TcRnTypes
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 Type
+import Coercion ( synTyConResKind )
+import TcType hiding( typeKind )
import Id
import Var
import TysPrim ( alphaTyVars )
import TyCon
import Class
-import FunDeps
+-- import FunDeps
import DataCon
import Name hiding ( varName )
-import OccName ( parenSymOcc )
-import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr,
- emptyInstEnv )
-import FamInstEnv ( emptyFamInstEnv )
+-- import OccName ( parenSymOcc )
+import InstEnv
import SrcLoc
---import CoreSyn
+import CoreSyn ( CoreBind )
import TidyPgm
import DriverPipeline
-import DriverPhases ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase )
+import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase )
import HeaderInfo
import Finder
import HscMain
import qualified StaticFlags
import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
cleanTempDirs )
+import Annotations
import Module
-import LazyUniqFM
-import UniqSet
-import Unique
-import FiniteMap
+import UniqFM
import Panic
import Digraph
-import Bag ( unitBag, listToBag, emptyBag, isEmptyBag )
+import Bag ( unitBag, listToBag )
import ErrUtils
import MonadUtils
import Util
-import StringBuffer ( StringBuffer, hGetStringBuffer, nextChar )
+import StringBuffer
import Outputable
import BasicTypes
import Maybes ( expectJust, mapCatMaybes )
-import HaddockParse
-import HaddockLex ( tokenise )
import FastString
+import qualified Parser
import Lexer
-import Control.Concurrent
import System.Directory ( getModificationTime, doesFileExist,
getCurrentDirectory )
import Data.Maybe
+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified FiniteMap as Map
import Data.List
import qualified Data.List as List
+import Data.Typeable ( Typeable )
+import Data.Word ( Word8 )
import Control.Monad
import System.Exit ( exitWith, ExitCode(..) )
import System.Time ( ClockTime, getClockTime )
import System.FilePath
import System.IO
import System.IO.Error ( try, isDoesNotExistError )
-#if __GLASGOW_HASKELL__ >= 609
-import Data.Typeable (cast)
-#endif
import Prelude hiding (init)
-- 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 :: (ExceptionMonad m, MonadIO m) => DynFlags -> m a -> m a
defaultErrorHandler dflags inner =
-- top-level exception handler: any unrecognised exception is a compiler bug.
-#if __GLASGOW_HASKELL__ < 609
- handle (\exception -> do
+ ghandle (\exception -> liftIO $ 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")
- ExitException _ -> throw exception
- _ ->
- fatalErrorMsg dflags (text (show (Panic (show exception))))
- exitWith (ExitFailure 1)
- ) $
-#else
- handle (\(SomeException exception) -> do
- hFlush stdout
- case cast exception of
+ 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 cast exception of
+ _ -> case fromException exception of
+ Just UserInterrupt -> exitWith (ExitFailure 1)
Just StackOverflow ->
fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
- _ -> case cast exception of
+ _ -> case fromException exception of
Just (ex :: ExitCode) -> throw ex
_ ->
fatalErrorMsg dflags
(text (show (Panic (show exception))))
exitWith (ExitFailure 1)
) $
-#endif
-
- -- program errors: messages with locations attached. Sometimes it is
- -- convenient to just throw these as exceptions.
- handleErrMsg
- (\em -> do printBagOfErrors dflags (unitBag em)
- exitWith (ExitFailure 1)) $
-- error messages propagated as exceptions
handleGhcException
- (\ge -> do
+ (\ge -> liftIO $ do
hFlush stdout
case ge of
PhaseFailed _ code -> exitWith code
- Interrupted -> exitWith (ExitFailure 1)
+ Signal _ -> exitWith (ExitFailure 1)
_ -> do fatalErrorMsg dflags (text (show ge))
exitWith (ExitFailure 1)
) $
DynFlags -> m a -> m a
defaultCleanupHandler dflags inner =
-- make sure we clean up after ourselves
- inner `gonException`
+ inner `gfinally`
(liftIO $ do
cleanTempFiles dflags
cleanTempDirs dflags
-- | Print the error message and all warnings. Useful inside exception
-- handlers. Clears warnings after printing.
+printException :: GhcMonad m => SourceError -> m ()
+printException err = do
+ dflags <- getSessionDynFlags
+ liftIO $ printBagOfErrors dflags (srcErrorMessages err)
+
+{-# DEPRECATED printExceptionAndWarnings "use printException instead" #-}
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
+printExceptionAndWarnings = printException
-- | Run function for the 'Ghc' monad.
--
-> 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
+ let session = Session ref
flip unGhc session $ do
initGhcMonad mb_top_dir
ghc
-> 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
+ let session = Session ref
flip unGhcT session $ do
initGhcMonad mb_top_dir
ghct
initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
initGhcMonad mb_top_dir = do
-- catch ^C
- main_thread <- liftIO $ myThreadId
- liftIO $ modifyMVar_ interruptTargetThread (return . (main_thread :))
liftIO $ installSignalHandlers
liftIO $ StaticFlags.initStaticOpts
dflags <- liftIO $ initSysTools mb_top_dir dflags0
env <- liftIO $ newHscEnv dflags
setSession env
- clearWarnings
-- -----------------------------------------------------------------------------
-- Flags & settings
--- | Grabs the DynFlags from the Session
-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),
-- and prepares the compilers knowledge about packages. It
target tid = Target tid obj_allowed Nothing
-- -----------------------------------------------------------------------------
--- Extending the program scope
-
-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 :: GhcMonad m => [GlobalRdrElt] -> m ()
-setGlobalRdrScope rdrElts
- = modifySession $ \hscEnv ->
- hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv emptyGlobalRdrEnv rdrElts }
-
-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 :: 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 =
- 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
-- and update the session with the new module graph.
+--
+-- 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
text "Chasing modules from: ",
hcat (punctuate comma (map pprTarget targets))])
- mod_graph <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
+ mod_graph <- liftIO $ 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. Calls 'loadWithLogger' with the default
--- compiler that just immediately logs all warnings and errors.
+-- | 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 =
- loadWithLogger defaultWarnErrLogger how_much
+load how_much = do
+ mod_graph <- depanal [] False
+ load2 how_much mod_graph
-- | A function called to log warnings and errors.
type WarnErrLogger = GhcMonad m => Maybe SourceError -> m ()
defaultWarnErrLogger :: WarnErrLogger
-defaultWarnErrLogger Nothing = printWarnings
-defaultWarnErrLogger (Just e) = printExceptionAndWarnings e
+defaultWarnErrLogger Nothing = return ()
+defaultWarnErrLogger (Just e) = printException 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.
---
--- The first argument is a function that is called after compiling each
--- module to print wanrings and errors.
-
-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.
- mod_graph <- depanal [] False
- load2 how_much mod_graph logger
-
-load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] -> WarnErrLogger
+load2 :: GhcMonad m => LoadHowMuch -> [ModSummary]
-> m SuccessFlag
-load2 how_much mod_graph logger = do
+load2 how_much mod_graph = do
guessOutputFile
hsc_env <- getSession
-- If we can determine that any of the {-# SOURCE #-} imports
-- are definitely unnecessary, then emit a warning.
- warnUnnecessarySourceImports dflags mg2_with_srcimps
+ warnUnnecessarySourceImports mg2_with_srcimps
let
-- check the stability property for each module.
(flattenSCCs mg2_with_srcimps)
stable_mods
- liftIO $ 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,
liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
2 (ppr mg))
- (upsweep_ok, hsc_env1, modsUpswept)
- <- upsweep logger
- (hsc_env { hsc_HPT = emptyHomePackageTable })
- pruned_hpt stable_mods cleanup mg
+
+ setSession hsc_env{ hsc_HPT = emptyHomePackageTable }
+ (upsweep_ok, modsUpswept)
+ <- upsweep pruned_hpt stable_mods cleanup mg
-- Make modsDone be the summaries for each home module now
-- available; this should equal the domain of hpt3.
let
main_mod = mainModIs dflags
a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
- do_linking = a_root_is_Main || no_hs_main
+ do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib
when (ghcLink dflags == LinkBinary
&& isJust ofile && not do_linking) $
moduleNameString (moduleName main_mod) ++ " module.")
-- link everything together
+ hsc_env1 <- getSession
linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)
- loadFinish Succeeded linkresult hsc_env1
+ loadFinish Succeeded linkresult
else
-- Tricky. We need to back out the effects of compiling any
= filter ((`notElem` mods_to_zap_names).ms_mod)
modsDone
+ hsc_env1 <- getSession
let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
(hsc_HPT hsc_env1)
-- Link everything together
linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4
- let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
- loadFinish Failed linkresult hsc_env4
+ modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 }
+ loadFinish Failed linkresult
-- Finish up after a load.
-- If the link failed, unload everything and return.
loadFinish :: GhcMonad m =>
- SuccessFlag -> SuccessFlag -> HscEnv
+ SuccessFlag -> SuccessFlag
-> m SuccessFlag
-loadFinish _all_ok Failed hsc_env
- = do liftIO $ unload hsc_env []
- modifySession $ \_ -> discardProg hsc_env
+loadFinish _all_ok Failed
+ = do hsc_env <- getSession
+ liftIO $ unload hsc_env []
+ modifySession discardProg
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 hsc_env
- = do modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext }
+loadFinish all_ok Succeeded
+ = do modifySession $ \hsc_env -> hsc_env{ hsc_IC = emptyInteractiveContext }
return all_ok
type ParsedSource = Located (HsModule RdrName)
type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
- Maybe (HsDoc Name), HaddockModInfo Name)
+ Maybe LHsDocString)
type TypecheckedSource = LHsBinds Id
-- NOTE:
-- - default methods are turned into top-level decls.
-- - dictionary bindings
+-- | 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 ] of
+ 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
+ [ms] -> return ms
+ multiple -> throw $ mkApiErr (text "getModSummary is ambiguous: " <+> ppr multiple)
-- | Parse a module.
--
-- Throws a 'SourceError' on parse error.
-parseModule :: GhcMonad m => ModuleName -> m ParsedModule
-parseModule mod = do
- ms <- getModSummary mod
- hsc_env0 <- getSession
- let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms }
- rdr_module <- parseFile hsc_env ms
+parseModule :: GhcMonad m => ModSummary -> m ParsedModule
+parseModule ms = do
+ hsc_env <- getSession
+ let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
+ rdr_module <- liftIO $ hscParse hsc_env_tmp 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
- hsc_env0 <- getSession
- let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms }
- (tc_gbl_env, rn_info)
- <- typecheckRenameModule hsc_env ms (parsedSource pmod)
- details <- liftIO $ makeSimpleDetails hsc_env tc_gbl_env
- return $
+ let ms = modSummary pmod
+ hsc_env <- getSession
+ let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
+ (tc_gbl_env, rn_info)
+ <- liftIO $ hscTypecheckRename hsc_env_tmp ms (parsedSource pmod)
+ details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env
+ return $
TypecheckedModule {
tm_internals_ = (tc_gbl_env, details),
tm_parsed_module = pmod,
-- | Desugar a typechecked module.
desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
desugarModule tcm = do
- let ms = modSummary tcm
- hsc_env0 <- getSession
- let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms }
- let (tcg, _) = tm_internals tcm
- guts <- deSugarModule hsc_env ms tcg
- return $
+ let ms = modSummary tcm
+ let (tcg, _) = tm_internals tcm
+ hsc_env <- getSession
+ let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
+ guts <- liftIO $ hscDesugar hsc_env_tmp ms tcg
+ return $
DesugaredModule {
dm_typechecked_module = tcm,
dm_core_module = guts
-- | Load a module. Input doesn't need to be desugared.
--
--- XXX: Describe usage.
+-- 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
- hsc_env0 <- getSession
- let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms }
- let (tcg, details) = tm_internals tcm
- (iface,_) <- liftIO $ makeSimpleIface hsc_env Nothing tcg details
- let mod_info = HomeModInfo {
- hm_iface = iface,
- hm_details = details,
- hm_linkable = Nothing }
- let hpt_new = addToUFM (hsc_HPT hsc_env) mod mod_info
- modifySession $ \_ -> hsc_env0{ hsc_HPT = hpt_new }
+ let loc = ms_location ms
+ let (tcg, _details) = tm_internals tcm
+
+ mb_linkable <- case ms_obj_date ms of
+ Just t | t > ms_hs_date ms -> do
+ l <- liftIO $ findObjectLinkable (ms_mod ms)
+ (ml_obj_file loc) t
+ return (Just l)
+ _otherwise -> return Nothing
+
+ -- compile doesn't change the session
+ hsc_env <- getSession
+ mod_info <- liftIO $ compile' (hscNothingBackendOnly tcg,
+ hscInteractiveBackendOnly tcg,
+ hscBatchBackendOnly tcg)
+ hsc_env ms 1 1 Nothing mb_linkable
+
+ modifySession $ \e -> e{ hsc_HPT = addToUFM (hsc_HPT e) mod mod_info }
return tcm
+-- -----------------------------------------------------------------------------
+-- Operations dealing with Core
+
+-- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for
+-- the 'GHC.compileToCoreModule' interface.
+data CoreModule
+ = CoreModule {
+ -- | Module name
+ cm_module :: !Module,
+ -- | Type environment for types declared in this module
+ cm_types :: !TypeEnv,
+ -- | Declarations
+ cm_binds :: [CoreBind],
+ -- | Imports
+ cm_imports :: ![Module]
+ }
+
+instance Outputable CoreModule where
+ ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb}) =
+ text "%module" <+> ppr mn <+> ppr te $$ vcat (map ppr cb)
+
-- | 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
-- 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.
--- Returns True iff compilation succeeded.
-- 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
- hscEnv <- getSession
dflags <- getSessionDynFlags
currentTime <- liftIO $ getClockTime
cwd <- liftIO $ getCurrentDirectory
ms_hspp_buf = Nothing
}
- ioMsgMaybe $ flip evalComp (CompState{ compHscEnv=hscEnv,
- compModSummary=modSummary,
- compOldIface=Nothing}) $
- let maybe_simplify mod_guts | simplify = hscSimplify mod_guts
- | otherwise = return mod_guts
- in maybe_simplify (mkModGuts cm)
- >>= hscNormalIface
- >>= hscWriteIface
- >>= hscOneShot
- 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_hpc_info = emptyHpcInfo False,
- mg_modBreaks = emptyModBreaks,
- mg_vect_info = noVectInfo,
- mg_inst_env = emptyInstEnv,
- mg_fam_inst_env = emptyFamInstEnv
-}
+ hsc_env <- getSession
+ liftIO $ hscCompileCore hsc_env simplify modSummary (cm_binds cm)
+
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
+ _ <- 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
- let mod = ms_mod_name modSummary
mod_guts <- coreModule `fmap`
- (desugarModule =<< typecheckModule =<< parseModule mod)
+ -- 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 <- ioMsg $ evalComp (hscSimplify mod_guts)
- (CompState{
- compHscEnv = hsc_env,
- compModSummary = modSummary,
- compOldIface = Nothing})
+ simpl_guts <- liftIO $ hscSimplify hsc_env mod_guts
tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts
return $ Left tidy_guts
else
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
-- There better had not be any cyclic groups here -- we check for them.
upsweep
- :: GhcMonad m =>
- WarnErrLogger -- ^ Called to print warnings and errors.
- -> HscEnv -- ^ Includes initially-empty HPT
- -> HomePackageTable -- ^ HPT from last time round (pruned)
+ :: GhcMonad m
+ => 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, -- With an updated HPT
- [ModSummary]) -- Mods which succeeded
-
-upsweep logger 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)
+ [ModSummary])
+ -- ^ Returns:
+ --
+ -- 1. A flag whether the complete upsweep was successful.
+ -- 2. The 'HscEnv' in the monad has an updated HPT
+ -- 3. A list of modules which succeeded loading.
+
+upsweep old_hpt stable_mods cleanup sccs = do
+ (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs)
+ return (res, reverse done)
where
- upsweep' hsc_env _old_hpt done
+ upsweep' _old_hpt done
[] _ _
- = return (Succeeded, hsc_env, done)
+ = return (Succeeded, done)
- upsweep' hsc_env _old_hpt done
+ upsweep' _old_hpt done
(CyclicSCC ms:_) _ _
- = do liftIO $ fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms)
- return (Failed, hsc_env, done)
+ = do dflags <- getSessionDynFlags
+ liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)
+ return (Failed, done)
- upsweep' hsc_env old_hpt done
+ upsweep' 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 _mod = defaultWarnErrLogger
+ hsc_env <- getSession
mb_mod_info
<- handleSourceError
- (\err -> do logger (Just err); return Nothing) $ do
- mod_info <- upsweep_mod hsc_env old_hpt stable_mods
- mod mod_index nmods
- logger Nothing -- log warnings
+ (\err -> do logger mod (Just err); return Nothing) $ do
+ mod_info <- liftIO $ upsweep_mod hsc_env old_hpt stable_mods
+ mod mod_index nmods
+ logger mod Nothing -- log warnings
return (Just mod_info)
liftIO cleanup -- Remove unwanted tmp files between compilations
case mb_mod_info of
- Nothing -> return (Failed, hsc_env, done)
+ Nothing -> return (Failed, done)
Just mod_info -> do
let this_mod = ms_mod_name mod
-- fixup our HomePackageTable after we've finished compiling
-- a mutually-recursive loop. See reTypecheckLoop, below.
hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done'
+ setSession hsc_env2
- upsweep' hsc_env2 old_hpt1 done' mods (mod_index+1) nmods
+ upsweep' old_hpt1 done' mods (mod_index+1) nmods
-- | Compile a single module. Always produce a Linkable for it if
-- successful. If no compilation happened, return the old Linkable.
-upsweep_mod :: GhcMonad m =>
- HscEnv
+upsweep_mod :: HscEnv
-> HomePackageTable
-> ([ModuleName],[ModuleName])
-> ModSummary
-> Int -- index of module
-> Int -- total number of modules
- -> m HomeModInfo
+ -> IO HomeModInfo
upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
= let
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
+ compile_it :: Maybe Linkable -> IO HomeModInfo
+ compile_it mb_linkable =
+ compile hsc_env summary' mod_index nmods
+ mb_old_iface mb_linkable
+
+ compile_it_discard_iface :: Maybe Linkable -> IO HomeModInfo
+ compile_it_discard_iface mb_linkable =
+ compile hsc_env summary' mod_index nmods
+ Nothing mb_linkable
+
+ -- 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 target of
-
- _any
+ 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, isJust old_hmi ->
- let Just hmi = old_hmi in
- return hmi
- -- object is stable, and we have an entry in the
- -- old HPT: nothing to do
-
- | is_stable_obj, isNothing old_hmi -> do
- 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.
-
- HscInterpreted
- | is_stable_bco ->
- ASSERT(isJust old_hmi) -- must be in the old_hpt
- let Just hmi = old_hmi in
- return 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.
-
- -- When generating object code, if there's an up-to-date
- -- object file on the disk, then we can use it.
- -- However, if the object file is new (compared to any
- -- linkable we had from a previous compilation), then we
- -- must discard any in-memory interface, because this
- -- means the user has compiled the source file
- -- separately and generated a new interface, that we must
- -- read from the disk.
- --
- obj | isObjectTarget obj,
- Just obj_date <- mb_obj_date, obj_date >= hs_date -> do
- case old_hmi of
- Just hmi
- | Just l <- hm_linkable hmi,
- isObjectLinkable l && linkableTime l == obj_date
- -> compile_it (Just l)
- _otherwise -> do
- linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date
+ | 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 ->
- compile_it Nothing
+ _otherwise -> do
+ liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+ (text "compiling mod:" <+> ppr this_mod_name)
+ compile_it Nothing
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 be cyclic
numbered_summaries = zip summaries [1..]
lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
- lookup_node hs_src mod = lookupFM node_map (mod, hs_src)
+ lookup_node hs_src mod = Map.lookup (mod, hs_src) node_map
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 ]
+ node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node)
+ | node@(s, _, _) <- nodes ]
-- We use integers as the keys for the SCC algorithm
nodes :: [SummaryNode]
| (s, key) <- numbered_summaries
-- Drop the hi-boot ones if told to do so
, not (isBootSummary s && drop_hs_boot_nodes)
- , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++
- out_edge_keys HsSrcFile (map unLoc (ms_imps s)) ++
+ , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++
+ out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++
(-- see [boot-edges] below
if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
then []
type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are
-type NodeMap a = FiniteMap NodeKey a -- keyed by (mod, src_file_type) pairs
+type NodeMap a = Map NodeKey a -- keyed by (mod, src_file_type) pairs
msKey :: ModSummary -> NodeKey
msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)
mkNodeMap :: [ModSummary] -> NodeMap ModSummary
-mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries]
+mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries]
nodeMapElts :: NodeMap a -> [a]
-nodeMapElts = eltsFM
+nodeMapElts = Map.elems
-- | 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 :: GhcMonad m => DynFlags -> [SCC ModSummary] -> m ()
-warnUnnecessarySourceImports dflags sccs =
- liftIO $ printBagOfWarnings dflags (listToBag (concatMap (check.flattenSCC) sccs))
+warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
+warnUnnecessarySourceImports sccs = do
+ logWarnings (listToBag (concatMap (check.flattenSCC) sccs))
where check ms =
let mods_in_this_cycle = map ms_mod_name ms in
- [ warn i | m <- ms, i <- ms_srcimps m,
- unLoc i `notElem` mods_in_this_cycle ]
+ [ warn i | m <- ms, i <- ms_home_srcimps m,
+ unLoc i `notElem` mods_in_this_cycle ]
warn :: Located ModuleName -> WarnMsg
warn (L loc mod) =
-- 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 :: GhcMonad m =>
- HscEnv
+downsweep :: 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
- -> m [ModSummary]
+ -> IO [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
- = 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
+ = do
rootSummaries <- mapM getRootSummary roots
let root_map = mkRootMap rootSummaries
checkDuplicates root_map
old_summary_map :: NodeMap ModSummary
old_summary_map = mkNodeMap old_summaries
- getRootSummary :: GhcMonad m => Target -> m ModSummary
+ getRootSummary :: Target -> IO 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
obj_allowed maybe_buf
- else throwErrMsg $ mkPlainErrMsg noSrcSpan $
+ else throwOneError $ mkPlainErrMsg noSrcSpan $
text "can't find file:" <+> text file
getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)
= do maybe_summary <- summariseModule hsc_env old_summary_map False
-- 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 :: GhcMonad m => NodeMap [ModSummary] -> m ()
+ checkDuplicates :: NodeMap [ModSummary] -> IO ()
checkDuplicates root_map
| allow_dup_roots = return ()
| null dup_roots = return ()
dup_roots :: [[ModSummary]] -- Each at least of length 2
dup_roots = filterOut isSingleton (nodeMapElts root_map)
- loop :: GhcMonad m =>
- [(Located ModuleName,IsBootInterface)]
+ loop :: [(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
- -> m [ModSummary]
+ -> IO [ModSummary]
-- The result includes the worklist, except
-- for those mentioned in the visited set
loop [] done = return (concat (nodeMapElts done))
loop ((wanted_mod, is_boot) : ss) done
- | Just summs <- lookupFM done key
+ | Just summs <- Map.lookup key done
= if isSingleton summs then
loop ss done
else
- do { liftIO $ multiRootsErr summs; return [] }
+ do { 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])
+ Just s -> loop (msDeps s ++ ss) (Map.insert key [s] done)
where
key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
+-- XXX Does the (++) here need to be flipped?
mkRootMap :: [ModSummary] -> NodeMap [ModSummary]
-mkRootMap summaries = addListToFM_C (++) emptyFM
- [ (msKey s, [s]) | s <- summaries ]
+mkRootMap summaries = Map.insertListWith (flip (++))
+ [ (msKey s, [s]) | s <- summaries ]
+ Map.empty
msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]
-- (msDeps s) returns the dependencies of the ModSummary s.
-- 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, isLocal (ideclPkgQual i) ]
+ where isLocal Nothing = True
+ isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special
+ isLocal _ = False
+
+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
- :: GhcMonad m =>
- HscEnv
+ :: HscEnv
-> [ModSummary] -- old summaries
-> FilePath -- source file name
-> Maybe Phase -- start phase
-> Bool -- object code allowed?
-> Maybe (StringBuffer,ClockTime)
- -> m ModSummary
+ -> IO ModSummary
summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
-- we can use a cached summary if one is available and the
(dflags', hspp_fn, buf)
<- preprocessFile hsc_env file mb_phase maybe_buf
- (srcimps,the_imps, L _ mod_name) <- liftIO $ getImports dflags' buf hspp_fn file
+ (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file
-- Make a ModLocation for this file
location <- liftIO $ mkHomeModLocation dflags mod_name file
-- Summarise a module, and pick up source and timestamp.
summariseModule
- :: GhcMonad m =>
- HscEnv
+ :: 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
- -> m (Maybe ModSummary) -- Its new summary
+ -> IO (Maybe ModSummary) -- Its new summary
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
- | Just old_summary <- lookupFM old_summary_map (wanted_mod, hsc_src)
+ | Just old_summary <- Map.lookup (wanted_mod, hsc_src) old_summary_map
= do -- Find its new timestamp; all the
-- ModSummaries in the old map have valid ml_hs_files
let location = ms_location old_summary
case maybe_buf of
Just (_,t) -> check_timestamp old_summary location src_fn t
Nothing -> do
- m <- liftIO $ System.IO.Error.try (getModificationTime src_fn)
+ m <- 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 -> liftIO $ ioError e
+ | otherwise -> 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 <- liftIO $
+ obj_timestamp <-
if isObjectTarget (hscTarget (hsc_dflags hsc_env))
|| obj_allowed -- bug #1205
then getObjTimestamp location is_boot
-- 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.
- liftIO $ uncacheModule hsc_env wanted_mod
- found <- liftIO $ findImportedModule hsc_env wanted_mod Nothing
+ uncacheModule hsc_env wanted_mod
+ found <- findImportedModule hsc_env wanted_mod Nothing
case found of
Found location mod
| isJust (ml_hs_file location) ->
ASSERT(modulePackageId mod /= thisPackage dflags)
return Nothing
- err -> liftIO $ noModError dflags loc wanted_mod err
+ err -> 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 <- liftIO $ modificationTimeIfExists src_fn
+ maybe_t <- modificationTimeIfExists src_fn
case maybe_t of
Nothing -> noHsFileErr loc src_fn
Just t -> new_summary location' mod src_fn t
-- Preprocess the source file and get its imports
-- The dflags' contains the OPTIONS pragmas
(dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf
- (srcimps, the_imps, L mod_loc mod_name) <- liftIO $ getImports dflags' buf hspp_fn src_fn
+ (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
when (mod_name /= wanted_mod) $
- throwErrMsg $ mkPlainErrMsg mod_loc $
+ 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 <- liftIO $
+ obj_timestamp <-
if isObjectTarget (hscTarget (hsc_dflags hsc_env))
|| obj_allowed -- bug #1205
then getObjTimestamp location is_boot
else modificationTimeIfExists (ml_obj_file location)
-preprocessFile :: GhcMonad m =>
- HscEnv
+preprocessFile :: HscEnv
-> FilePath
-> Maybe Phase -- ^ Starting phase
-> Maybe (StringBuffer,ClockTime)
- -> m (DynFlags, FilePath, StringBuffer)
+ -> IO (DynFlags, FilePath, StringBuffer)
preprocessFile hsc_env src_fn mb_phase Nothing
= do
(dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)
- buf <- liftIO $ hGetStringBuffer hspp_fn
+ buf <- hGetStringBuffer hspp_fn
return (dflags', hspp_fn, buf)
preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
--
(dflags', leftovers, warns)
<- parseDynamicNoPackageFlags dflags local_opts
- liftIO $ checkProcessArgsResult leftovers -- XXX: throws exceptions
- liftIO $ handleFlagWarnings dflags' warns -- XXX: throws exceptions
+ checkProcessArgsResult leftovers
+ handleFlagWarnings dflags' warns
let
needs_preprocessing
| Just (Unlit _) <- mb_phase = True
| Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True
-- note: local_opts is only required if there's no Unlit phase
- | dopt Opt_Cpp dflags' = True
+ | xopt Opt_Cpp dflags' = True
| dopt Opt_Pp dflags' = True
| otherwise = False
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
- = throwErrMsg $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
+ = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
-noHsFileErr :: SrcSpan -> String -> a
+noHsFileErr :: SrcSpan -> String -> IO a
noHsFileErr loc path
- = throwErrMsg $ mkPlainErrMsg loc $ text "Can't find" <+> text path
+ = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path
-packageModErr :: ModuleName -> a
+packageModErr :: ModuleName -> IO a
packageModErr mod
- = throwErrMsg $ mkPlainErrMsg noSrcSpan $
+ = throwOneError $ mkPlainErrMsg noSrcSpan $
text "module" <+> quotes (ppr mod) <+> text "is a package module"
multiRootsErr :: [ModSummary] -> IO ()
multiRootsErr [] = panic "multiRootsErr"
multiRootsErr summs@(summ1:_)
- = throwErrMsg $ mkPlainErrMsg noSrcSpan $
+ = throwOneError $ mkPlainErrMsg noSrcSpan $
text "module" <+> quotes (ppr mod) <+>
text "is defined in multiple files:" <+>
sep (map text files)
= 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:") <+>
- (pp_imps HsBootFile (ms_srcimps ms)
- $$ pp_imps HsSrcFile (ms_imps ms))]
+ mods_in_cycle = map ms_mod_name ms
+ imp_modname = unLoc . ideclName . unLoc
+ just_in_cycle = filter ((`elem` mods_in_cycle) . imp_modname)
+
+ show_one ms =
+ vcat [ show_mod (ms_hsc_src ms) (ms_mod_name ms) <+>
+ maybe empty (parens . text) (ml_hs_file (ms_location ms)),
+ nest 2 $ ptext (sLit "imports:") <+> vcat [
+ pp_imps HsBootFile (just_in_cycle $ ms_srcimps ms),
+ pp_imps HsSrcFile (just_in_cycle $ ms_imps ms) ]
+ ]
show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
- pp_imps src mods = fsep (map (show_mod src) mods)
+ pp_imps src imps = fsep (map (show_mod src . unLoc . ideclName . unLoc) imps)
-- | Inform GHC that the working directory has changed. GHC will flush
-- 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).
+--
+-- Note: Before changing the working directory make sure all threads running
+-- in the same session have stopped. If you change the working directory,
+-- you should also unload the current program (set targets to empty,
+-- followed by load).
workingDirectoryChanged :: GhcMonad m => m ()
workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches)
getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary
getModuleGraph = liftM hsc_mod_graph getSession
+-- | 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 (xopt Opt_TemplateHaskell . ms_hspp_opts) ms
+
-- | Return @True@ <==> module is loaded.
isLoaded :: GhcMonad m => ModuleName -> m Bool
isLoaded m = 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))
+ occ_env = mkOccEnv [ (nameOccName (idName id), AnId id)
+ | id <- ic_tmp_ids (hsc_IC hsc_env) ]
in
- return filtered
+ return (occEnvElts occ_env)
getPrintUnqual :: GhcMonad m => m PrintUnqualified
getPrintUnqual = withSession $ \hsc_env ->
getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
#ifdef GHCI
getPackageModuleInfo hsc_env mdl = do
- (_msgs, mb_avails) <- getModuleExports hsc_env mdl
+ mb_avails <- hscGetModuleExports hsc_env mdl
case mb_avails of
Nothing -> return Nothing
Just avails -> do
return (Just (ModuleInfo {
minf_type_env = mkTypeEnv tys,
minf_exports = names,
- minf_rdr_env = Just $! nameSetToGlobalRdrEnv names (moduleName mdl),
+ minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails,
minf_instances = error "getModuleInfo: instances for package module unimplemented",
minf_modBreaks = emptyModBreaks
}))
-- 'setContext'.
lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing)
lookupGlobalName name = withSession $ \hsc_env -> do
- eps <- liftIO $ readIORef (hsc_EPS hsc_env)
- return $! lookupType (hsc_dflags hsc_env)
- (hsc_HPT hsc_env) (eps_PTE eps) name
+ 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
#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 = eltsUFM (pkgIdMap (pkgState dflags))
+ return $
+ [ mkModule pid modname | p <- pkgs
+ , not only_exposed || exposed p
+ , let pid = packageConfigId p
+ , modname <- exposedModules p ]
+
+-- -----------------------------------------------------------------------------
-- Misc exported utils
dataConType :: DataCon -> Type
getTokenStream :: GhcMonad m => Module -> m [Located Token]
getTokenStream mod = do
(sourceFile, source, flags) <- getModuleSourceAndFlags mod
- let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0
+ let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream source startLoc flags of
POk _ ts -> return ts
PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
getRichTokenStream mod = do
(sourceFile, source, flags) <- getModuleSourceAndFlags mod
- let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0
+ let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream source startLoc flags of
POk _ ts -> return $ addSourceToTokens startLoc source ts
PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
showRichTokenStream :: [(Located Token, String)] -> String
showRichTokenStream ts = go startLoc ts ""
where sourceFile = srcSpanFile (getLoc . fst . head $ ts)
- startLoc = mkSrcLoc sourceFile 0 0
+ startLoc = mkSrcLoc sourceFile 1 1
go _ [] = id
go loc ((L span _, str):ts)
| not (isGoodSrcSpan span) = go loc ts
-- filesystem and package database to find the corresponding 'Module',
-- using the algorithm that is used for an @import@ declaration.
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
- this_pkg = thisPackage dflags
- in
- case lookupUFM hpt mod_name of
- Just mod_info -> return (mi_module (hm_iface mod_info))
- _not_a_home_module -> do
- res <- findImportedModule hsc_env mod_name maybe_pkg
- case res of
- Found _ m | modulePackageId m /= this_pkg -> return m
- | otherwise -> ghcError (CmdLineError (showSDoc $
- text "module" <+> quotes (ppr (moduleName m)) <+>
- text "is not loaded"))
- err -> let msg = cannotFindModule dflags mod_name err in
- ghcError (CmdLineError (showSDoc msg))
+findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
+ let
+ dflags = hsc_dflags hsc_env
+ this_pkg = thisPackage dflags
+ --
+ case maybe_pkg of
+ Just pkg | fsToPackageId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do
+ res <- findImportedModule hsc_env mod_name maybe_pkg
+ case res of
+ Found _ m -> return m
+ err -> noModError dflags noSrcSpan mod_name err
+ _otherwise -> do
+ home <- lookupLoadedHomeModule mod_name
+ case home of
+ Just m -> return m
+ Nothing -> liftIO $ do
+ res <- findImportedModule hsc_env mod_name maybe_pkg
+ case res of
+ Found loc m | modulePackageId m /= this_pkg -> return m
+ | otherwise -> modNotLoadedError m loc
+ err -> noModError dflags noSrcSpan mod_name err
+
+modNotLoadedError :: Module -> ModLocation -> IO a
+modNotLoadedError m loc = ghcError $ CmdLineError $ showSDoc $
+ text "module is not loaded:" <+>
+ quotes (ppr (moduleName m)) <+>
+ parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
+
+-- | Like 'findModule', but differs slightly when the module refers to
+-- a source file, and the file has not been loaded via 'load'. In
+-- this case, 'findModule' will throw an error (module not loaded),
+-- but 'lookupModule' will check to see whether the module can also be
+-- found in a package, and if so, that package 'Module' will be
+-- returned. If not, the usual module-not-found error will be thrown.
+--
+lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
+lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg)
+lookupModule mod_name Nothing = withSession $ \hsc_env -> do
+ home <- lookupLoadedHomeModule mod_name
+ case home of
+ Just m -> return m
+ Nothing -> liftIO $ do
+ res <- findExposedPackageModule hsc_env mod_name Nothing
+ case res of
+ Found _ m -> return m
+ err -> noModError (hsc_dflags hsc_env) noSrcSpan mod_name err
+
+lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module)
+lookupLoadedHomeModule mod_name = withSession $ \hsc_env ->
+ case lookupUFM (hsc_HPT hsc_env) mod_name of
+ Just mod_info -> return (Just (mi_module (hm_iface mod_info)))
+ _not_a_home_module -> return Nothing
#ifdef GHCI
getHistorySpan :: GhcMonad m => History -> m SrcSpan
liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
#endif
+
+-- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any
+-- entity known to GHC, including 'Name's defined using 'runStmt'.
+lookupName :: GhcMonad m => Name -> m (Maybe TyThing)
+lookupName name =
+ withSession $ \hsc_env ->
+ liftIO $ hscTcRcLookupName hsc_env name
+
+-- -----------------------------------------------------------------------------
+-- Pure API
+
+-- | A pure interface to the module parser.
+--
+parser :: String -- ^ Haskell module source text (full Unicode is supported)
+ -> DynFlags -- ^ the flags
+ -> FilePath -- ^ the filename (for source locations)
+ -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName))
+
+parser str dflags filename =
+ let
+ loc = mkSrcLoc (mkFastString filename) 1 1
+ buf = stringToStringBuffer str
+ in
+ case unP Parser.parseModule (mkPState dflags buf loc) of
+
+ PFailed span err ->
+ Left (unitBag (mkPlainErrMsg span err))
+
+ POk pst rdr_module ->
+ let (warns,_) = getMessages pst in
+ Right (warns, rdr_module)
projects / ghc-hetmet.git / blobdiff