parseModule, typecheckModule, desugarModule, loadModule,
ParsedModule, TypecheckedModule, DesugaredModule, -- all abstract
TypecheckedSource, ParsedSource, RenamedSource, -- ditto
+ TypecheckedMod, ParsedMod,
moduleInfo, renamedSource, typecheckedSource,
parsedSource, coreModule,
compileToCoreModule, compileToCoreSimplified,
compileCoreToObj,
+ getModSummary,
-- * Parsing Haddock comments
parseHaddockComment,
modInfoIsExportedName,
modInfoLookupName,
lookupGlobalName,
+ findGlobalAnns,
mkPrintUnqualifiedForModule,
+ -- * Querying the environment
+ packageDbModules,
+
-- * Printing
PrintUnqualified, alwaysQualify,
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,
import qualified StaticFlags
import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
cleanTempDirs )
+import Annotations
import Module
import LazyUniqFM
+import qualified UniqFM as UFM
import UniqSet
import Unique
import FiniteMap
import Data.Maybe
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
- 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
+ ghandle (\exception -> liftIO $ 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 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
-- | Try to load the program. Calls 'loadWithLogger' with the default
-- compiler that just immediately logs all warnings and errors.
+--
+-- This function may throw a 'SourceError' if errors are encountered before
+-- the actual compilation starts (e.g., during dependency analysis).
+--
load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
load how_much =
loadWithLogger defaultWarnErrLogger how_much
--
-- 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:
-- - 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
+parseModule :: GhcMonad m => ModSummary -> m ParsedModule
+parseModule ms = do
hsc_env0 <- getSession
let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms }
rdr_module <- parseFile hsc_env ms
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,
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)
+ (desugarModule =<< typecheckModule =<< parseModule modSummary)
liftM gutsToCoreModule $
if simplify
then do
= compile hsc_env summary' mod_index nmods Nothing
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 ->
+ 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),
+ 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
-> [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
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
(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
-- 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)
local_opts = getOptions dflags buf src_fn
--
(dflags', leftovers, warns)
- <- parseDynamicFlags dflags local_opts
+ <- parseDynamicNoPackageFlags dflags local_opts
liftIO $ checkProcessArgsResult leftovers -- XXX: throws exceptions
liftIO $ handleFlagWarnings dflags' warns -- XXX: throws exceptions
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 :: GhcMonad m => SrcSpan -> String -> m 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 :: GhcMonad m => ModuleName -> m 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)
-- '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 = 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
dataConType :: DataCon -> Type