X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2FInteractiveUI.hs;h=2f3ca85dece9910fb2251e960c61aac479139d99;hp=d6202907d1515428b4f35ad8f02d0243fad1d5c8;hb=b00e3a6c0a82a8af3238d677f798d812cd7fd49f;hpb=e16df2647fde526846e4c13470250ee5b475bdd2 diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index d620290..2f3ca85 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -1,7 +1,6 @@ {-# OPTIONS -fno-cse #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly -{-# OPTIONS -#include "Linker.h" #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} ----------------------------------------------------------------------------- -- @@ -23,23 +22,24 @@ import Debugger -- The GHC interface import qualified GHC hiding (resume, runStmt) import GHC ( LoadHowMuch(..), Target(..), TargetId(..), - Module, ModuleName, TyThing(..), Phase, - BreakIndex, SrcSpan, Resume, SingleStep, + TyThing(..), Phase, + BreakIndex, Resume, SingleStep, Ghc, handleSourceError ) import PprTyThing import DynFlags import Packages -import PackageConfig +-- import PackageConfig import UniqFM -import HscTypes ( implicitTyThings, handleFlagWarnings ) +import HscTypes ( handleFlagWarnings ) +import HsImpExp import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC? +import RdrName (RdrName) import Outputable hiding (printForUser, printForUserPartWay) import Module -- for ModuleEnv import Name import SrcLoc -import ObjLink -- Other random utilities import CmdLineParser @@ -54,6 +54,7 @@ import NameSet import Maybes ( orElse, expectJust ) import FastString import Encoding +import Foreign.C #ifndef mingw32_HOST_OS import System.Posix hiding (getEnv) @@ -68,7 +69,6 @@ import Control.Monad.Trans --import SystemExts import Exception hiding (catch, block, unblock) -import qualified Exception -- import Control.Concurrent @@ -88,7 +88,10 @@ import Control.Monad as Monad import Text.Printf import Foreign import GHC.Exts ( unsafeCoerce# ) -import GHC.IOBase ( IOErrorType(InvalidArgument) ) + +import GHC.IO.Exception ( IOErrorType(InvalidArgument) ) +import GHC.IO.Handle ( hFlushAll ) + import GHC.TopHandler import Data.IORef ( IORef, readIORef, writeIORef ) @@ -118,11 +121,11 @@ builtin_commands = [ ("check", keepGoing' checkModule, completeHomeModule), ("continue", keepGoing continueCmd, noCompletion), ("cmd", keepGoing cmdCmd, completeExpression), - ("ctags", keepGoing createCTagsFileCmd, completeFilename), + ("ctags", keepGoing createCTagsWithLineNumbersCmd, completeFilename), + ("ctags!", keepGoing createCTagsWithRegExesCmd, completeFilename), ("def", keepGoing (defineMacro False), completeExpression), ("def!", keepGoing (defineMacro True), completeExpression), ("delete", keepGoing deleteCmd, noCompletion), - ("e", keepGoing editFile, completeFilename), ("edit", keepGoing editFile, completeFilename), ("etags", keepGoing createETagsFileCmd, completeFilename), ("force", keepGoing forceCmd, completeExpression), @@ -133,7 +136,7 @@ builtin_commands = [ ("kind", keepGoing' kindOfType, completeIdentifier), ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile), ("list", keepGoing' listCmd, noCompletion), - ("module", keepGoing setContext, completeModule), + ("module", keepGoing setContext, completeSetModule), ("main", keepGoing runMain, completeFilename), ("print", keepGoing printCmd, completeExpression), ("quit", quit, noCompletion), @@ -198,7 +201,8 @@ helpText = " (!: more details; *: all top-level names)\n" ++ " :cd change directory to \n" ++ " :cmd run the commands returned by ::IO String\n" ++ - " :ctags [] create tags file for Vi (default: \"tags\")\n" ++ + " :ctags[!] [] create tags file for Vi (default: \"tags\")\n" ++ + " (!: use regex instead of line number)\n" ++ " :def define a command :\n" ++ " :edit edit file\n" ++ " :edit edit last module\n" ++ @@ -276,7 +280,7 @@ helpText = findEditor :: IO String findEditor = do getEnv "EDITOR" - `IO.catch` \_ -> do + `catchIO` \_ -> do #if mingw32_HOST_OS win <- System.Win32.getWindowsDirectory return (win "notepad.exe") @@ -284,14 +288,24 @@ findEditor = do return "" #endif +foreign import ccall unsafe "rts_isProfiled" isProfiled :: IO CInt + +default_progname, default_prompt, default_stop :: String +default_progname = "" +default_prompt = "%s> " +default_stop = "" + +default_args :: [String] +default_args = [] + interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc () interactiveUI srcs maybe_exprs = do -- although GHCi compiles with -prof, it is not usable: the byte-code -- compiler and interpreter don't work with profiling. So we check for -- this up front and emit a helpful error message (#2197) - m <- liftIO $ lookupSymbol "PushCostCentre" - when (isJust m) $ + i <- liftIO $ isProfiled + when (i /= 0) $ ghcError (InstallationError "GHCi cannot be used when compiled with -prof") -- HACK! If we happen to get into an infinite loop (eg the user @@ -302,9 +316,9 @@ interactiveUI 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. - liftIO $ newStablePtr stdin - liftIO $ newStablePtr stdout - liftIO $ newStablePtr stderr + _ <- liftIO $ newStablePtr stdin + _ <- liftIO $ newStablePtr stdout + _ <- liftIO $ newStablePtr stderr -- Initialise buffering for the *interpreted* I/O system initInterpBuffering @@ -320,18 +334,24 @@ interactiveUI srcs maybe_exprs = do -- We don't want the cmd line to buffer any input that might be -- intended for the program, so unbuffer stdin. hSetBuffering stdin NoBuffering +#if defined(mingw32_HOST_OS) + -- On Unix, stdin will use the locale encoding. The IO library + -- doesn't do this on Windows (yet), so for now we use UTF-8, + -- for consistency with GHC 6.10 and to make the tests work. + hSetEncoding stdin utf8 +#endif -- initial context is just the Prelude prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing - GHC.setContext [] [prel_mod] + GHC.setContext [] [(prel_mod, Nothing)] default_editor <- liftIO $ findEditor startGHCi (runGHCi srcs maybe_exprs) - GHCiState{ progname = "", - args = [], - prompt = "%s> ", - stop = "", + GHCiState{ progname = default_progname, + args = default_args, + prompt = default_prompt, + stop = default_stop, editor = default_editor, -- session = session, options = [], @@ -349,51 +369,58 @@ interactiveUI srcs maybe_exprs = do 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 + either_dir <- IO.try (getAppUserDataDirectory "ghc") + case either_dir of + Right dir -> + do createDirectoryIfMissing False dir `catchIO` \_ -> return () + right dir + _ -> left runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi () runGHCi paths maybe_exprs = do - let + let read_dot_files = not opt_IgnoreDotGhci current_dir = return (Just ".ghci") - app_user_dir = io $ withGhcAppData + app_user_dir = liftIO $ withGhcAppData (\dir -> return (Just (dir "ghci.conf"))) (return Nothing) home_dir = do - either_dir <- io $ IO.try (getEnv "HOME") + either_dir <- liftIO $ IO.try (getEnv "HOME") case either_dir of Right home -> return (Just (home ".ghci")) _ -> return Nothing + canonicalizePath' :: FilePath -> IO (Maybe FilePath) + canonicalizePath' fp = liftM Just (canonicalizePath fp) + `catchIO` \_ -> return Nothing + sourceConfigFile :: FilePath -> GHCi () sourceConfigFile file = do - exists <- io $ doesFileExist file + exists <- liftIO $ doesFileExist file when exists $ do - dir_ok <- io $ checkPerms (getDirectory file) - file_ok <- io $ checkPerms file + dir_ok <- liftIO $ checkPerms (getDirectory file) + file_ok <- liftIO $ checkPerms file when (dir_ok && file_ok) $ do - either_hdl <- io $ IO.try (openFile file ReadMode) + either_hdl <- liftIO $ IO.try (openFile file ReadMode) case either_hdl of Left _e -> return () -- NOTE: this assumes that runInputT won't affect the terminal; -- can we assume this will always be the case? -- This would be a good place for runFileInputT. - Right hdl -> runInputTWithPrefs defaultPrefs defaultSettings $ do - setLogAction + Right hdl -> + do runInputTWithPrefs defaultPrefs defaultSettings $ runCommands $ fileLoop hdl + liftIO (hClose hdl `catchIO` \_ -> return ()) where getDirectory f = case takeDirectory f of "" -> "."; d -> d when (read_dot_files) $ do - cfgs0 <- sequence [ current_dir, app_user_dir, home_dir ] - cfgs <- io $ mapM canonicalizePath (catMaybes cfgs0) - mapM_ sourceConfigFile (nub cfgs) + mcfgs0 <- sequence [ current_dir, app_user_dir, home_dir ] + mcfgs <- liftIO $ mapM canonicalizePath' (catMaybes mcfgs0) + mapM_ sourceConfigFile $ nub $ catMaybes mcfgs -- nub, because we don't want to read .ghci twice if the -- CWD is $HOME. @@ -408,11 +435,11 @@ runGHCi paths maybe_exprs = do filePaths' <- mapM (Encoding.decode . BS.pack) filePaths loadModule (zip filePaths' phases) when (isJust maybe_exprs && failed ok) $ - io (exitWith (ExitFailure 1)) + liftIO (exitWith (ExitFailure 1)) -- if verbosity is greater than 0, or we are connected to a -- terminal, display the prompt in the interactive loop. - is_tty <- io (hIsTerminalDevice stdin) + is_tty <- liftIO (hIsTerminalDevice stdin) dflags <- getDynFlags let show_prompt = verbosity dflags > 0 || is_tty @@ -425,28 +452,27 @@ runGHCi paths maybe_exprs = do -- just evaluate the expression we were given enqueueCommands exprs let handle e = do st <- getGHCiState + -- flush the interpreter's stdout/stderr on exit (#3890) + flushInterpBuffers -- Jump through some hoops to get the -- current progname in the exception text: -- : - io $ withProgName (progname st) + liftIO $ withProgName (progname st) -- this used to be topHandlerFastExit, see #2228 - $ topHandler e + $ topHandler e runInputTWithPrefs defaultPrefs defaultSettings $ do - setLogAction runCommands' handle (return Nothing) -- and finally, exit - io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi." + liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi." runGHCiInput :: InputT GHCi a -> GHCi a runGHCiInput f = do - histFile <- io $ withGhcAppData (\dir -> return (Just (dir "ghci_history"))) - (return Nothing) + histFile <- liftIO $ withGhcAppData (\dir -> return (Just (dir "ghci_history"))) + (return Nothing) let settings = setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile} - runInputT settings $ do - setLogAction - f + runInputT settings f nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String) nextInputLine show_prompt is_tty @@ -479,7 +505,7 @@ checkPerms name = putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!" return False else do - let mode = fileMode st + let mode = System.Posix.fileMode st if (groupWriteMode == (mode `intersectFileModes` groupWriteMode)) || (otherWriteMode == (mode `intersectFileModes` otherWriteMode)) then do @@ -501,7 +527,7 @@ fileLoop hdl = do -- this can happen if the user closed stdin, or -- perhaps did getContents which closes stdin at -- EOF. - Right l -> fmap Just (Encoding.decode (BS.pack l)) + Right l -> return (Just l) mkPrompt :: GHCi String mkPrompt = do @@ -525,15 +551,13 @@ mkPrompt = do dots | _:rs <- resumes, not (null rs) = text "... " | otherwise = empty - - modules_bit = -- ToDo: maybe... -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+> -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+> hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+> - hsep (map (ppr . GHC.moduleName) exports) + hsep (map (ppr . GHC.moduleName) (nub (map fst exports))) deflt_prompt = dots <> context_bit <> modules_bit @@ -560,9 +584,14 @@ runCommands = runCommands' handler runCommands' :: (SomeException -> GHCi Bool) -- Exception handler -> InputT GHCi (Maybe String) -> InputT GHCi () runCommands' eh getCmd = do - b <- handleGhcException (\e -> case e of - Interrupted -> return False - _other -> liftIO (print e) >> return True) + b <- ghandle (\e -> case fromException e of + Just UserInterrupt -> return False + _ -> case fromException e of + Just ghc_e -> + do liftIO (print (ghc_e :: GhcException)) + return True + _other -> + liftIO (Exception.throwIO e)) (runOneCommand eh getCmd) if b then return () else runCommands' eh getCmd @@ -578,7 +607,7 @@ runOneCommand eh getCmd = do (doCommand c) where printErrorAndKeepGoing err = do - GHC.printExceptionAndWarnings err + GHC.printException err return False noSpace q = q >>= maybe (return Nothing) @@ -605,13 +634,13 @@ runOneCommand eh getCmd = do maybe (liftIO (ioError collectError)) (\l->if removeSpaces l == ":}" then return (Just $ removeSpaces c) - else collectCommand q (c++map normSpace l)) + else collectCommand q (c ++ "\n" ++ map normSpace l)) where normSpace '\r' = ' ' normSpace c = c -- QUESTION: is userError the one to use here? collectError = userError "unterminated multiline command :{ .. :}" doCommand (':' : cmd) = specialCommand cmd - doCommand stmt = do timeIt $ lift $ runStmt stmt GHC.RunToCompletion + doCommand stmt = do _ <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion return False enqueueCommands :: [String] -> GHCi () @@ -622,10 +651,18 @@ enqueueCommands cmds = do runStmt :: String -> SingleStep -> GHCi Bool runStmt stmt step - | null (filter (not.isSpace) stmt) = return False - | ["import", mod] <- words stmt = keepGoing' setContext ('+':mod) + | null (filter (not.isSpace) stmt) + = return False + | "import " `isPrefixOf` stmt + = do newContextCmd (Import stmt); return False | otherwise - = do result <- GhciMonad.runStmt stmt step + = do -- In the new IO library, read handles buffer data even if the Handle + -- is set to NoBuffering. This causes problems for GHCi where there + -- are really two stdin Handles. So we flush any bufferred data in + -- GHCi's stdin Handle here (only relevant if stdin is attached to + -- a file, otherwise the read buffer can't be flushed). + _ <- liftIO $ IO.try $ hFlushAll stdin + result <- GhciMonad.runStmt stmt step afterRunStmt (const True) result --afterRunStmt :: GHC.RunResult -> GHCi Bool @@ -655,7 +692,7 @@ afterRunStmt step_here run_result = do _ -> return () flushInterpBuffers - io installSignalHandlers + liftIO installSignalHandlers b <- isOptionSet RevertCAFs when b revertCAFs @@ -723,7 +760,7 @@ lookupCommand "" = do Just c -> return $ GotCommand c Nothing -> return NoLastCommand lookupCommand str = do - mc <- io $ lookupCommand' str + mc <- liftIO $ lookupCommand' str st <- getGHCiState setGHCiState st{ last_command = mc } return $ case mc of @@ -731,9 +768,12 @@ lookupCommand str = do Nothing -> BadCommand lookupCommand' :: String -> IO (Maybe Command) -lookupCommand' str = do +lookupCommand' ":" = return Nothing +lookupCommand' str' = do macros <- readIORef macros_ref - let cmds = builtin_commands ++ macros + let{ (str, cmds) = case str' of + ':' : rest -> (rest, builtin_commands) + _ -> (str', macros ++ builtin_commands) } -- look for exact match first, then the first prefix match return $ case [ c | c <- cmds, str == cmdName c ] of c:_ -> Just c @@ -773,15 +813,15 @@ getCurrentBreakModule = do noArgs :: GHCi () -> String -> GHCi () noArgs m "" = m -noArgs _ _ = io $ putStrLn "This command takes no arguments" +noArgs _ _ = liftIO $ putStrLn "This command takes no arguments" help :: String -> GHCi () -help _ = io (putStr helpText) +help _ = liftIO (putStr helpText) info :: String -> InputT GHCi () info "" = ghcError (CmdLineError "syntax: ':i '") -info s = handleSourceError GHC.printExceptionAndWarnings $ do - { let names = words s +info s = handleSourceError GHC.printException $ + do { let names = words s ; dflags <- getDynFlags ; let pefas = dopt Opt_PrintExplicitForalls dflags ; mapM_ (infoThing pefas) names } @@ -791,7 +831,7 @@ info s = handleSourceError GHC.printExceptionAndWarnings $ do mb_stuffs <- mapM GHC.getInfo names let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) unqual <- GHC.getPrintUnqual - outputStrLn $ showSDocForUser unqual $ + liftIO $ putStrLn $ showSDocForUser unqual $ vcat (intersperse (text "") $ map (pprInfo pefas) filtered) @@ -800,9 +840,12 @@ info s = handleSourceError GHC.printExceptionAndWarnings $ do -- constructor in the same type filterOutChildren :: (a -> TyThing) -> [a] -> [a] filterOutChildren get_thing xs - = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)] + = filterOut has_parent xs where - implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] + all_names = mkNameSet (map (getName . get_thing) xs) + has_parent x = case pprTyThingParent_maybe (get_thing x) of + Just p -> getName p `elemNameSet` all_names + Nothing -> False pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc pprInfo pefas (thing, fixity, insts) @@ -816,7 +859,7 @@ pprInfo pefas (thing, fixity, insts) runMain :: String -> GHCi () runMain s = case toArgs s of - Left err -> io (hPutStrLn stderr err) + Left err -> liftIO (hPutStrLn stderr err) Right args -> do dflags <- getDynFlags case mainFunIs dflags of @@ -825,7 +868,7 @@ runMain s = case toArgs s of runRun :: String -> GHCi () runRun s = case toCmdArgs s of - Left err -> io (hPutStrLn stderr err) + Left err -> liftIO (hPutStrLn stderr err) Right (cmd, args) -> doWithArgs args cmd doWithArgs :: [String] -> String -> GHCi () @@ -854,10 +897,10 @@ changeDirectory "" = do changeDirectory dir = do graph <- GHC.getModuleGraph when (not (null graph)) $ - outputStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n" + liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed." prev_context <- GHC.getContext GHC.setTargets [] - GHC.load LoadAllTargets + _ <- GHC.load LoadAllTargets lift $ setContextAfterLoad prev_context False [] GHC.workingDirectoryChanged dir <- expandPath dir @@ -865,7 +908,7 @@ changeDirectory dir = do trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag trySuccess act = - handleSourceError (\e -> do GHC.printExceptionAndWarnings e + handleSourceError (\e -> do GHC.printException e return Failed) $ do act @@ -876,7 +919,7 @@ editFile str = let cmd = editor st when (null cmd) $ ghcError (CmdLineError "editor not set, use :set editor") - io $ system (cmd ++ ' ':file) + _ <- liftIO $ system (cmd ++ ' ':file) return () -- The user didn't specify a file so we pick one for them. @@ -912,15 +955,17 @@ chooseEditFile = fromTarget _ = Nothing -- when would we get a module target? defineMacro :: Bool{-overwrite-} -> String -> GHCi () +defineMacro _ (':':_) = + liftIO $ putStrLn "macro name cannot start with a colon" defineMacro overwrite s = do let (macro_name, definition) = break isSpace s - macros <- io (readIORef macros_ref) + macros <- liftIO (readIORef macros_ref) let defined = map cmdName macros if (null macro_name) then if null defined - then io $ putStrLn "no macros defined" - else io $ putStr ("the following macros are defined:\n" ++ - unlines defined) + then liftIO $ putStrLn "no macros defined" + else liftIO $ putStr ("the following macros are defined:\n" ++ + unlines defined) else do if (not overwrite && macro_name `elem` defined) then ghcError (CmdLineError @@ -934,14 +979,15 @@ defineMacro overwrite s = do let new_expr = '(' : definition ++ ") :: String -> IO String" -- compile the expression - handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do + handleSourceError (\e -> GHC.printException e) $ + do hv <- GHC.compileExpr new_expr - io (writeIORef macros_ref -- - (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)])) + liftIO (writeIORef macros_ref -- + (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)])) runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool runMacro fun s = do - str <- io ((unsafeCoerce# fun :: String -> IO String) s) + str <- liftIO ((unsafeCoerce# fun :: String -> IO String) s) -- make sure we force any exceptions in the result, while we are still -- inside the exception handler for commands: seqList str (return ()) @@ -951,37 +997,41 @@ runMacro fun s = do undefineMacro :: String -> GHCi () undefineMacro str = mapM_ undef (words str) where undef macro_name = do - cmds <- io (readIORef macros_ref) + cmds <- liftIO (readIORef macros_ref) if (macro_name `notElem` map cmdName cmds) then ghcError (CmdLineError ("macro '" ++ macro_name ++ "' is not defined")) else do - io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds)) + liftIO (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds)) cmdCmd :: String -> GHCi () cmdCmd str = do let expr = '(' : str ++ ") :: IO String" - handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do + handleSourceError (\e -> GHC.printException e) $ + do hv <- GHC.compileExpr expr - cmds <- io $ (unsafeCoerce# hv :: IO String) + cmds <- liftIO $ (unsafeCoerce# hv :: IO String) enqueueCommands (lines cmds) return () +loadModuleName :: GHC.GhcMonad m => ImportDecl RdrName -> m Module +loadModuleName = flip GHC.findModule Nothing . unLoc . ideclName + loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag loadModule fs = timeIt (loadModule' fs) loadModule_ :: [FilePath] -> InputT GHCi () -loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return () +loadModule_ fs = loadModule (zip fs (repeat Nothing)) >> return () loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag loadModule' files = do prev_context <- GHC.getContext -- unload first - GHC.abandonAll + _ <- GHC.abandonAll lift discardActiveBreakPoints GHC.setTargets [] - GHC.load LoadAllTargets + _ <- GHC.load LoadAllTargets let (filenames, phases) = unzip files exp_filenames <- mapM expandPath filenames @@ -1000,9 +1050,9 @@ checkModule :: String -> InputT GHCi () checkModule m = do let modl = GHC.mkModuleName m prev_context <- GHC.getContext - ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do + ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl - outputStrLn (showSDoc ( + liftIO $ putStrLn $ showSDoc $ case GHC.moduleInfo r of cm | Just scope <- GHC.modInfoTopLevelScope cm -> let @@ -1011,19 +1061,19 @@ checkModule m = do in (text "global names: " <+> ppr global) $$ (text "local names: " <+> ppr local) - _ -> empty)) + _ -> empty return True afterLoad (successIf ok) False prev_context reloadModule :: String -> InputT GHCi () reloadModule m = do prev_context <- GHC.getContext - doLoad True prev_context $ + _ <- doLoad True prev_context $ if null m then LoadAllTargets else LoadUpTo (GHC.mkModuleName m) return () -doLoad :: Bool -> ([Module],[Module]) -> LoadHowMuch -> InputT GHCi SuccessFlag +doLoad :: Bool -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> LoadHowMuch -> InputT 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. @@ -1032,7 +1082,7 @@ doLoad retain_context prev_context howmuch = do afterLoad ok retain_context prev_context return ok -afterLoad :: SuccessFlag -> Bool -> ([Module],[Module]) -> InputT GHCi () +afterLoad :: SuccessFlag -> Bool -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> InputT GHCi () afterLoad ok retain_context prev_context = do lift revertCAFs -- always revert CAFs on load. lift discardTickArrays @@ -1044,10 +1094,10 @@ afterLoad ok retain_context prev_context = do lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries -setContextAfterLoad :: ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi () +setContextAfterLoad :: ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> Bool -> [GHC.ModSummary] -> GHCi () setContextAfterLoad prev keep_ctxt [] = do prel_mod <- getPrelude - setContextKeepingPackageModules prev keep_ctxt ([], [prel_mod]) + setContextKeepingPackageModules prev keep_ctxt ([], [(prel_mod, Nothing)]) setContextAfterLoad prev keep_ctxt ms = do -- load a target if one is available, otherwise load the topmost module. targets <- GHC.getTargets @@ -1075,20 +1125,21 @@ setContextAfterLoad prev keep_ctxt ms = do if b then setContextKeepingPackageModules prev keep_ctxt ([m], []) else do prel_mod <- getPrelude - setContextKeepingPackageModules prev keep_ctxt ([],[prel_mod,m]) + setContextKeepingPackageModules prev keep_ctxt ([],[(prel_mod,Nothing),(m,Nothing)]) -- | Keep any package modules (except Prelude) when changing the context. setContextKeepingPackageModules - :: ([Module],[Module]) -- previous context + :: ([Module],[(Module, Maybe (ImportDecl RdrName))]) -- previous context -> Bool -- re-execute :module commands - -> ([Module],[Module]) -- new context + -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -- new context -> GHCi () 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 - GHC.setContext as (nub (bs1 ++ pkg_modules)) + -- filter everything, not just lefts + let pkg_modules = filter ((\p -> not (isHomeModule p) && p /= prel_mod) . fst) bs0 + let bs1 = if null as then nubBy sameFst ((prel_mod,Nothing) : bs) else bs + GHC.setContext as (nubBy sameFst (bs1 ++ pkg_modules)) if keep_ctxt then do st <- getGHCiState @@ -1100,6 +1151,9 @@ setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do isHomeModule :: Module -> Bool isHomeModule mod = GHC.modulePackageId mod == mainPackageId +sameFst :: (Module, Maybe (ImportDecl RdrName)) -> (Module, Maybe (ImportDecl RdrName)) -> Bool +sameFst x y = fst x == fst y + modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi () modulesLoadedMsg ok mods = do dflags <- getDynFlags @@ -1110,30 +1164,32 @@ modulesLoadedMsg ok mods = do punctuate comma (map ppr mods)) <> text "." case ok of Failed -> - outputStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)) + liftIO $ putStrLn $ showSDoc (text "Failed, modules loaded: " <> mod_commas) Succeeded -> - outputStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)) + liftIO $ putStrLn $ showSDoc (text "Ok, modules loaded: " <> mod_commas) typeOfExpr :: String -> InputT GHCi () typeOfExpr str - = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do + = handleSourceError GHC.printException + $ do ty <- GHC.exprType str dflags <- getDynFlags let pefas = dopt Opt_PrintExplicitForalls dflags - printForUser' $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)] + printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)] kindOfType :: String -> InputT GHCi () kindOfType str - = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do + = handleSourceError GHC.printException + $ do ty <- GHC.typeKind str - printForUser' $ text str <+> dcolon <+> ppr ty + printForUser $ text str <+> dcolon <+> ppr ty quit :: String -> InputT GHCi Bool quit _ = return True shellEscape :: String -> GHCi Bool -shellEscape str = io (system str >> return False) +shellEscape str = liftIO (system str >> return False) ----------------------------------------------------------------------------- -- Browsing a module's contents @@ -1154,8 +1210,8 @@ browseCmd bang m = -- recently-added module occurs last, it seems. case (as,bs) of (as@(_:_), _) -> browseModule bang (last as) True - ([], bs@(_:_)) -> browseModule bang (last bs) True - ([], []) -> ghcError (CmdLineError ":browse: no current module") + ([], bs@(_:_)) -> browseModule bang (fst (last bs)) True + ([], []) -> ghcError (CmdLineError ":browse: no current module") _ -> ghcError (CmdLineError "syntax: :browse ") -- without bang, show items in context of their parents and omit children @@ -1170,7 +1226,7 @@ browseModule bang modl exports_only = do -- just so we can get an appropriate PrintUnqualified (as,bs) <- GHC.getContext prel_mod <- lift getPrelude - if exports_only then GHC.setContext [] [prel_mod,modl] + if exports_only then GHC.setContext [] [(prel_mod,Nothing), (modl,Nothing)] else GHC.setContext [modl] [] target_unqual <- GHC.getPrintUnqual GHC.setContext as bs @@ -1238,7 +1294,7 @@ browseModule bang modl exports_only = do let prettyThings = map (pretty pefas) things prettyThings' | bang = annotate $ zip modNames prettyThings | otherwise = prettyThings - outputStrLn $ showSDocForUser unqual (vcat prettyThings') + liftIO $ putStrLn $ showSDocForUser unqual (vcat prettyThings') -- ToDo: modInfoInstances currently throws an exception for -- package modules. When it works, we can do this: -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info)) @@ -1246,21 +1302,25 @@ browseModule bang modl exports_only = do ----------------------------------------------------------------------------- -- Setting the module context +newContextCmd :: CtxtCmd -> GHCi () +newContextCmd cmd = do + playCtxtCmd True cmd + st <- getGHCiState + let cmds = remembered_ctx st + setGHCiState st{ remembered_ctx = cmds ++ [cmd] } + setContext :: String -> GHCi () setContext str - | all sensible strs = do - playCtxtCmd True (cmd, as, bs) - st <- getGHCiState - setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] } + | all sensible strs = newContextCmd cmd | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn") where - (cmd, strs, as, bs) = + (cmd, strs) = case str of '+':stuff -> rest AddModules stuff '-':stuff -> rest RemModules stuff stuff -> rest SetContext stuff - rest cmd stuff = (cmd, strs, as, bs) + rest cmd stuff = (cmd as bs, strs) where strs = words stuff (as,bs) = partitionWith starred strs @@ -1270,42 +1330,60 @@ setContext str 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 +playCtxtCmd:: Bool -> CtxtCmd -> GHCi () +playCtxtCmd fail cmd = do (prev_as,prev_bs) <- GHC.getContext - (new_as, new_bs) <- - case cmd of - SetContext -> do + case cmd of + SetContext as bs -> do + (as',bs') <- do_checks as bs 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 + let bs'' = if null as && prel_mod `notElem` (map fst bs') + then (prel_mod,Nothing):bs' + else bs' + GHC.setContext as' bs'' + + AddModules as bs -> do + (as',bs') <- do_checks as bs + -- it should replace the old stuff, not the other way around + -- need deleteAllBy, not deleteFirstsBy for sameFst + let remaining_as = prev_as \\ (as' ++ map fst bs') + remaining_bs = deleteAllBy sameFst prev_bs (bs' ++ map contextualize as') + GHC.setContext (remaining_as ++ as') (remaining_bs ++ bs') + + RemModules as bs -> do + (as',bs') <- do_checks as bs + let new_as = prev_as \\ (as' ++ map fst bs') + new_bs = deleteAllBy sameFst prev_bs (map contextualize as' ++ bs') + GHC.setContext new_as new_bs + + Import str -> do + m_idecl <- maybe_fail $ GHC.parseImportDecl str + case m_idecl of + Nothing -> return () + Just idecl -> do + m_mdl <- maybe_fail $ loadModuleName idecl + case m_mdl of + Nothing -> return () + Just m -> GHC.setContext prev_as (prev_bs ++ [(m, Just idecl)]) + 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) + maybe_fail | fail = liftM Just + | otherwise = trymaybe + + do_checks as bs = do + as' <- mapM (maybe_fail . wantInterpretedModule) as + bs' <- mapM (maybe_fail . lookupModule) bs + return (catMaybes as', map contextualize (catMaybes bs')) + + contextualize x = (x,Nothing) + deleteAllBy f a b = filter (\x->(not (any (f x) b))) a + +trymaybe ::GHCi a -> GHCi (Maybe a) +trymaybe m = do + r <- ghciTry m + case r of + Left _ -> return Nothing + Right a -> return (Just a) ---------------------------------------------------------------------------- -- Code for `:set' @@ -1321,28 +1399,26 @@ setCmd :: String -> GHCi () setCmd "" = do st <- getGHCiState let opts = options st - io $ putStrLn (showSDoc ( + liftIO $ putStrLn (showSDoc ( text "options currently set: " <> if null opts then text "none." else hsep (map (\o -> char '+' <> text (optToStr o)) opts) )) dflags <- getDynFlags - io $ putStrLn (showSDoc ( + liftIO $ putStrLn (showSDoc ( vcat (text "GHCi-specific dynamic flag settings:" :map (flagSetting dflags) ghciFlags) )) - io $ putStrLn (showSDoc ( + liftIO $ putStrLn (showSDoc ( vcat (text "other dynamic, non-language, flag settings:" - :map (flagSetting dflags) nonLanguageDynFlags) + :map (flagSetting dflags) others) )) 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) DynFlags.fFlags - nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions) - others flags = [Opt_PrintExplicitForalls ,Opt_PrintBindResult ,Opt_BreakOnException @@ -1353,17 +1429,17 @@ setCmd str = case getCmd str of Right ("args", rest) -> case toArgs rest of - Left err -> io (hPutStrLn stderr err) + Left err -> liftIO (hPutStrLn stderr err) Right args -> setArgs args Right ("prog", rest) -> case toArgs rest of Right [prog] -> setProg prog - _ -> io (hPutStrLn stderr "syntax: :set prog ") + _ -> liftIO (hPutStrLn stderr "syntax: :set prog ") Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest Right ("editor", rest) -> setEditor $ dropWhile isSpace rest Right ("stop", rest) -> setStop $ dropWhile isSpace rest _ -> case toArgs str of - Left err -> io (hPutStrLn stderr err) + Left err -> liftIO (hPutStrLn stderr err) Right wds -> setOptions wds setArgs, setOptions :: [String] -> GHCi () @@ -1401,13 +1477,13 @@ setStop cmd = do setPrompt value = do st <- getGHCiState if null value - then io $ hPutStrLn stderr $ "syntax: :set prompt , currently \"" ++ prompt st ++ "\"" + then liftIO $ hPutStrLn stderr $ "syntax: :set prompt , currently \"" ++ prompt st ++ "\"" else case value of '\"' : _ -> case reads value of [(value', xs)] | all isSpace xs -> setGHCiState (st { prompt = value' }) _ -> - io $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax." + liftIO $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax." _ -> setGHCiState (st { prompt = value }) setOptions wds = @@ -1421,8 +1497,8 @@ newDynFlags :: [String] -> GHCi () newDynFlags minus_opts = do dflags <- getDynFlags let pkg_flags = packageFlags dflags - (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts - handleFlagWarnings dflags' warns + (dflags', leftovers, warns) <- liftIO $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts + liftIO $ handleFlagWarnings dflags' warns if (not (null leftovers)) then ghcError $ errorsToGhcException leftovers @@ -1434,10 +1510,10 @@ newDynFlags minus_opts = do -- and link the new packages. dflags <- getDynFlags when (packageFlags dflags /= pkg_flags) $ do - io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..." + liftIO $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..." GHC.setTargets [] - GHC.load LoadAllTargets - io (linkPackages dflags new_pkgs) + _ <- GHC.load LoadAllTargets + liftIO (linkPackages dflags new_pkgs) -- package flags changed, we can't re-use any of the old context setContextAfterLoad ([],[]) False [] return () @@ -1445,22 +1521,32 @@ newDynFlags minus_opts = do unsetOptions :: String -> GHCi () unsetOptions str - = do -- first, deal with the GHCi opts (+s, +t, etc.) - let opts = words str - (minus_opts, rest1) = partition isMinus opts - (plus_opts, rest2) = partitionWith isPlus rest1 - - if (not (null rest2)) - then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'")) - else do + = -- first, deal with the GHCi opts (+s, +t, etc.) + let opts = words str + (minus_opts, rest1) = partition isMinus opts + (plus_opts, rest2) = partitionWith isPlus rest1 + (other_opts, rest3) = partition (`elem` map fst defaulters) rest2 + + defaulters = + [ ("args" , setArgs default_args) + , ("prog" , setProg default_progname) + , ("prompt", setPrompt default_prompt) + , ("editor", liftIO findEditor >>= setEditor) + , ("stop" , setStop default_stop) + ] + + no_flag ('-':'f':rest) = return ("-fno-" ++ rest) + no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f)) + + in if (not (null rest3)) + then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'")) + else do + mapM_ (fromJust.flip lookup defaulters) other_opts - mapM_ unsetOpt plus_opts - - let no_flag ('-':'f':rest) = return ("-fno-" ++ rest) - no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f)) + mapM_ unsetOpt plus_opts - no_flags <- mapM no_flag minus_opts - newDynFlags no_flags + no_flags <- mapM no_flag minus_opts + newDynFlags no_flags isMinus :: String -> Bool isMinus ('-':_) = True @@ -1474,12 +1560,12 @@ setOpt, unsetOpt :: String -> GHCi () setOpt str = case strToGHCiOpt str of - Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'")) + Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'")) Just o -> setOption o unsetOpt str = case strToGHCiOpt str of - Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'")) + Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'")) Just o -> unsetOption o strToGHCiOpt :: String -> (Maybe GHCiOption) @@ -1500,14 +1586,14 @@ showCmd :: String -> GHCi () showCmd str = do st <- getGHCiState case words str of - ["args"] -> io $ putStrLn (show (args st)) - ["prog"] -> io $ putStrLn (show (progname st)) - ["prompt"] -> io $ putStrLn (show (prompt st)) - ["editor"] -> io $ putStrLn (show (editor st)) - ["stop"] -> io $ putStrLn (show (stop st)) + ["args"] -> liftIO $ putStrLn (show (args st)) + ["prog"] -> liftIO $ putStrLn (show (progname st)) + ["prompt"] -> liftIO $ putStrLn (show (prompt st)) + ["editor"] -> liftIO $ putStrLn (show (editor st)) + ["stop"] -> liftIO $ putStrLn (show (stop st)) ["modules" ] -> showModules ["bindings"] -> showBindings - ["linker"] -> io showLinkerState + ["linker"] -> liftIO showLinkerState ["breaks"] -> showBkptTable ["context"] -> showContext ["packages"] -> showPackages @@ -1519,7 +1605,7 @@ showModules :: GHCi () showModules = do loaded_mods <- getLoadedModules -- we want *loaded* modules only, see #1734 - let show_one ms = do m <- GHC.showModule ms; io (putStrLn m) + let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m) mapM_ show_one loaded_mods getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary] @@ -1559,29 +1645,26 @@ showContext = do showPackages :: GHCi () showPackages = do pkg_flags <- fmap packageFlags getDynFlags - io $ putStrLn $ showSDoc $ vcat $ + liftIO $ putStrLn $ showSDoc $ vcat $ text ("active package flags:"++if null pkg_flags then " none" else "") : map showFlag pkg_flags - pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags - io $ putStrLn $ showSDoc $ vcat $ - text "packages currently loaded:" - : 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 + showFlag (ExposePackageId p) = text $ " -package-id " ++ p showLanguages :: GHCi () showLanguages = do dflags <- getDynFlags - io $ putStrLn $ showSDoc $ vcat $ + liftIO $ putStrLn $ showSDoc $ vcat $ text "active language flags:" : - [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags] + [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, xopt f dflags] -- ----------------------------------------------------------------------------- -- Completion completeCmd, completeMacro, completeIdentifier, completeModule, + completeSetModule, completeHomeModule, completeSetOptions, completeShowOptions, completeHomeModuleOrFile, completeExpression :: CompletionFunc GHCi @@ -1604,9 +1687,13 @@ ghciCompleteWord line@(left,_) = case firstWord of Nothing -> return completeFilename completeCmd = wrapCompleter " " $ \w -> do - cmds <- liftIO $ readIORef macros_ref - return (filter (w `isPrefixOf`) (map (':':) - (map cmdName (builtin_commands ++ cmds)))) + macros <- liftIO $ readIORef macros_ref + let macro_names = map (':':) . map cmdName $ macros + let command_names = map (':':) . map cmdName $ builtin_commands + let{ candidates = case w of + ':' : ':' : _ -> map (':':) command_names + _ -> nub $ macro_names ++ command_names } + return $ filter (w `isPrefixOf`) candidates completeMacro = wrapIdentCompleter $ \w -> do cmds <- liftIO $ readIORef macros_ref @@ -1623,6 +1710,18 @@ completeModule = wrapIdentCompleter $ \w -> do return $ filter (w `isPrefixOf`) $ map (showSDoc.ppr) $ loaded_mods ++ pkg_mods +completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do + modules <- case m of + Just '-' -> do + (toplevs, exports) <- GHC.getContext + return $ map GHC.moduleName (nub (map fst exports) ++ toplevs) + _ -> do + dflags <- GHC.getSessionDynFlags + let pkg_mods = allExposedModules dflags + loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules + return $ loaded_mods ++ pkg_mods + return $ filter (w `isPrefixOf`) $ map (showSDoc.ppr) modules + completeHomeModule = wrapIdentCompleter listHomeModules listHomeModules :: String -> GHCi [String] @@ -1660,6 +1759,12 @@ wrapCompleter breakChars fun = completeWord Nothing breakChars wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi wrapIdentCompleter = wrapCompleter word_break_chars +wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi +wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars + $ \rest -> fmap (map simpleCompletion) . fmap sort . fun (getModifier rest) + where + getModifier = find (`elem` modifChars) + allExposedModules :: DynFlags -> [ModuleName] allExposedModules dflags = concat (map exposedModules (filter exposed (eltsUFM pkg_db))) @@ -1686,19 +1791,21 @@ handler :: SomeException -> GHCi Bool handler exception = do flushInterpBuffers - io installSignalHandlers + liftIO installSignalHandlers ghciHandle handler (showException exception >> return False) showException :: SomeException -> GHCi () showException se = - io $ case fromException se 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 se) + liftIO $ case fromException se of + -- 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 -> + case fromException se of + Just UserInterrupt -> putStrLn "Interrupted." + _ -> putStrLn ("*** Exception: " ++ show se) ----------------------------------------------------------------------------- -- recursive exception handlers @@ -1750,7 +1857,7 @@ wantNameFromInterpretedModule :: GHC.GhcMonad m -> (Name -> m ()) -> m () wantNameFromInterpretedModule noCanDo str and_then = - handleSourceError (GHC.printExceptionAndWarnings) $ do + handleSourceError GHC.printException $ do names <- GHC.parseName str case names of [] -> return () @@ -1780,7 +1887,7 @@ pprintCommand bind force str = do stepCmd :: String -> GHCi () stepCmd [] = doContinue (const True) GHC.SingleStep -stepCmd expression = do runStmt expression GHC.SingleStep; return () +stepCmd expression = runStmt expression GHC.SingleStep >> return () stepLocalCmd :: String -> GHCi () stepLocalCmd [] = do @@ -1818,7 +1925,7 @@ enclosingTickSpan mod src = do traceCmd :: String -> GHCi () traceCmd [] = doContinue (const True) GHC.RunAndLogSteps -traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return () +traceCmd expression = runStmt expression GHC.RunAndLogSteps >> return () continueCmd :: String -> GHCi () continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion @@ -1827,22 +1934,21 @@ continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi () doContinue pred step = do runResult <- resume pred step - afterRunStmt pred runResult + _ <- afterRunStmt pred runResult return () abandonCmd :: String -> GHCi () abandonCmd = noArgs $ do b <- GHC.abandon -- the prompt will change to indicate the new context - when (not b) $ io $ putStrLn "There is no computation running." - return () + when (not b) $ liftIO $ putStrLn "There is no computation running." deleteCmd :: String -> GHCi () deleteCmd argLine = do deleteSwitch $ words argLine where deleteSwitch :: [String] -> GHCi () - deleteSwitch [] = - io $ putStrLn "The delete command requires at least one argument." + deleteSwitch [] = + liftIO $ putStrLn "The delete command requires at least one argument." -- delete all break points deleteSwitch ("*":_rest) = discardActiveBreakPoints deleteSwitch idents = do @@ -1857,28 +1963,28 @@ historyCmd :: String -> GHCi () historyCmd arg | null arg = history 20 | all isDigit arg = history (read arg) - | otherwise = io $ putStrLn "Syntax: :history [num]" + | otherwise = liftIO $ putStrLn "Syntax: :history [num]" where history num = do resumes <- GHC.getResumeContext case resumes of - [] -> io $ putStrLn "Not stopped at a breakpoint" + [] -> liftIO $ putStrLn "Not stopped at a breakpoint" (r:_) -> do let hist = GHC.resumeHistory r (took,rest) = splitAt num hist case hist of - [] -> io $ putStrLn $ + [] -> liftIO $ putStrLn $ "Empty history. Perhaps you forgot to use :trace?" _ -> do spans <- mapM GHC.getHistorySpan took let nums = map (printf "-%-3d:") [(1::Int)..] - names = map GHC.historyEnclosingDecl took + names = map GHC.historyEnclosingDecls took printForUser (vcat(zipWith3 (\x y z -> x <+> y <+> z) (map text nums) - (map (bold . ppr) names) + (map (bold . hcat . punctuate colon . map text) names) (map (parens . ppr) spans))) - io $ putStrLn $ if null rest then "" else "..." + liftIO $ putStrLn $ if null rest then "" else "..." bold :: SDoc -> SDoc bold c | do_bold = text start_bold <> c <> text end_bold @@ -1911,7 +2017,7 @@ breakCmd argLine = do breakSwitch :: [String] -> GHCi () breakSwitch [] = do - io $ putStrLn "The break command requires at least one argument." + liftIO $ putStrLn "The break command requires at least one argument." breakSwitch (arg1:rest) | looksLikeModuleName arg1 && not (null rest) = do mod <- wantInterpretedModule arg1 @@ -1921,8 +2027,8 @@ breakSwitch (arg1:rest) case toplevel of (mod : _) -> breakByModuleLine mod (read arg1) rest [] -> do - io $ putStrLn "Cannot find default module for breakpoint." - io $ putStrLn "Perhaps no modules are loaded for debugging?" + liftIO $ putStrLn "Cannot find default module for breakpoint." + liftIO $ putStrLn "Perhaps no modules are loaded for debugging?" | otherwise = do -- try parsing it as an identifier wantNameFromInterpretedModule noCanDo arg1 $ \name -> do let loc = GHC.srcSpanStart (GHC.nameSrcSpan name) @@ -1959,9 +2065,9 @@ findBreakAndSet mod lookupTickTree = do tickArray <- getTickArray mod (breakArray, _) <- getModBreak mod case lookupTickTree tickArray of - Nothing -> io $ putStrLn $ "No breakpoints found at that location." + Nothing -> liftIO $ putStrLn $ "No breakpoints found at that location." Just (tick, span) -> do - success <- io $ setBreakFlag True breakArray tick + success <- liftIO $ setBreakFlag True breakArray tick if success then do (alreadySet, nm) <- @@ -2040,11 +2146,14 @@ end_bold :: String end_bold = "\ESC[0m" listCmd :: String -> InputT GHCi () -listCmd "" = do +listCmd c = listCmd' c + +listCmd' :: String -> InputT GHCi () +listCmd' "" = do mb_span <- lift getCurrentBreakSpan case mb_span of Nothing -> - printForUser' $ text "Not stopped at a breakpoint; nothing to list" + printForUser $ text "Not stopped at a breakpoint; nothing to list" Just span | GHC.isGoodSrcSpan span -> listAround span True | otherwise -> @@ -2056,16 +2165,16 @@ listCmd "" = do [] -> text "rerunning with :trace," _ -> empty doWhat = traceIt <+> text ":back then :list" - printForUser' (text "Unable to list source for" <+> + printForUser (text "Unable to list source for" <+> ppr span $$ text "Try" <+> doWhat) -listCmd str = list2 (words str) +listCmd' str = list2 (words str) list2 :: [String] -> InputT GHCi () list2 [arg] | all isDigit arg = do (toplevel, _) <- GHC.getContext case toplevel of - [] -> outputStrLn "No module to list" + [] -> liftIO $ putStrLn "No module to list" (mod : _) -> listModuleLine mod (read arg) list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do mod <- wantInterpretedModule arg1 @@ -2087,10 +2196,10 @@ list2 [arg] = do noCanDo name $ text "can't find its location: " <> ppr loc where - noCanDo n why = printForUser' $ + noCanDo n why = printForUser $ text "cannot list source code for " <> ppr n <> text ": " <> why list2 _other = - outputStrLn "syntax: :list [ | | ]" + liftIO $ putStrLn "syntax: :list [ | | ]" listModuleLine :: Module -> Int -> InputT GHCi () listModuleLine modl line = do @@ -2131,13 +2240,13 @@ listAround span do_highlight = do let output = BS.intercalate (BS.pack "\n") prefixed utf8Decoded <- liftIO $ BS.useAsCStringLen output $ \(p,n) -> utf8DecodeString (castPtr p) n - outputStrLn utf8Decoded + liftIO $ putStrLn utf8Decoded where file = GHC.srcSpanFile span line1 = GHC.srcSpanStartLine span - col1 = GHC.srcSpanStartCol span + col1 = GHC.srcSpanStartCol span - 1 line2 = GHC.srcSpanEndLine span - col2 = GHC.srcSpanEndCol span + col2 = GHC.srcSpanEndCol span - 1 pad_before | line1 == 1 = 0 | otherwise = 1 @@ -2213,7 +2322,7 @@ lookupModule modName discardActiveBreakPoints :: GHCi () discardActiveBreakPoints = do st <- getGHCiState - mapM (turnOffBreak.snd) (breaks st) + mapM_ (turnOffBreak.snd) (breaks st) setGHCiState $ st { breaks = [] } deleteBreak :: Int -> GHCi () @@ -2225,13 +2334,13 @@ deleteBreak identity = do then printForUser (text "Breakpoint" <+> ppr identity <+> text "does not exist") else do - mapM (turnOffBreak.snd) this + mapM_ (turnOffBreak.snd) this setGHCiState $ st { breaks = rest } turnOffBreak :: BreakLocation -> GHCi Bool turnOffBreak loc = do (arr, _) <- getModBreak (breakModule loc) - io $ setBreakFlag False arr (breakTick loc) + liftIO $ setBreakFlag False arr (breakTick loc) getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan) getModBreak mod = do