-- * Loading\/compiling the program
depanal,
- load, loadWithCompiler, LoadHowMuch(..), SuccessFlag(..), -- also does depanal
+ load, loadWithLogger, LoadHowMuch(..), SuccessFlag(..), -- also does depanal
+ defaultWarnErrLogger, WarnErrLogger,
workingDirectoryChanged,
parseModule, typecheckModule, desugarModule, loadModule,
ParsedModule, TypecheckedModule, DesugaredModule, -- all abstract
parsedSource, coreModule,
compileToCoreModule, compileToCoreSimplified,
compileCoreToObj,
+ getModSummary,
-- * Parsing Haddock comments
parseHaddockComment,
modInfoIsExportedName,
modInfoLookupName,
lookupGlobalName,
+ findGlobalAnns,
mkPrintUnqualifiedForModule,
-- * Printing
isModuleInterpreted,
InteractiveEval.compileExpr, HValue, dynCompileExpr,
lookupName,
- GHC.obtainTerm, GHC.obtainTerm1, GHC.obtainTermB, reconstructType,
+ GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
modInfoModBreaks,
ModBreaks(..), BreakIndex,
BreakInfo(breakInfo_number, breakInfo_module),
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,
cyclicModuleErr,
import qualified StaticFlags
import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
cleanTempDirs )
+import Annotations
import Module
import LazyUniqFM
import UniqSet
import ErrUtils
import MonadUtils
import Util
-import StringBuffer ( StringBuffer, hGetStringBuffer )
+import StringBuffer ( StringBuffer, hGetStringBuffer, nextChar )
import Outputable
import BasicTypes
import Maybes ( expectJust, mapCatMaybes )
import HaddockParse
import HaddockLex ( tokenise )
import FastString
+import Lexer
import Control.Concurrent
import System.Directory ( getModificationTime, doesFileExist,
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
+ 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 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
| LoadUpTo ModuleName
| LoadDependenciesOf ModuleName
--- | Try to load the program. Calls 'loadWithCompiler' with the default
+-- | Try to load the program. Calls 'loadWithLogger' with the default
-- compiler that just immediately logs all warnings and errors.
load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
load how_much =
- loadWithCompiler defaultCompiler how_much
- where
- defaultCompiler env mod_summary mod_index mod_count
- mb_old_iface mb_linkable =
- handleSourceError logErrorsAndRethrowException $ do
- home_mod_info <- compile env mod_summary mod_index mod_count
- mb_old_iface mb_linkable
- printWarnings
- return home_mod_info
-
- logErrorsAndRethrowException err = do
- printExceptionAndWarnings err
- throw err
+ loadWithLogger defaultWarnErrLogger how_much
+
+-- | 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.
--
--- The first argument is a function that is called to compile a single module.
--- The arguments are the same as 'DriverPipeline.compile'. Use this function
--- to intercept warns and errors from a single module compilation. (Don't
--- forget to actually call 'DriverPipeline.compile' inside that function.
--- XXX: this could be enforced by changing 'ModuleCompiler' to return a static
--- capability which can only be obtained by calling 'DriverPipeline.compile'.)
-
-loadWithCompiler :: GhcMonad m => ModuleCompiler -> LoadHowMuch -> m SuccessFlag
-loadWithCompiler module_compiler how_much = do
+-- 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 module_compiler
+ load2 how_much mod_graph logger
-load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] -> ModuleCompiler
+load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] -> WarnErrLogger
-> m SuccessFlag
-load2 how_much mod_graph mod_comp = do
+load2 how_much mod_graph logger = do
guessOutputFile
hsc_env <- getSession
liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
2 (ppr mg))
(upsweep_ok, hsc_env1, modsUpswept)
- <- upsweep mod_comp
+ <- upsweep logger
(hsc_env { hsc_HPT = emptyHomePackageTable })
pruned_hpt stable_mods cleanup mg
-- - 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
upsweep
:: GhcMonad m =>
- ModuleCompiler -- ^ See argument to 'loadWithCompiler'.
+ WarnErrLogger -- ^ Called to print warnings and errors.
-> HscEnv -- ^ Includes initially-empty HPT
-> HomePackageTable -- ^ HPT from last time round (pruned)
-> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability)
HscEnv, -- With an updated HPT
[ModSummary]) -- Mods which succeeded
-upsweep mod_comp hsc_env old_hpt stable_mods cleanup sccs = do
+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)
where
-- (moduleEnvElts (hsc_HPT hsc_env)))
mb_mod_info
- <- gtry $ gfinally
- (upsweep_mod mod_comp hsc_env old_hpt stable_mods mod mod_index nmods)
- (liftIO cleanup) -- Remove unwanted tmp files between compilations
+ <- 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
+ return (Just mod_info)
+
+ liftIO cleanup -- Remove unwanted tmp files between compilations
case mb_mod_info of
- Left (_ :: SomeException) -> return (Failed, hsc_env, done)
- Right mod_info -> do
+ Nothing -> return (Failed, hsc_env, done)
+ Just mod_info -> do
let this_mod = ms_mod_name mod
-- Add new info to hsc_env
upsweep' hsc_env2 old_hpt1 done' mods (mod_index+1) nmods
--- | Same type as 'DriverPipeline.compile'. See its documentation for
--- argument description.
-type ModuleCompiler = GhcMonad m =>
- HscEnv
- -> ModSummary
- -> Int
- -> Int
- -> Maybe ModIface
- -> Maybe Linkable
- -> m HomeModInfo
-
-- | Compile a single module. Always produce a Linkable for it if
-- successful. If no compilation happened, return the old Linkable.
upsweep_mod :: GhcMonad m =>
- ModuleCompiler
- -> HscEnv
+ HscEnv
-> HomePackageTable
-> ([ModuleName],[ModuleName])
-> ModSummary
-> Int -- total number of modules
-> m HomeModInfo
-upsweep_mod compile hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
+upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
= let
this_mod_name = ms_mod_name summary
this_mod = ms_mod summary
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 by cyclic
+-- 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
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
(srcimps, the_imps, L mod_loc mod_name) <- liftIO $ 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)
return $! lookupType (hsc_dflags hsc_env)
(hsc_HPT hsc_env) (eps_PTE eps) 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
-- :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
getHistorySpan h = withSession $ \hsc_env ->
return$ InteractiveEval.getHistorySpan hsc_env h
-obtainTerm :: GhcMonad m => Bool -> Id -> m Term
-obtainTerm force id = withSession $ \hsc_env ->
- liftIO $ InteractiveEval.obtainTerm hsc_env force id
-
-obtainTerm1 :: GhcMonad m => Bool -> Maybe Type -> a -> m Term
-obtainTerm1 force mb_ty a =
+obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term
+obtainTermFromVal bound force ty a =
withSession $ \hsc_env ->
- liftIO $ InteractiveEval.obtainTerm1 hsc_env force mb_ty a
+ liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a
-obtainTermB :: GhcMonad m => Int -> Bool -> Id -> m Term
-obtainTermB bound force id =
+obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
+obtainTermFromId bound force id =
withSession $ \hsc_env ->
- liftIO $ InteractiveEval.obtainTermB hsc_env bound force id
+ liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
#endif
projects / ghc-hetmet.git / blobdiff