X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=b1baecd69a32b5a1d28f2829d5e389ccd70b30b5;hp=afd970214b5f1be4c5c9ac23e396158a0d8d97a1;hb=66579ff945831c5fc9a17c58c722ff01f2268d76;hpb=00fc612dc1e776ef34bd09b4f4ef4f6650d418b0 diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index afd9702..b1baecd 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -1,3 +1,6 @@ +{-# OPTIONS -fno-cse #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly + {-# OPTIONS -#include "Linker.h" #-} ----------------------------------------------------------------------------- -- @@ -11,25 +14,27 @@ module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where #include "HsVersions.h" -import GhciMonad +import qualified GhciMonad +import GhciMonad hiding (runStmt) import GhciTags import Debugger -- The GHC interface -import qualified GHC -import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..), +import qualified GHC hiding (resume, runStmt) +import GHC ( LoadHowMuch(..), Target(..), TargetId(..), Module, ModuleName, TyThing(..), Phase, - BreakIndex, SrcSpan, Resume, SingleStep ) + BreakIndex, SrcSpan, Resume, SingleStep, + Ghc, handleSourceError ) import PprTyThing import DynFlags import Packages -#ifdef USE_READLINE +#ifdef USE_EDITLINE import PackageConfig import UniqFM #endif -import HscTypes ( implicitTyThings ) +import HscTypes ( implicitTyThings, reflectGhc, reifyGhc ) import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC? import Outputable hiding (printForUser, printForUserPartWay) import Module -- for ModuleEnv @@ -37,6 +42,8 @@ import Name import SrcLoc -- Other random utilities +import ErrUtils +import CmdLineParser import Digraph import BasicTypes hiding (isTopLevel) import Panic hiding (showException) @@ -48,25 +55,26 @@ import NameSet import Maybes ( orElse ) import FastString import Encoding +import MonadUtils ( liftIO ) #ifndef mingw32_HOST_OS import System.Posix hiding (getEnv) #else import GHC.ConsoleHandler ( flushConsole ) import qualified System.Win32 -import System.FilePath #endif -#ifdef USE_READLINE +#ifdef USE_EDITLINE import Control.Concurrent ( yield ) -- Used in readline loop -import System.Console.Readline as Readline +import System.Console.Editline.Readline as Readline #endif --import SystemExts -import Control.Exception as Exception +import Exception -- import Control.Concurrent +import System.FilePath import qualified Data.ByteString.Char8 as BS import Data.List import Data.Maybe @@ -89,7 +97,7 @@ import GHC.TopHandler import Data.IORef ( IORef, readIORef, writeIORef ) -#ifdef USE_READLINE +#ifdef USE_EDITLINE import System.Posix.Internals ( setNonBlockingFD ) #endif @@ -102,7 +110,6 @@ ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++ cmdName :: Command -> String cmdName (n,_,_,_) = n -macros_ref :: IORef [Command] GLOBAL_VAR(macros_ref, [], [Command]) builtin_commands :: [Command] @@ -161,7 +168,7 @@ builtin_commands = [ -- -- NOTE: in order for us to override the default correctly, any custom entry -- must be a SUBSET of word_break_chars. -#ifdef USE_READLINE +#ifdef USE_EDITLINE word_break_chars :: String word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~" specials = "(),;[]`{}" @@ -194,7 +201,7 @@ helpText = " evaluate/run \n" ++ " : repeat last command\n" ++ " :{\\n ..lines.. \\n:}\\n multiline command\n" ++ - " :add ... add module(s) to the current target set\n" ++ + " :add [*] ... add module(s) to the current target set\n" ++ " :browse[!] [[*]] display the names defined by module \n" ++ " (!: more details; *: all top-level names)\n" ++ " :cd change directory to \n" ++ @@ -207,7 +214,7 @@ helpText = " :help, :? display this list of commands\n" ++ " :info [ ...] display information about the given names\n" ++ " :kind show the kind of \n" ++ - " :load ... load module(s) and their dependents\n" ++ + " :load [*] ... load module(s) and their dependents\n" ++ " :main [ ...] run the main function with the given arguments\n" ++ " :module [+/-] [*] ... set the context for expression evaluation\n" ++ " :quit exit GHCi\n" ++ @@ -228,15 +235,18 @@ helpText = " :delete * delete all breakpoints\n" ++ " :force print , forcing unevaluated parts\n" ++ " :forward go forward in the history (after :back)\n" ++ - " :history [] show the last items in the history (after :trace)\n" ++ + " :history [] after :trace, show the execution history\n" ++ + " :list show the source code around current breakpoint\n" ++ + " :list identifier show the source code for \n" ++ + " :list [] show the source code around line number \n" ++ " :print [ ...] prints a value without forcing its computation\n" ++ " :sprint [ ...] simplifed version of :print\n" ++ " :step single-step after stopping at a breakpoint\n"++ " :step single-step into \n"++ - " :steplocal single-step restricted to the current top level decl.\n"++ + " :steplocal single-step within the current top-level binding\n"++ " :stepmodule single-step restricted to the current module\n"++ " :trace trace after stopping at a breakpoint\n"++ - " :trace trace into (remembers breakpoints for :history)\n"++ + " :trace evaluate with tracing on (see :history)\n"++ "\n" ++ " -- Commands for changing settings:\n" ++ @@ -267,7 +277,8 @@ helpText = " :show modules show the currently loaded modules\n" ++ " :show packages show the currently active package flags\n" ++ " :show languages show the currently active language flags\n" ++ - " :show show anything that can be set with :set (e.g. args)\n" ++ + " :show show value of , which is one of\n" ++ + " [args, prog, prompt, editor, stop]\n" ++ "\n" findEditor :: IO String @@ -281,9 +292,9 @@ findEditor = do return "" #endif -interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe [String] - -> IO () -interactiveUI session srcs maybe_exprs = do +interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String] + -> Ghc () +interactiveUI srcs maybe_exprs = do -- HACK! If we happen to get into an infinite loop (eg the user -- types 'let x=x in x' at the prompt), then the thread will block -- on a blackhole, and become unreachable during GC. The GC will @@ -292,14 +303,14 @@ interactiveUI session srcs maybe_exprs = do -- it refers to might be finalized, including the standard Handles. -- This sounds like a bug, but we don't have a good solution right -- now. - newStablePtr stdin - newStablePtr stdout - newStablePtr stderr + liftIO $ newStablePtr stdin + liftIO $ newStablePtr stdout + liftIO $ newStablePtr stderr -- Initialise buffering for the *interpreted* I/O system - initInterpBuffering session + initInterpBuffering - when (isNothing maybe_exprs) $ do + liftIO $ when (isNothing maybe_exprs) $ do -- Only for GHCi (not runghc and ghc -e): -- Turn buffering off for the compiled program's stdout/stderr @@ -311,10 +322,15 @@ interactiveUI session srcs maybe_exprs = do -- intended for the program, so unbuffer stdin. hSetBuffering stdin NoBuffering -#ifdef USE_READLINE +#ifdef USE_EDITLINE is_tty <- hIsTerminalDevice stdin - when is_tty $ do + when is_tty $ withReadline $ do Readline.initialize + + withGhcAppData + (\dir -> Readline.readHistory (dir "ghci_history")) + (return True) + Readline.setAttemptedCompletionFunction (Just completeWord) --Readline.parseAndBind "set show-all-if-ambiguous 1" @@ -324,11 +340,12 @@ interactiveUI session srcs maybe_exprs = do #endif -- initial context is just the Prelude - prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude") - (Just basePackageId) - GHC.setContext session [] [prel_mod] + prel_mod <- GHC.findModule (GHC.mkModuleName "Prelude") Nothing + GHC.setContext [] [prel_mod] + + default_editor <- liftIO $ findEditor - default_editor <- findEditor + cwd <- liftIO $ getCurrentDirectory startGHCi (runGHCi srcs maybe_exprs) GHCiState{ progname = "", @@ -336,7 +353,7 @@ interactiveUI session srcs maybe_exprs = do prompt = "%s> ", stop = "", editor = default_editor, - session = session, +-- session = session, options = [], prelude = prel_mod, break_ctr = 0, @@ -344,47 +361,66 @@ interactiveUI session srcs maybe_exprs = do tickarrays = emptyModuleEnv, last_command = Nothing, cmdqueue = [], - remembered_ctx = Nothing + remembered_ctx = [], + virtual_path = cwd, + ghc_e = isJust maybe_exprs } -#ifdef USE_READLINE - Readline.resetTerminal Nothing +#ifdef USE_EDITLINE + liftIO $ do + Readline.stifleHistory 100 + withGhcAppData (\dir -> Readline.writeHistory (dir "ghci_history")) + (return True) + Readline.resetTerminal Nothing #endif return () +withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a +withGhcAppData right left = do + either_dir <- IO.try (getAppUserDataDirectory "ghc") + case either_dir of + Right dir -> right dir + _ -> left + + runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi () runGHCi paths maybe_exprs = do - let read_dot_files = not opt_IgnoreDotGhci + let + read_dot_files = not opt_IgnoreDotGhci - when (read_dot_files) $ do - -- Read in ./.ghci. - let file = "./.ghci" - exists <- io (doesFileExist file) - when exists $ do - dir_ok <- io (checkPerms ".") - file_ok <- io (checkPerms file) + current_dir = return (Just ".ghci") + + app_user_dir = io $ withGhcAppData + (\dir -> return (Just (dir "ghci.conf"))) + (return Nothing) + + home_dir = do + either_dir <- io $ IO.try (getEnv "HOME") + case either_dir of + Right home -> return (Just (home ".ghci")) + _ -> return Nothing + + sourceConfigFile :: FilePath -> GHCi () + sourceConfigFile file = do + exists <- io $ doesFileExist file + when exists $ do + dir_ok <- io $ checkPerms (getDirectory file) + file_ok <- io $ checkPerms file when (dir_ok && file_ok) $ do - either_hdl <- io (IO.try (openFile "./.ghci" ReadMode)) - case either_hdl of - Left _e -> return () - Right hdl -> runCommands (fileLoop hdl False False) + either_hdl <- io $ IO.try (openFile file ReadMode) + case either_hdl of + Left _e -> return () + Right hdl -> runCommands (fileLoop hdl False False) + where + getDirectory f = case takeDirectory f of "" -> "."; d -> d when (read_dot_files) $ do - -- Read in $HOME/.ghci - either_dir <- io (IO.try getHomeDirectory) - case either_dir of - Left _e -> return () - Right dir -> do - cwd <- io (getCurrentDirectory) - when (dir /= cwd) $ do - let file = dir ++ "/.ghci" - ok <- io (checkPerms file) - when ok $ do - either_hdl <- io (IO.try (openFile file ReadMode)) - case either_hdl of - Left _e -> return () - Right hdl -> runCommands (fileLoop hdl False False) + cfgs0 <- sequence [ current_dir, app_user_dir, home_dir ] + cfgs <- io $ mapM canonicalizePath (catMaybes cfgs0) + mapM_ sourceConfigFile (nub cfgs) + -- nub, because we don't want to read .ghci twice if the + -- CWD is $HOME. -- Perform a :load for files given on the GHCi command line -- When in -e mode, if the load fails then we want to stop @@ -425,12 +461,8 @@ runGHCi paths maybe_exprs = do -- current progname in the exception text: -- : io $ withProgName (progname st) - -- The "fast exit" part just calls exit() - -- directly instead of doing an orderly - -- runtime shutdown, otherwise the main - -- GHCi thread will complain about being - -- interrupted. - $ topHandlerFastExit e + -- this used to be topHandlerFastExit, see #2228 + $ topHandler e runCommands' handle (return Nothing) -- and finally, exit @@ -439,7 +471,7 @@ runGHCi paths maybe_exprs = do interactiveLoop :: Bool -> Bool -> GHCi () interactiveLoop is_tty show_prompt = -- Ignore ^C exceptions caught here - ghciHandleDyn (\e -> case e of + ghciHandleGhcException (\e -> case e of Interrupted -> do #if defined(mingw32_HOST_OS) io (putStrLn "") @@ -451,7 +483,7 @@ interactiveLoop is_tty show_prompt = -- exception handler above. -- read commands from stdin -#ifdef USE_READLINE +#ifdef USE_EDITLINE if (is_tty) then runCommands readlineLoop else runCommands (fileLoop stdin show_prompt is_tty) @@ -475,7 +507,7 @@ checkPerms _ = return True #else checkPerms name = - Util.handle (\_ -> return False) $ do + handleIO (\_ -> return False) $ do st <- getFileStatus name me <- getRealUserID if fileOwner st /= me then do @@ -537,9 +569,8 @@ decodeStringAsUTF8 str = mkPrompt :: GHCi String mkPrompt = do - session <- getSession - (toplevs,exports) <- io (GHC.getContext session) - resumes <- io $ GHC.getResumeContext session + (toplevs,exports) <- GHC.getContext + resumes <- GHC.getResumeContext -- st <- getGHCiState context_bit <- @@ -551,7 +582,7 @@ mkPrompt = do then return (brackets (ppr (GHC.resumeSpan r)) <> space) else do let hist = GHC.resumeHistory r !! (ix-1) - span <- io$ GHC.getHistorySpan session hist + span <- GHC.getHistorySpan hist return (brackets (ppr (negate ix) <> char ':' <+> ppr span) <> space) let @@ -579,22 +610,35 @@ mkPrompt = do return (showSDoc (f (prompt st))) -#ifdef USE_READLINE +#ifdef USE_EDITLINE readlineLoop :: GHCi (Maybe String) readlineLoop = do io yield saveSession -- for use by completion prompt <- mkPrompt - l <- io (readline prompt `finally` setNonBlockingFD 0) - -- readline sometimes puts stdin into blocking mode, - -- so we need to put it back for the IO library + l <- io $ withReadline (readline prompt) splatSavedSession case l of Nothing -> return Nothing + Just "" -> return (Just "") -- Don't put empty lines in the history Just l -> do io (addHistory l) str <- io $ consoleInputToUnicode True l return (Just str) + +withReadline :: IO a -> IO a +withReadline = bracket_ stopTimer (do startTimer; setNonBlockingFD 0) + -- Two problems are being worked around here: + -- 1. readline sometimes puts stdin into blocking mode, + -- so we need to put it back for the IO library + -- 2. editline doesn't handle some of its system calls returning + -- EINTR, so our timer signal confuses it, hence we turn off + -- the timer signal when making calls to editline. (#2277) + -- If editline is ever fixed, we can remove this. + +-- These come from the RTS +foreign import ccall unsafe startTimer :: IO () +foreign import ccall unsafe stopTimer :: IO () #endif queryQueue :: GHCi (Maybe String) @@ -608,7 +652,7 @@ queryQueue = do runCommands :: GHCi (Maybe String) -> GHCi () runCommands = runCommands' handler -runCommands' :: (Exception -> GHCi Bool) -- Exception handler +runCommands' :: (SomeException -> GHCi Bool) -- Exception handler -> GHCi (Maybe String) -> GHCi () runCommands' eh getCmd = do mb_cmd <- noSpace queryQueue @@ -616,9 +660,15 @@ runCommands' eh getCmd = do case mb_cmd of Nothing -> return () Just c -> do - b <- ghciHandle eh (doCommand c) + b <- ghciHandle eh $ + handleSourceError printErrorAndKeepGoing + (doCommand c) if b then return () else runCommands' eh getCmd where + printErrorAndKeepGoing err = do + GHC.printExceptionAndWarnings err + return True + noSpace q = q >>= maybe (return Nothing) (\c->case removeSpaces c of "" -> noSpace q @@ -663,48 +713,43 @@ runStmt stmt step | null (filter (not.isSpace) stmt) = return False | ["import", mod] <- words stmt = keepGoing setContext ('+':mod) | otherwise - = do st <- getGHCiState - session <- getSession - result <- io $ withProgName (progname st) $ withArgs (args st) $ - GHC.runStmt session stmt step + = do result <- GhciMonad.runStmt stmt step afterRunStmt (const True) result - --afterRunStmt :: GHC.RunResult -> GHCi Bool -- False <=> the statement failed to compile afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool afterRunStmt _ (GHC.RunException e) = throw e afterRunStmt step_here run_result = do - session <- getSession - resumes <- io $ GHC.getResumeContext session + resumes <- GHC.getResumeContext case run_result of GHC.RunOk names -> do show_types <- isOptionSet ShowType - when show_types $ printTypeOfNames session names + when show_types $ printTypeOfNames names GHC.RunBreak _ names mb_info | isNothing mb_info || step_here (GHC.resumeSpan $ head resumes) -> do - printForUser $ ptext SLIT("Stopped at") <+> + printForUser $ ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan $ head resumes) -- printTypeOfNames session names let namesSorted = sortBy compareNames names tythings <- catMaybes `liftM` - io (mapM (GHC.lookupName session) namesSorted) - docs <- io$ pprTypeAndContents session [id | AnId id <- tythings] + mapM GHC.lookupName namesSorted + docs <- pprTypeAndContents [id | AnId id <- tythings] printForUserPartWay docs maybe (return ()) runBreakCmd mb_info -- run the command set with ":set stop " st <- getGHCiState enqueueCommands [stop st] return () - | otherwise -> io(GHC.resume session GHC.SingleStep) >>= + | otherwise -> resume GHC.SingleStep >>= afterRunStmt step_here >> return () _ -> return () flushInterpBuffers io installSignalHandlers b <- isOptionSet RevertCAFs - io (when b revertCAFs) + when b revertCAFs return (case run_result of GHC.RunOk _ -> True; _ -> False) @@ -720,17 +765,17 @@ runBreakCmd info = do | otherwise -> do enqueueCommands [cmd]; return () where cmd = onBreakCmd loc -printTypeOfNames :: Session -> [Name] -> GHCi () -printTypeOfNames session names - = mapM_ (printTypeOfName session) $ sortBy compareNames names +printTypeOfNames :: [Name] -> GHCi () +printTypeOfNames names + = mapM_ (printTypeOfName ) $ sortBy compareNames names compareNames :: Name -> Name -> Ordering n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2 where compareWith n = (getOccString n, getSrcSpan n) -printTypeOfName :: Session -> Name -> GHCi () -printTypeOfName session n - = do maybe_tything <- io (GHC.lookupName session n) +printTypeOfName :: Name -> GHCi () +printTypeOfName n + = do maybe_tything <- GHC.lookupName n case maybe_tything of Nothing -> return () Just thing -> printTyThing thing @@ -781,8 +826,7 @@ lookupCommand' str = do getCurrentBreakSpan :: GHCi (Maybe SrcSpan) getCurrentBreakSpan = do - session <- getSession - resumes <- io $ GHC.getResumeContext session + resumes <- GHC.getResumeContext case resumes of [] -> return Nothing (r:_) -> do @@ -791,13 +835,12 @@ getCurrentBreakSpan = do then return (Just (GHC.resumeSpan r)) else do let hist = GHC.resumeHistory r !! (ix-1) - span <- io $ GHC.getHistorySpan session hist + span <- GHC.getHistorySpan hist return (Just span) getCurrentBreakModule :: GHCi (Maybe Module) getCurrentBreakModule = do - session <- getSession - resumes <- io $ GHC.getResumeContext session + resumes <- GHC.getResumeContext case resumes of [] -> return Nothing (r:_) -> do @@ -819,21 +862,22 @@ help :: String -> GHCi () help _ = io (putStr helpText) info :: String -> GHCi () -info "" = throwDyn (CmdLineError "syntax: ':i '") -info s = do { let names = words s - ; session <- getSession +info "" = ghcError (CmdLineError "syntax: ':i '") +info s = handleSourceError GHC.printExceptionAndWarnings $ do + { let names = words s ; dflags <- getDynFlags ; let pefas = dopt Opt_PrintExplicitForalls dflags - ; mapM_ (infoThing pefas session) names } + ; mapM_ (infoThing pefas) names } where - infoThing pefas session str = io $ do - names <- GHC.parseName session str - mb_stuffs <- mapM (GHC.getInfo session) names + infoThing pefas str = do + names <- GHC.parseName str + mb_stuffs <- mapM GHC.getInfo names let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) - unqual <- GHC.getPrintUnqual session - putStrLn (showSDocForUser unqual $ - vcat (intersperse (text "") $ - map (pprInfo pefas) filtered)) + unqual <- GHC.getPrintUnqual + liftIO $ + putStrLn (showSDocForUser unqual $ + vcat (intersperse (text "") $ + map (pprInfo pefas) filtered)) -- Filter out names whose parent is also there Good -- example is '[]', which is both a type and data @@ -874,14 +918,15 @@ doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++ addModule :: [FilePath] -> GHCi () addModule files = do - io (revertCAFs) -- always revert CAFs on load/add. + revertCAFs -- always revert CAFs on load/add. files <- mapM expandPath files - targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files - session <- getSession - io (mapM_ (GHC.addTarget session) targets) - prev_context <- io $ GHC.getContext session - ok <- io (GHC.load session LoadAllTargets) - afterLoad ok session False prev_context + targets <- mapM (\m -> GHC.guessTarget m Nothing) files + -- remove old targets with the same id; e.g. for :add *M + mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ] + mapM_ GHC.addTarget targets + prev_context <- GHC.getContext + ok <- trySuccess $ GHC.load LoadAllTargets + afterLoad ok False prev_context changeDirectory :: String -> GHCi () changeDirectory "" = do @@ -891,25 +936,30 @@ changeDirectory "" = do Left _e -> return () Right dir -> changeDirectory dir changeDirectory dir = do - session <- getSession - graph <- io (GHC.getModuleGraph session) + graph <- GHC.getModuleGraph when (not (null graph)) $ io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n" - prev_context <- io $ GHC.getContext session - io (GHC.setTargets session []) - io (GHC.load session LoadAllTargets) - setContextAfterLoad session prev_context [] - io (GHC.workingDirectoryChanged session) + prev_context <- GHC.getContext + GHC.setTargets [] + GHC.load LoadAllTargets + setContextAfterLoad prev_context False [] + GHC.workingDirectoryChanged dir <- expandPath dir io (setCurrentDirectory dir) +trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag +trySuccess act = + handleSourceError (\e -> do GHC.printExceptionAndWarnings e + return Failed) $ do + act + editFile :: String -> GHCi () editFile str = do file <- if null str then chooseEditFile else return str st <- getGHCiState let cmd = editor st when (null cmd) - $ throwDyn (CmdLineError "editor not set, use :set editor") + $ ghcError (CmdLineError "editor not set, use :set editor") io $ system (cmd ++ ' ':file) return () @@ -925,10 +975,9 @@ editFile str = -- of those. chooseEditFile :: GHCi String chooseEditFile = - do session <- getSession - let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x + do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x - graph <- io (GHC.getModuleGraph session) + graph <- GHC.getModuleGraph failed_graph <- filterM hasFailed graph let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing pick xs = case xs of @@ -938,12 +987,12 @@ chooseEditFile = case pick (order failed_graph) of Just file -> return file Nothing -> - do targets <- io (GHC.getTargets session) + do targets <- GHC.getTargets case msum (map fromTarget targets) of Just file -> return file - Nothing -> throwDyn (CmdLineError "No files to edit.") + Nothing -> ghcError (CmdLineError "No files to edit.") - where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f + where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f fromTarget _ = Nothing -- when would we get a module target? defineMacro :: Bool{-overwrite-} -> String -> GHCi () @@ -958,7 +1007,7 @@ defineMacro overwrite s = do unlines defined) else do if (not overwrite && macro_name `elem` defined) - then throwDyn (CmdLineError + then ghcError (CmdLineError ("macro '" ++ macro_name ++ "' is already defined")) else do @@ -969,12 +1018,10 @@ defineMacro overwrite s = do let new_expr = '(' : definition ++ ") :: String -> IO String" -- compile the expression - cms <- getSession - maybe_hv <- io (GHC.compileExpr cms new_expr) - case maybe_hv of - Nothing -> return () - Just hv -> io (writeIORef macros_ref -- - (filtered ++ [(macro_name, runMacro hv, Nothing, completeNone)])) + handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do + hv <- GHC.compileExpr new_expr + io (writeIORef macros_ref -- + (filtered ++ [(macro_name, runMacro hv, Nothing, completeNone)])) runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool runMacro fun s = do @@ -987,7 +1034,7 @@ undefineMacro str = mapM_ undef (words str) where undef macro_name = do cmds <- io (readIORef macros_ref) if (macro_name `notElem` map cmdName cmds) - then throwDyn (CmdLineError + then ghcError (CmdLineError ("macro '" ++ macro_name ++ "' is not defined")) else do io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds)) @@ -995,14 +1042,11 @@ undefineMacro str = mapM_ undef (words str) cmdCmd :: String -> GHCi () cmdCmd str = do let expr = '(' : str ++ ") :: IO String" - session <- getSession - maybe_hv <- io (GHC.compileExpr session expr) - case maybe_hv of - Nothing -> return () - Just hv -> do - cmds <- io $ (unsafeCoerce# hv :: IO String) - enqueueCommands (lines cmds) - return () + handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do + hv <- GHC.compileExpr expr + cmds <- io $ (unsafeCoerce# hv :: IO String) + enqueueCommands (lines cmds) + return () loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag loadModule fs = timeIt (loadModule' fs) @@ -1012,115 +1056,83 @@ loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return () loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag loadModule' files = do - session <- getSession - prev_context <- io $ GHC.getContext session + prev_context <- GHC.getContext -- unload first + GHC.abandonAll discardActiveBreakPoints - io (GHC.setTargets session []) - io (GHC.load session LoadAllTargets) + GHC.setTargets [] + GHC.load LoadAllTargets -- expand tildes let (filenames, phases) = unzip files exp_filenames <- mapM expandPath filenames let files' = zip exp_filenames phases - targets <- io (mapM (uncurry GHC.guessTarget) files') + targets <- mapM (uncurry GHC.guessTarget) files' -- NOTE: we used to do the dependency anal first, so that if it -- fails we didn't throw away the current set of modules. This would -- require some re-working of the GHC interface, so we'll leave it -- as a ToDo for now. - io (GHC.setTargets session targets) - doLoad session False prev_context LoadAllTargets + GHC.setTargets targets + doLoad False prev_context LoadAllTargets checkModule :: String -> GHCi () checkModule m = do let modl = GHC.mkModuleName m - session <- getSession - prev_context <- io $ GHC.getContext session - result <- io (GHC.checkModule session modl False) - case result of - Nothing -> io $ putStrLn "Nothing" - Just r -> io $ putStrLn (showSDoc ( - case GHC.checkedModuleInfo r of - Just cm | Just scope <- GHC.modInfoTopLevelScope cm -> + prev_context <- GHC.getContext + ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do + r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl + io $ putStrLn (showSDoc ( + case GHC.moduleInfo r of + cm | Just scope <- GHC.modInfoTopLevelScope cm -> let - (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope + (local,global) = ASSERT( all isExternalName scope ) + partition ((== modl) . GHC.moduleName . GHC.nameModule) scope in (text "global names: " <+> ppr global) $$ (text "local names: " <+> ppr local) - _ -> empty)) - afterLoad (successIf (isJust result)) session False prev_context + _ -> empty)) + return True + afterLoad (successIf ok) False prev_context reloadModule :: String -> GHCi () reloadModule m = do - session <- getSession - prev_context <- io $ GHC.getContext session - doLoad session True prev_context $ + prev_context <- GHC.getContext + doLoad True prev_context $ if null m then LoadAllTargets else LoadUpTo (GHC.mkModuleName m) return () -doLoad :: Session -> Bool -> ([Module],[Module]) -> LoadHowMuch -> GHCi SuccessFlag -doLoad session retain_context prev_context howmuch = do +doLoad :: Bool -> ([Module],[Module]) -> LoadHowMuch -> GHCi SuccessFlag +doLoad retain_context prev_context howmuch = do -- turn off breakpoints before we load: we can't turn them off later, because -- the ModBreaks will have gone away. discardActiveBreakPoints - ok <- io (GHC.load session howmuch) - afterLoad ok session retain_context prev_context + ok <- trySuccess $ GHC.load howmuch + afterLoad ok retain_context prev_context return ok -afterLoad :: SuccessFlag -> Session -> Bool -> ([Module],[Module]) -> GHCi () -afterLoad ok session retain_context prev_context = do - io (revertCAFs) -- always revert CAFs on load. +afterLoad :: SuccessFlag -> Bool -> ([Module],[Module]) -> GHCi () +afterLoad ok retain_context prev_context = do + revertCAFs -- always revert CAFs on load. discardTickArrays - loaded_mod_summaries <- getLoadedModules session + loaded_mod_summaries <- getLoadedModules let loaded_mods = map GHC.ms_mod loaded_mod_summaries loaded_mod_names = map GHC.moduleName loaded_mods modulesLoadedMsg ok loaded_mod_names - st <- getGHCiState - if not retain_context - then do - setGHCiState st{ remembered_ctx = Nothing } - setContextAfterLoad session prev_context loaded_mod_summaries - else do - -- figure out which modules we can keep in the context, which we - -- have to put back, and which we have to remember because they - -- are (temporarily) unavailable. See ghci.prog009, #1873, #1360 - let (as,bs) = prev_context - as1 = filter isHomeModule as -- package modules are kept anyway - bs1 = filter isHomeModule bs - (as_ok, as_bad) = partition (`elem` loaded_mods) as1 - (bs_ok, bs_bad) = partition (`elem` loaded_mods) bs1 - (rem_as, rem_bs) = fromMaybe ([],[]) (remembered_ctx st) - (rem_as_ok, rem_as_bad) = partition (`elem` loaded_mods) rem_as - (rem_bs_ok, rem_bs_bad) = partition (`elem` loaded_mods) rem_bs - as' = nub (as_ok++rem_as_ok) - bs' = nub (bs_ok++rem_bs_ok) - rem_as' = nub (rem_as_bad ++ as_bad) - rem_bs' = nub (rem_bs_bad ++ bs_bad) - - -- Put back into the context any modules that we previously had - -- to drop because they weren't available (rem_as_ok, rem_bs_ok). - setContextKeepingPackageModules session prev_context (as',bs') - - -- If compilation failed, remember any modules that we are unable - -- to load, so that we can put them back in the context in the future. - case ok of - Succeeded -> setGHCiState st{ remembered_ctx = Nothing } - Failed -> setGHCiState st{ remembered_ctx = Just (rem_as',rem_bs') } - - - -setContextAfterLoad :: Session -> ([Module],[Module]) -> [GHC.ModSummary] -> GHCi () -setContextAfterLoad session prev [] = do + setContextAfterLoad prev_context retain_context loaded_mod_summaries + + +setContextAfterLoad :: ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi () +setContextAfterLoad prev keep_ctxt [] = do prel_mod <- getPrelude - setContextKeepingPackageModules session prev ([], [prel_mod]) -setContextAfterLoad session prev ms = do + setContextKeepingPackageModules prev keep_ctxt ([], [prel_mod]) +setContextAfterLoad prev keep_ctxt ms = do -- load a target if one is available, otherwise load the topmost module. - targets <- io (GHC.getTargets session) + targets <- GHC.getTargets case [ m | Just m <- map (findTarget ms) targets ] of [] -> let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in @@ -1133,32 +1145,39 @@ setContextAfterLoad session prev ms = do [] -> Nothing (m:_) -> Just m - summary `matches` Target (TargetModule m) _ + summary `matches` Target (TargetModule m) _ _ = GHC.ms_mod_name summary == m - summary `matches` Target (TargetFile f _) _ + summary `matches` Target (TargetFile f _) _ _ | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f' _ `matches` _ = False load_this summary | m <- GHC.ms_mod summary = do - b <- io (GHC.moduleIsInterpreted session m) - if b then setContextKeepingPackageModules session prev ([m], []) + b <- GHC.moduleIsInterpreted m + if b then setContextKeepingPackageModules prev keep_ctxt ([m], []) else do prel_mod <- getPrelude - setContextKeepingPackageModules session prev ([],[prel_mod,m]) + setContextKeepingPackageModules prev keep_ctxt ([],[prel_mod,m]) -- | Keep any package modules (except Prelude) when changing the context. setContextKeepingPackageModules - :: Session - -> ([Module],[Module]) -- previous context + :: ([Module],[Module]) -- previous context + -> Bool -- re-execute :module commands -> ([Module],[Module]) -- new context -> GHCi () -setContextKeepingPackageModules session prev_context (as,bs) = do +setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do let (_,bs0) = prev_context prel_mod <- getPrelude let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0 let bs1 = if null as then nub (prel_mod : bs) else bs - io $ GHC.setContext session as (nub (bs1 ++ pkg_modules)) + GHC.setContext as (nub (bs1 ++ pkg_modules)) + if keep_ctxt + then do + st <- getGHCiState + mapM_ (playCtxtCmd False) (remembered_ctx st) + else do + st <- getGHCiState + setGHCiState st{ remembered_ctx = [] } isHomeModule :: Module -> Bool isHomeModule mod = GHC.modulePackageId mod == mainPackageId @@ -1180,22 +1199,18 @@ modulesLoadedMsg ok mods = do typeOfExpr :: String -> GHCi () typeOfExpr str - = do cms <- getSession - maybe_ty <- io (GHC.exprType cms str) - case maybe_ty of - Nothing -> return () - Just ty -> do dflags <- getDynFlags - let pefas = dopt Opt_PrintExplicitForalls dflags - printForUser $ text str <+> dcolon - <+> pprTypeForUser pefas ty + = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do + ty <- GHC.exprType str + dflags <- getDynFlags + let pefas = dopt Opt_PrintExplicitForalls dflags + printForUser $ text str <+> dcolon + <+> pprTypeForUser pefas ty kindOfType :: String -> GHCi () kindOfType str - = do cms <- getSession - maybe_ty <- io (GHC.typeKind cms str) - case maybe_ty of - Nothing -> return () - Just ty -> printForUser $ text str <+> dcolon <+> ppr ty + = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do + ty <- GHC.typeKind str + printForUser $ text str <+> dcolon <+> ppr ty quit :: String -> GHCi Bool quit _ = return True @@ -1216,16 +1231,15 @@ browseCmd bang m = m <- lookupModule s browseModule bang m True [] -> do - s <- getSession - (as,bs) <- io $ GHC.getContext s + (as,bs) <- GHC.getContext -- Guess which module the user wants to browse. Pick -- modules that are interpreted first. The most -- recently-added module occurs last, it seems. case (as,bs) of (as@(_:_), _) -> browseModule bang (last as) True ([], bs@(_:_)) -> browseModule bang (last bs) True - ([], []) -> throwDyn (CmdLineError ":browse: no current module") - _ -> throwDyn (CmdLineError "syntax: :browse ") + ([], []) -> ghcError (CmdLineError ":browse: no current module") + _ -> ghcError (CmdLineError "syntax: :browse ") -- without bang, show items in context of their parents and omit children -- with bang, show class methods and data constructors separately, and @@ -1233,23 +1247,22 @@ browseCmd bang m = -- with sorted, sort items alphabetically browseModule :: Bool -> Module -> Bool -> GHCi () browseModule bang modl exports_only = do - s <- getSession -- :browse! reports qualifiers wrt current context - current_unqual <- io (GHC.getPrintUnqual s) + current_unqual <- GHC.getPrintUnqual -- Temporarily set the context to the module we're interested in, -- just so we can get an appropriate PrintUnqualified - (as,bs) <- io (GHC.getContext s) + (as,bs) <- GHC.getContext prel_mod <- getPrelude - io (if exports_only then GHC.setContext s [] [prel_mod,modl] - else GHC.setContext s [modl] []) - target_unqual <- io (GHC.getPrintUnqual s) - io (GHC.setContext s as bs) + if exports_only then GHC.setContext [] [prel_mod,modl] + else GHC.setContext [modl] [] + target_unqual <- GHC.getPrintUnqual + GHC.setContext as bs let unqual = if bang then current_unqual else target_unqual - mb_mod_info <- io $ GHC.getModuleInfo s modl + mb_mod_info <- GHC.getModuleInfo modl case mb_mod_info of - Nothing -> throwDyn (CmdLineError ("unknown module: " ++ + Nothing -> ghcError (CmdLineError ("unknown module: " ++ GHC.moduleNameString (GHC.moduleName modl))) Just mod_info -> do dflags <- getDynFlags @@ -1263,7 +1276,8 @@ browseModule bang modl exports_only = do -- We would like to improve this; see #1799. sorted_names = loc_sort local ++ occ_sort external where - (local,external) = partition ((==modl) . nameModule) names + (local,external) = ASSERT( all isExternalName names ) + partition ((==modl) . nameModule) names occ_sort = sortBy (compare `on` nameOccName) -- try to sort by src location. If the first name in -- our list has a good source location, then they all should. @@ -1273,10 +1287,10 @@ browseModule bang modl exports_only = do | otherwise = occ_sort names - mb_things <- io $ mapM (GHC.lookupName s) sorted_names + mb_things <- mapM GHC.lookupName sorted_names let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things) - rdr_env <- io $ GHC.getGRE s + rdr_env <- GHC.getGRE let pefas = dopt Opt_PrintExplicitForalls dflags things | bang = catMaybes mb_things @@ -1317,60 +1331,64 @@ browseModule bang modl exports_only = do setContext :: String -> GHCi () setContext str - | all sensible mods = fn mods - | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn") + | all sensible strs = do + playCtxtCmd True (cmd, as, bs) + st <- getGHCiState + setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] } + | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn") where - (fn, mods) = case str of - '+':stuff -> (addToContext, words stuff) - '-':stuff -> (removeFromContext, words stuff) - stuff -> (newContext, words stuff) + (cmd, strs, as, bs) = + case str of + '+':stuff -> rest AddModules stuff + '-':stuff -> rest RemModules stuff + stuff -> rest SetContext stuff + + rest cmd stuff = (cmd, strs, as, bs) + where strs = words stuff + (as,bs) = partitionWith starred strs sensible ('*':m) = looksLikeModuleName m sensible m = looksLikeModuleName m -separate :: Session -> [String] -> [Module] -> [Module] - -> GHCi ([Module],[Module]) -separate _ [] as bs = return (as,bs) -separate session (('*':str):ms) as bs = do - m <- wantInterpretedModule str - separate session ms (m:as) bs -separate session (str:ms) as bs = do - m <- lookupModule str - separate session ms as (m:bs) - -newContext :: [String] -> GHCi () -newContext strs = do - s <- getSession - (as,bs) <- separate s strs [] [] - prel_mod <- getPrelude - let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs - io $ GHC.setContext s as bs' - - -addToContext :: [String] -> GHCi () -addToContext strs = do - s <- getSession - (as,bs) <- io $ GHC.getContext s - - (new_as,new_bs) <- separate s strs [] [] - - let as_to_add = new_as \\ (as ++ bs) - bs_to_add = new_bs \\ (as ++ bs) - - io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add) - - -removeFromContext :: [String] -> GHCi () -removeFromContext strs = do - s <- getSession - (as,bs) <- io $ GHC.getContext s - - (as_to_remove,bs_to_remove) <- separate s strs [] [] - - let as' = as \\ (as_to_remove ++ bs_to_remove) - bs' = bs \\ (as_to_remove ++ bs_to_remove) - - io $ GHC.setContext s as' bs' + starred ('*':m) = Left m + starred m = Right m + +playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi () +playCtxtCmd fail (cmd, as, bs) + = do + (as',bs') <- do_checks fail + (prev_as,prev_bs) <- GHC.getContext + (new_as, new_bs) <- + case cmd of + SetContext -> do + prel_mod <- getPrelude + let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs' + else bs' + return (as',bs'') + AddModules -> do + let as_to_add = as' \\ (prev_as ++ prev_bs) + bs_to_add = bs' \\ (prev_as ++ prev_bs) + return (prev_as ++ as_to_add, prev_bs ++ bs_to_add) + RemModules -> do + let new_as = prev_as \\ (as' ++ bs') + new_bs = prev_bs \\ (as' ++ bs') + return (new_as, new_bs) + GHC.setContext new_as new_bs + where + do_checks True = do + as' <- mapM wantInterpretedModule as + bs' <- mapM lookupModule bs + return (as',bs') + do_checks False = do + as' <- mapM (trymaybe . wantInterpretedModule) as + bs' <- mapM (trymaybe . lookupModule) bs + return (catMaybes as', catMaybes bs') + + trymaybe m = do + r <- ghciTry m + case r of + Left _ -> return Nothing + Right a -> return (Just a) ---------------------------------------------------------------------------- -- Code for `:set' @@ -1401,13 +1419,13 @@ setCmd "" vcat (text "other dynamic, non-language, flag settings:" :map (flagSetting dflags) nonLanguageDynFlags) )) - where flagSetting dflags (str,f) + where flagSetting dflags (str, f, _) | dopt f dflags = text " " <> text "-f" <> text str | otherwise = text " " <> text "-fno-" <> text str - (ghciFlags,others) = partition (\(_,f)->f `elem` flags) + (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags) DynFlags.fFlags - nonLanguageDynFlags = filter (\(_,f)->not $ f `elem` map snd xFlags) - others + nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions) + others flags = [Opt_PrintExplicitForalls ,Opt_PrintBindResult ,Opt_BreakOnException @@ -1483,12 +1501,12 @@ newDynFlags :: [String] -> GHCi () newDynFlags minus_opts = do dflags <- getDynFlags let pkg_flags = packageFlags dflags - (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts + (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts + io $ handleFlagWarnings dflags' warns if (not (null leftovers)) - then throwDyn (CmdLineError ("unrecognised flags: " ++ - unwords leftovers)) - else return () + then ghcError $ errorsToGhcException leftovers + else return () new_pkgs <- setDynFlags dflags' @@ -1496,13 +1514,12 @@ newDynFlags minus_opts = do -- and link the new packages. dflags <- getDynFlags when (packageFlags dflags /= pkg_flags) $ do - io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..." - session <- getSession - io (GHC.setTargets session []) - io (GHC.load session LoadAllTargets) + io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..." + GHC.setTargets [] + GHC.load LoadAllTargets io (linkPackages dflags new_pkgs) -- package flags changed, we can't re-use any of the old context - setContextAfterLoad session ([],[]) [] + setContextAfterLoad ([],[]) False [] return () @@ -1520,7 +1537,7 @@ unsetOptions str mapM_ unsetOpt plus_opts let no_flag ('-':'f':rest) = return ("-fno-" ++ rest) - no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f)) + no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f)) no_flags <- mapM no_flag minus_opts newDynFlags no_flags @@ -1575,26 +1592,25 @@ showCmd str = do ["context"] -> showContext ["packages"] -> showPackages ["languages"] -> showLanguages - _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]") + _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++ + " | breaks | context | packages | languages ]")) showModules :: GHCi () showModules = do - session <- getSession - loaded_mods <- getLoadedModules session + loaded_mods <- getLoadedModules -- we want *loaded* modules only, see #1734 - let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m) + let show_one ms = do m <- GHC.showModule ms; io (putStrLn m) mapM_ show_one loaded_mods -getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary] -getLoadedModules session = do - graph <- io (GHC.getModuleGraph session) - filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph +getLoadedModules :: GHCi [GHC.ModSummary] +getLoadedModules = do + graph <- GHC.getModuleGraph + filterM (GHC.isLoaded . GHC.ms_mod_name) graph showBindings :: GHCi () showBindings = do - s <- getSession - bindings <- io (GHC.getBindings s) - docs <- io$ pprTypeAndContents s + bindings <- GHC.getBindings + docs <- pprTypeAndContents [ id | AnId id <- sortBy compareTyThings bindings] printForUserPartWay docs @@ -1613,13 +1629,12 @@ showBkptTable = do showContext :: GHCi () showContext = do - session <- getSession - resumes <- io $ GHC.getResumeContext session + resumes <- GHC.getResumeContext printForUser $ vcat (map pp_resume (reverse resumes)) where pp_resume resume = - ptext SLIT("--> ") <> text (GHC.resumeStmt resume) - $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume)) + ptext (sLit "--> ") <> text (GHC.resumeStmt resume) + $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume)) showPackages :: GHCi () showPackages = do @@ -1630,7 +1645,8 @@ showPackages = do pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags io $ putStrLn $ showSDoc $ vcat $ text "packages currently loaded:" - : map (nest 2 . text . packageIdString) pkg_ids + : map (nest 2 . text . packageIdString) + (sortBy (compare `on` packageIdFS) pkg_ids) where showFlag (ExposePackage p) = text $ " -package " ++ p showFlag (HidePackage p) = text $ " -hide-package " ++ p showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p @@ -1640,7 +1656,7 @@ showLanguages = do dflags <- getDynFlags io $ putStrLn $ showSDoc $ vcat $ text "active language flags:" : - [text (" -X" ++ str) | (str,f) <- DynFlags.xFlags, dopt f dflags] + [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags] -- ----------------------------------------------------------------------------- -- Completion @@ -1653,7 +1669,7 @@ completeMacro, completeIdentifier, completeModule, completeHomeModuleOrFile :: String -> IO [String] -#ifdef USE_READLINE +#ifdef USE_EDITLINE completeWord :: String -> Int -> Int -> IO (Maybe (String, [String])) completeWord w start end = do line <- Readline.getLineBuffer @@ -1681,7 +1697,7 @@ completeWord w start end = do (s,r') = span isBreak r in (n,w):words' isBreak (n+length w+length s) r' -- In a Haskell expression we want to parse 'a-b' as three words - -- where a compiler flag (ie. -fno-monomorphism-restriction) should + -- where a compiler flag (e.g. -ddump-simpl) should -- only be a single word. selectWord [] = (0,w) selectWord ((offset,x):xs) @@ -1709,19 +1725,16 @@ completeMacro w = do return (filter (w `isPrefixOf`) (map cmdName cmds)) completeIdentifier w = do - s <- restoreSession - rdrs <- GHC.getRdrNamesInScope s + rdrs <- withRestoredSession GHC.getRdrNamesInScope return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs)) completeModule w = do - s <- restoreSession - dflags <- GHC.getSessionDynFlags s + dflags <- withRestoredSession GHC.getSessionDynFlags let pkg_mods = allExposedModules dflags return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods)) completeHomeModule w = do - s <- restoreSession - g <- GHC.getModuleGraph s + g <- withRestoredSession GHC.getModuleGraph let home_mods = map GHC.ms_mod_name g return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods)) @@ -1799,14 +1812,15 @@ completeHomeModuleOrFile=completeNone -- raising another exception. We therefore don't put the recursive -- handler arond the flushing operation, so if stderr is closed -- GHCi will just die gracefully rather than going into an infinite loop. -handler :: Exception -> GHCi Bool +handler :: SomeException -> GHCi Bool handler exception = do flushInterpBuffers io installSignalHandlers ghciHandle handler (showException exception >> return False) -showException :: Exception -> GHCi () +showException :: SomeException -> GHCi () +#if __GLASGOW_HASKELL__ < 609 showException (DynException dyn) = case fromDynamic dyn of Nothing -> io (putStrLn ("*** Exception: (unknown)")) @@ -1817,6 +1831,17 @@ showException (DynException dyn) = showException other_exception = io (putStrLn ("*** Exception: " ++ show other_exception)) +#else +showException (SomeException e) = + io $ case cast e of + Just Interrupted -> putStrLn "Interrupted." + -- omit the location for CmdLineError: + Just (CmdLineError s) -> putStrLn s + -- ditto: + Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "") + Just other_ghc_ex -> print other_ghc_ex + Nothing -> putStrLn ("*** Exception: " ++ show e) +#endif ----------------------------------------------------------------------------- -- recursive exception handlers @@ -1825,14 +1850,18 @@ showException other_exception -- in an exception loop (eg. let a = error a in a) the ^C exception -- may never be delivered. Thanks to Marcin for pointing out the bug. -ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a +ghciHandle :: (SomeException -> GHCi a) -> GHCi a -> GHCi a ghciHandle h (GHCi m) = GHCi $ \s -> - Exception.catch (m s) + gcatch (m s) (\e -> unGHCi (ghciUnblock (h e)) s) ghciUnblock :: GHCi a -> GHCi a -ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s) +ghciUnblock (GHCi a) = + GHCi $ \s -> reifyGhc $ \gs -> + Exception.unblock (reflectGhc (a s) gs) +ghciTry :: GHCi a -> GHCi (Either SomeException a) +ghciTry (GHCi m) = GHCi $ \s -> gtry (m s) -- ---------------------------------------------------------------------------- -- Utils @@ -1851,28 +1880,30 @@ expandPathIO path = wantInterpretedModule :: String -> GHCi Module wantInterpretedModule str = do - session <- getSession modl <- lookupModule str - is_interpreted <- io (GHC.moduleIsInterpreted session modl) + dflags <- getDynFlags + when (GHC.modulePackageId modl /= thisPackage dflags) $ + ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module")) + is_interpreted <- GHC.moduleIsInterpreted modl when (not is_interpreted) $ - throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted")) + ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first")) return modl wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String -> (Name -> GHCi ()) -> GHCi () -wantNameFromInterpretedModule noCanDo str and_then = do - session <- getSession - names <- io $ GHC.parseName session str +wantNameFromInterpretedModule noCanDo str and_then = + handleSourceError (GHC.printExceptionAndWarnings) $ do + names <- GHC.parseName str case names of [] -> return () (n:_) -> do - let modl = GHC.nameModule n + let modl = ASSERT( isExternalName n ) GHC.nameModule n if not (GHC.isExternalName n) then noCanDo n $ ppr n <> text " is not defined in an interpreted module" else do - is_interpreted <- io (GHC.moduleIsInterpreted session modl) + is_interpreted <- GHC.moduleIsInterpreted modl if not is_interpreted then noCanDo n $ text "module " <> ppr modl <> text " is not interpreted" @@ -1888,8 +1919,7 @@ forceCmd = pprintCommand False True pprintCommand :: Bool -> Bool -> String -> GHCi () pprintCommand bind force str = do - session <- getSession - io $ pprintClosureCommand session bind force str + pprintClosureCommand bind force str stepCmd :: String -> GHCi () stepCmd [] = doContinue (const True) GHC.SingleStep @@ -1914,7 +1944,7 @@ stepModuleCmd [] = do Nothing -> stepCmd [] Just _ -> do Just span <- getCurrentBreakSpan - let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span + let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span doContinue f GHC.SingleStep stepModuleCmd expression = stepCmd expression @@ -1939,15 +1969,13 @@ continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion -- doContinue :: SingleStep -> GHCi () doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi () doContinue pred step = do - session <- getSession - runResult <- io $ GHC.resume session step + runResult <- resume step afterRunStmt pred runResult return () abandonCmd :: String -> GHCi () abandonCmd = noArgs $ do - s <- getSession - b <- io $ GHC.abandon s -- the prompt will change to indicate the new context + b <- GHC.abandon -- the prompt will change to indicate the new context when (not b) $ io $ putStrLn "There is no computation running." return () @@ -1975,8 +2003,7 @@ historyCmd arg | otherwise = io $ putStrLn "Syntax: :history [num]" where history num = do - s <- getSession - resumes <- io $ GHC.getResumeContext s + resumes <- GHC.getResumeContext case resumes of [] -> io $ putStrLn "Not stopped at a breakpoint" (r:_) -> do @@ -1986,7 +2013,7 @@ historyCmd arg [] -> io $ putStrLn $ "Empty history. Perhaps you forgot to use :trace?" _ -> do - spans <- mapM (io . GHC.getHistorySpan s) took + spans <- mapM GHC.getHistorySpan took let nums = map (printf "-%-3d:") [(1::Int)..] names = map GHC.historyEnclosingDecl took printForUser (vcat(zipWith3 @@ -2002,22 +2029,20 @@ bold c | do_bold = text start_bold <> c <> text end_bold backCmd :: String -> GHCi () backCmd = noArgs $ do - s <- getSession - (names, _, span) <- io $ GHC.back s - printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span - printTypeOfNames s names + (names, _, span) <- GHC.back + printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span + printTypeOfNames names -- run the command set with ":set stop " st <- getGHCiState enqueueCommands [stop st] forwardCmd :: String -> GHCi () forwardCmd = noArgs $ do - s <- getSession - (names, ix, span) <- io $ GHC.forward s + (names, ix, span) <- GHC.forward printForUser $ (if (ix == 0) - then ptext SLIT("Stopped at") - else ptext SLIT("Logged breakpoint at")) <+> ppr span - printTypeOfNames s names + then ptext (sLit "Stopped at") + else ptext (sLit "Logged breakpoint at")) <+> ppr span + printTypeOfNames names -- run the command set with ":set stop " st <- getGHCiState enqueueCommands [stop st] @@ -2025,18 +2050,17 @@ forwardCmd = noArgs $ do -- handle the "break" command breakCmd :: String -> GHCi () breakCmd argLine = do - session <- getSession - breakSwitch session $ words argLine + breakSwitch $ words argLine -breakSwitch :: Session -> [String] -> GHCi () -breakSwitch _session [] = do +breakSwitch :: [String] -> GHCi () +breakSwitch [] = do io $ putStrLn "The break command requires at least one argument." -breakSwitch session (arg1:rest) - | looksLikeModuleName arg1 = do +breakSwitch (arg1:rest) + | looksLikeModuleName arg1 && not (null rest) = do mod <- wantInterpretedModule arg1 breakByModule mod rest | all isDigit arg1 = do - (toplevel, _) <- io $ GHC.getContext session + (toplevel, _) <- GHC.getContext case toplevel of (mod : _) -> breakByModuleLine mod (read arg1) rest [] -> do @@ -2046,7 +2070,8 @@ breakSwitch session (arg1:rest) wantNameFromInterpretedModule noCanDo arg1 $ \name -> do let loc = GHC.srcSpanStart (GHC.nameSrcSpan name) if GHC.isGoodSrcLoc loc - then findBreakAndSet (GHC.nameModule name) $ + then ASSERT( isExternalName name ) + findBreakAndSet (GHC.nameModule name) $ findBreakByCoord (Just (GHC.srcLocFile loc)) (GHC.srcLocLine loc, GHC.srcLocCol loc) @@ -2070,7 +2095,7 @@ breakByModuleLine mod line args | otherwise = breakSyntax breakSyntax :: a -breakSyntax = throwDyn (CmdLineError "Syntax: :break [] []") +breakSyntax = ghcError (CmdLineError "Syntax: :break [] []") findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi () findBreakAndSet mod lookupTickTree = do @@ -2150,7 +2175,7 @@ findBreakByCoord mb_file (line, col) arr do_bold :: Bool do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"] where mTerm = System.Environment.getEnv "TERM" - `Exception.catch` \_ -> return "TERM not set" + `catchIO` \_ -> return "TERM not set" start_bold :: String start_bold = "\ESC[1m" @@ -2166,8 +2191,7 @@ listCmd "" = do Just span | GHC.isGoodSrcSpan span -> io $ listAround span True | otherwise -> - do s <- getSession - resumes <- io $ GHC.getResumeContext s + do resumes <- GHC.getResumeContext case resumes of [] -> panic "No resumes" (r:_) -> @@ -2182,8 +2206,7 @@ listCmd str = list2 (words str) list2 :: [String] -> GHCi () list2 [arg] | all isDigit arg = do - session <- getSession - (toplevel, _) <- io $ GHC.getContext session + (toplevel, _) <- GHC.getContext case toplevel of [] -> io $ putStrLn "No module to list" (mod : _) -> listModuleLine mod (read arg) @@ -2195,7 +2218,8 @@ list2 [arg] = do let loc = GHC.srcSpanStart (GHC.nameSrcSpan name) if GHC.isGoodSrcLoc loc then do - tickArray <- getTickArray (GHC.nameModule name) + tickArray <- ASSERT( isExternalName name ) + getTickArray (GHC.nameModule name) let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc)) (GHC.srcLocLine loc, GHC.srcLocCol loc) tickArray @@ -2213,8 +2237,7 @@ list2 _other = listModuleLine :: Module -> Int -> GHCi () listModuleLine modl line = do - session <- getSession - graph <- io (GHC.getModuleGraph session) + graph <- GHC.getModuleGraph let this = filter ((== modl) . GHC.ms_mod) graph case this of [] -> panic "listModuleLine" @@ -2225,7 +2248,7 @@ listModuleLine modl line = do -- | list a section of a source file around a particular SrcSpan. -- If the highlight flag is True, also highlight the span using --- start_bold/end_bold. +-- start_bold\/end_bold. listAround :: SrcSpan -> Bool -> IO () listAround span do_highlight = do contents <- BS.readFile (unpackFS file) @@ -2318,8 +2341,7 @@ mkTickArray ticks lookupModule :: String -> GHCi Module lookupModule modName - = do session <- getSession - io (GHC.findModule session (GHC.mkModuleName modName) Nothing) + = GHC.findModule (GHC.mkModuleName modName) Nothing -- don't reset the counter back to zero? discardActiveBreakPoints :: GHCi () @@ -2347,8 +2369,7 @@ turnOffBreak loc = do getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan) getModBreak mod = do - session <- getSession - Just mod_info <- io $ GHC.getModuleInfo session mod + Just mod_info <- GHC.getModuleInfo mod let modBreaks = GHC.modInfoModBreaks mod_info let array = GHC.modBreaks_flags modBreaks let ticks = GHC.modBreaks_locs modBreaks @@ -2358,4 +2379,3 @@ setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool setBreakFlag toggle array index | toggle = GHC.setBreakOn array index | otherwise = GHC.setBreakOff array index -