-- * 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
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),
-- * Exceptions
GhcException(..), showGhcException,
+ -- * Token stream manipulations
+ Token,
+ getTokenStream, getRichTokenStream,
+ showRichTokenStream, addSourceToTokens,
+
-- * Miscellaneous
--sessionHscEnv,
cyclicModuleErr,
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,
-- 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
exitWith (ExitFailure 1)
) $
#else
- handle (\(SomeException exception) -> do
+ ghandle (\(SomeException exception) -> liftIO $ do
hFlush stdout
case cast exception of
-- an IO exception probably isn't our fault, so don't panic
-- 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)) $
+ (\em -> liftIO $ 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
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
--
-- 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
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
-- :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