X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=a18deb8c9fe0305196c1a7713cfd1d46f51bf1b2;hp=aacf8b3e621f01e1dddd1fff556b1264af2a7dab;hb=b4470389096913ed1430b077d29a2d1901f3c694;hpb=68a8c3bbab3a77a982fcac980e69f47b4ec13dfd diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index aacf8b3..a18deb8 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -6,6 +6,7 @@ -- (c) The GHC Team 2005-2006 -- ----------------------------------------------------------------------------- + module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where #include "HsVersions.h" @@ -17,14 +18,19 @@ import Debugger -- The GHC interface import qualified GHC import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..), - Type, Module, ModuleName, TyThing(..), Phase, - BreakIndex, SrcSpan, Resume, SingleStep ) + Module, ModuleName, TyThing(..), Phase, + BreakIndex, SrcSpan, Resume, SingleStep, Id ) +import PprTyThing import DynFlags + import Packages +#ifdef USE_READLINE import PackageConfig import UniqFM +#endif + import HscTypes ( implicitTyThings ) -import PprTyThing +import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC? import Outputable hiding (printForUser) import Module -- for ModuleEnv import Name @@ -41,12 +47,12 @@ import Util import NameSet import Maybes ( orElse ) import FastString +import Encoding #ifndef mingw32_HOST_OS import System.Posix hiding (getEnv) #else import GHC.ConsoleHandler ( flushConsole ) -import System.Win32 ( setConsoleCP, setConsoleOutputCP ) import qualified System.Win32 #endif @@ -74,14 +80,16 @@ import Data.Dynamic import Data.Array import Control.Monad as Monad import Text.Printf - -import Foreign.StablePtr ( newStablePtr ) +import Foreign +import Foreign.C ( withCStringLen ) import GHC.Exts ( unsafeCoerce# ) import GHC.IOBase ( IOErrorType(InvalidArgument) ) import Data.IORef ( IORef, readIORef, writeIORef ) +#ifdef USE_READLINE import System.Posix.Internals ( setNonBlockingFD ) +#endif ----------------------------------------------------------------------------- @@ -90,9 +98,12 @@ ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++ ": http://www.haskell.org/ghc/ :? for help" type Command = (String, String -> GHCi Bool, Bool, String -> IO [String]) + +cmdName :: Command -> String cmdName (n,_,_,_) = n -GLOBAL_VAR(commands, builtin_commands, [Command]) +macros_ref :: IORef [Command] +GLOBAL_VAR(macros_ref, [], [Command]) builtin_commands :: [Command] builtin_commands = [ @@ -102,13 +113,15 @@ builtin_commands = [ ("abandon", keepGoing abandonCmd, False, completeNone), ("break", keepGoing breakCmd, False, completeIdentifier), ("back", keepGoing backCmd, False, completeNone), - ("browse", keepGoing browseCmd, False, completeModule), + ("browse", keepGoing (browseCmd False), False, completeModule), + ("browse!", keepGoing (browseCmd True), False, completeModule), ("cd", keepGoing changeDirectory, False, completeFilename), ("check", keepGoing checkModule, False, completeHomeModule), ("continue", keepGoing continueCmd, False, completeNone), ("cmd", keepGoing cmdCmd, False, completeIdentifier), ("ctags", keepGoing createCTagsFileCmd, False, completeFilename), - ("def", keepGoing defineMacro, False, completeIdentifier), + ("def", keepGoing (defineMacro False), False, completeIdentifier), + ("def!", keepGoing (defineMacro True), False, completeIdentifier), ("delete", keepGoing deleteCmd, False, completeNone), ("e", keepGoing editFile, False, completeFilename), ("edit", keepGoing editFile, False, completeFilename), @@ -130,7 +143,8 @@ builtin_commands = [ ("show", keepGoing showCmd, False, completeNone), ("sprint", keepGoing sprintCmd, False, completeIdentifier), ("step", keepGoing stepCmd, False, completeIdentifier), - ("stepover", keepGoing stepOverCmd, False, completeIdentifier), + ("steplocal", keepGoing stepLocalCmd, False, completeIdentifier), + ("stepmodule",keepGoing stepModuleCmd, False, completeIdentifier), ("type", keepGoing typeOfExpr, False, completeIdentifier), ("trace", keepGoing traceCmd, False, completeIdentifier), ("undef", keepGoing undefineMacro, False, completeMacro), @@ -143,14 +157,18 @@ keepGoing a str = a str >> return False keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool) keepGoingPaths a str = a (toArgs str) >> return False +shortHelpText :: String shortHelpText = "use :? for help.\n" +helpText :: String helpText = " Commands available from the prompt:\n" ++ "\n" ++ " evaluate/run \n" ++ + " :{\\n ..lines.. \\n:}\\n multiline command\n" ++ " :add ... add module(s) to the current target set\n" ++ - " :browse [*] display the names defined by \n" ++ + " :browse[!] [-s] [[*]] display the names defined by module \n" ++ + " (!: more details; -s: sort; *: 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" ++ @@ -186,6 +204,8 @@ helpText = " :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"++ + " :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"++ @@ -207,6 +227,8 @@ helpText = " +t print type after evaluation\n" ++ " - most GHC command line flags can also be set here\n" ++ " (eg. -v2, -fglasgow-exts, etc.)\n" ++ + " for GHCi-specific flags, see User's Guide,\n"++ + " Flag reference, Interactive-mode options\n" ++ "\n" ++ " -- Commands for displaying information:\n" ++ "\n" ++ @@ -214,9 +236,12 @@ helpText = " :show breaks show the active breakpoints\n" ++ " :show context show the breakpoint context\n" ++ " :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" ++ "\n" +findEditor :: IO String findEditor = do getEnv "EDITOR" `IO.catch` \_ -> do @@ -257,7 +282,8 @@ interactiveUI session srcs maybe_expr = do hSetBuffering stdin NoBuffering -- initial context is just the Prelude - prel_mod <- GHC.findModule session prel_name (Just basePackageId) + prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude") + (Just basePackageId) GHC.setContext session [] [prel_mod] #ifdef USE_READLINE @@ -297,8 +323,6 @@ interactiveUI session srcs maybe_expr = do return () -prel_name = GHC.mkModuleName "Prelude" - runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi () runGHCi paths maybe_expr = do let read_dot_files = not opt_IgnoreDotGhci @@ -313,14 +337,14 @@ runGHCi paths maybe_expr = do when (dir_ok && file_ok) $ do either_hdl <- io (IO.try (openFile "./.ghci" ReadMode)) case either_hdl of - Left e -> return () - Right hdl -> fileLoop hdl False + Left _e -> return () + Right hdl -> runCommands (fileLoop hdl False False) when (read_dot_files) $ do -- Read in $HOME/.ghci - either_dir <- io (IO.try (getEnv "HOME")) + either_dir <- io (IO.try getHomeDirectory) case either_dir of - Left e -> return () + Left _e -> return () Right dir -> do cwd <- io (getCurrentDirectory) when (dir /= cwd) $ do @@ -329,8 +353,8 @@ runGHCi paths maybe_expr = do when ok $ do either_hdl <- io (IO.try (openFile file ReadMode)) case either_hdl of - Left e -> return () - Right hdl -> fileLoop hdl False + Left _e -> return () + Right hdl -> runCommands (fileLoop hdl False False) -- Perform a :load for files given on the GHCi command line -- When in -e mode, if the load fails then we want to stop @@ -361,9 +385,6 @@ runGHCi paths maybe_expr = do | otherwise -> io (ioError err) Right () -> return () #endif - -- initialise the console if necessary - io setUpConsole - -- enter the interactive loop interactiveLoop is_tty show_prompt Just expr -> do @@ -375,6 +396,7 @@ runGHCi paths maybe_expr = do io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi." +interactiveLoop :: Bool -> Bool -> GHCi () interactiveLoop is_tty show_prompt = -- Ignore ^C exceptions caught here ghciHandleDyn (\e -> case e of @@ -391,10 +413,10 @@ interactiveLoop is_tty show_prompt = -- read commands from stdin #ifdef USE_READLINE if (is_tty) - then readlineLoop - else fileLoop stdin show_prompt + then runCommands readlineLoop + else runCommands (fileLoop stdin show_prompt is_tty) #else - fileLoop stdin show_prompt + runCommands (fileLoop stdin show_prompt is_tty) #endif @@ -408,10 +430,11 @@ interactiveLoop is_tty show_prompt = -- the same directory while a process is running. checkPerms :: String -> IO Bool -checkPerms name = #ifdef mingw32_HOST_OS +checkPerms _ = return True #else +checkPerms name = Util.handle (\_ -> return False) $ do st <- getFileStatus name me <- getRealUserID @@ -429,27 +452,50 @@ checkPerms name = else return True #endif -fileLoop :: Handle -> Bool -> GHCi () -fileLoop hdl show_prompt = do +fileLoop :: Handle -> Bool -> Bool -> GHCi (Maybe String) +fileLoop hdl show_prompt is_tty = do when show_prompt $ do prompt <- mkPrompt (io (putStr prompt)) l <- io (IO.try (hGetLine hdl)) case l of - Left e | isEOFError e -> return () - | InvalidArgument <- etype -> return () - | otherwise -> io (ioError e) - where etype = ioeGetErrorType e - -- treat InvalidArgument in the same way as EOF: - -- this can happen if the user closed stdin, or - -- perhaps did getContents which closes stdin at - -- EOF. - Right l -> - case removeSpaces l of - "" -> fileLoop hdl show_prompt - l -> do quit <- runCommands l - if quit then return () else fileLoop hdl show_prompt + Left e | isEOFError e -> return Nothing + | InvalidArgument <- etype -> return Nothing + | otherwise -> io (ioError e) + where etype = ioeGetErrorType e + -- treat InvalidArgument in the same way as EOF: + -- this can happen if the user closed stdin, or + -- perhaps did getContents which closes stdin at + -- EOF. + Right l -> do + str <- io $ consoleInputToUnicode is_tty l + return (Just str) +#ifdef mingw32_HOST_OS +-- Convert the console input into Unicode according to the current code page. +-- The Windows console stores Unicode characters directly, so this is a +-- rather roundabout way of doing things... oh well. +-- See #782, #1483, #1649 +consoleInputToUnicode :: Bool -> String -> IO String +consoleInputToUnicode is_tty str + | is_tty = do + cp <- System.Win32.getConsoleCP + System.Win32.stringToUnicode cp str + | otherwise = + decodeStringAsUTF8 str +#else +-- for Unix, assume the input is in UTF-8 and decode it to a Unicode String. +-- See #782. +consoleInputToUnicode :: Bool -> String -> IO String +consoleInputToUnicode _is_tty str = decodeStringAsUTF8 str +#endif + +decodeStringAsUTF8 :: String -> IO String +decodeStringAsUTF8 str = + withCStringLen str $ \(cstr,len) -> + utf8DecodeString (castPtr cstr :: Ptr Word8) len + +mkPrompt :: GHCi String mkPrompt = do session <- getSession (toplevs,exports) <- io (GHC.getContext session) @@ -458,7 +504,7 @@ mkPrompt = do context_bit <- case resumes of [] -> return empty - r:rs -> do + r:_ -> do let ix = GHC.resumeHistoryIx r if ix == 0 then return (brackets (ppr (GHC.resumeSpan r)) <> space) @@ -468,7 +514,7 @@ mkPrompt = do return (brackets (ppr (negate ix) <> char ':' <+> ppr span) <> space) let - dots | r:rs <- resumes, not (null rs) = text "... " + dots | _:rs <- resumes, not (null rs) = text "... " | otherwise = empty modules_bit = @@ -487,45 +533,73 @@ mkPrompt = do #ifdef USE_READLINE -readlineLoop :: GHCi () +readlineLoop :: GHCi (Maybe String) readlineLoop = do - session <- getSession - (mod,imports) <- io (GHC.getContext session) io yield saveSession -- for use by completion - st <- getGHCiState - mb_span <- getCurrentBreakSpan 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 + -- readline sometimes puts stdin into blocking mode, + -- so we need to put it back for the IO library splatSavedSession case l of - Nothing -> return () - Just l -> - case removeSpaces l of - "" -> readlineLoop - l -> do - io (addHistory l) - quit <- runCommands l - if quit then return () else readlineLoop + Nothing -> return Nothing + Just l -> do + io (addHistory l) + str <- io $ consoleInputToUnicode True l + return (Just str) #endif -runCommands :: String -> GHCi Bool -runCommands cmd = do - q <- ghciHandle handler (doCommand cmd) - if q then return True else runNext +queryQueue :: GHCi (Maybe String) +queryQueue = do + st <- getGHCiState + case cmdqueue st of + [] -> return Nothing + c:cs -> do setGHCiState st{ cmdqueue = cs } + return (Just c) + +runCommands :: GHCi (Maybe String) -> GHCi () +runCommands getCmd = do + mb_cmd <- noSpace queryQueue + mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd + case mb_cmd of + Nothing -> return () + Just c -> do + b <- ghciHandle handler (doCommand c) + if b then return () else runCommands getCmd where - runNext = do - st <- getGHCiState - case cmdqueue st of - [] -> return False - c:cs -> do setGHCiState st{ cmdqueue = cs } - runCommands c - - doCommand (':' : cmd) = specialCommand cmd - doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion - return False + noSpace q = q >>= maybe (return Nothing) + (\c->case removeSpaces c of + "" -> noSpace q + ":{" -> multiLineCmd q + c -> return (Just c) ) + multiLineCmd q = do + st <- getGHCiState + let p = prompt st + setGHCiState st{ prompt = "%s| " } + mb_cmd <- collectCommand q "" + getGHCiState >>= \st->setGHCiState st{ prompt = p } + return mb_cmd + -- we can't use removeSpaces for the sublines here, so + -- multiline commands are somewhat more brittle against + -- fileformat errors (such as \r in dos input on unix), + -- we get rid of any extra spaces for the ":}" test; + -- we also avoid silent failure if ":}" is not found; + -- and since there is no (?) valid occurrence of \r (as + -- opposed to its String representation, "\r") inside a + -- ghci command, we replace any such with ' ' (argh:-( + collectCommand q c = q >>= + maybe (io (ioError collectError)) + (\l->if removeSpaces l == ":}" + then return (Just $ removeSpaces c) + else collectCommand q (c++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 $ runStmt stmt GHC.RunToCompletion + return False enqueueCommands :: [String] -> GHCi () enqueueCommands cmds = do @@ -536,6 +610,7 @@ enqueueCommands cmds = do -- This version is for the GHC command-line option -e. The only difference -- from runCommand is that it catches the ExitException exception and -- exits, rather than printing out the exception. +runCommandEval :: String -> GHCi Bool runCommandEval c = ghciHandle handleEval (doCommand c) where handleEval (ExitException code) = io (exitWith code) @@ -564,8 +639,9 @@ runStmt stmt step --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 pred run_result = do +afterRunStmt step_here run_result = do session <- getSession resumes <- io $ GHC.getResumeContext session case run_result of @@ -574,17 +650,22 @@ afterRunStmt pred run_result = do when show_types $ printTypeOfNames session names GHC.RunBreak _ names mb_info | isNothing mb_info || - pred (GHC.resumeSpan $ head resumes) -> do + step_here (GHC.resumeSpan $ head resumes) -> do printForUser $ ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan $ head resumes) - printTypeOfNames session names +-- printTypeOfNames session names + let namesSorted = sortBy compareNames names + tythings <- catMaybes `liftM` + io (mapM (GHC.lookupName session) namesSorted) + + printTypeAndContents session [id | AnId id <- tythings] 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) >>= - afterRunStmt pred >> return () + afterRunStmt step_here >> return () _ -> return () flushInterpBuffers @@ -599,7 +680,7 @@ runBreakCmd info = do let mod = GHC.breakInfo_module info nm = GHC.breakInfo_number info st <- getGHCiState - case [ loc | (i,loc) <- breaks st, + case [ loc | (_,loc) <- breaks st, breakModule loc == mod, breakTick loc == nm ] of [] -> return () loc:_ | null cmd -> return () @@ -621,6 +702,22 @@ printTypeOfName session n Nothing -> return () Just thing -> printTyThing thing +printTypeAndContents :: Session -> [Id] -> GHCi () +printTypeAndContents session ids = do + dflags <- getDynFlags + let pefas = dopt Opt_PrintExplicitForalls dflags + pcontents = dopt Opt_PrintBindContents dflags + if pcontents + then do + let depthBound = 100 + terms <- mapM (io . GHC.obtainTermB session depthBound False) ids + docs_terms <- mapM (io . showTerm session) terms + printForUser $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts) + (map (pprTyThing pefas . AnId) ids) + docs_terms + else printForUser $ vcat $ map (pprTyThing pefas . AnId) ids + + specialCommand :: String -> GHCi Bool specialCommand ('!':str) = shellEscape (dropWhile isSpace str) specialCommand str = do @@ -633,7 +730,8 @@ specialCommand str = do lookupCommand :: String -> IO (Maybe Command) lookupCommand str = do - cmds <- readIORef commands + macros <- readIORef macros_ref + let cmds = builtin_commands ++ macros -- look for exact match first, then the first prefix match case [ c | c <- cmds, str == cmdName c ] of c:_ -> return (Just c) @@ -648,7 +746,7 @@ getCurrentBreakSpan = do resumes <- io $ GHC.getResumeContext session case resumes of [] -> return Nothing - (r:rs) -> do + (r:_) -> do let ix = GHC.resumeHistoryIx r if ix == 0 then return (Just (GHC.resumeSpan r)) @@ -663,10 +761,10 @@ getCurrentBreakModule = do resumes <- io $ GHC.getResumeContext session case resumes of [] -> return Nothing - (r:rs) -> do + (r:_) -> do let ix = GHC.resumeHistoryIx r if ix == 0 - then return (GHC.breakInfo_module `fmap` GHC.resumeBreakInfo r) + then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r) else do let hist = GHC.resumeHistory r !! (ix-1) return $ Just $ GHC.getHistoryModule hist @@ -676,7 +774,7 @@ getCurrentBreakModule = do noArgs :: GHCi () -> String -> GHCi () noArgs m "" = m -noArgs m _ = io $ putStrLn "This command takes no arguments" +noArgs _ _ = io $ putStrLn "This command takes no arguments" help :: String -> GHCi () help _ = io (putStr helpText) @@ -692,7 +790,7 @@ info s = do { let names = words s infoThing pefas session str = io $ do names <- GHC.parseName session str mb_stuffs <- mapM (GHC.getInfo session) names - let filtered = filterOutChildren (\(t,f,i) -> t) (catMaybes mb_stuffs) + let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) unqual <- GHC.getPrintUnqual session putStrLn (showSDocForUser unqual $ vcat (intersperse (text "") $ @@ -730,7 +828,7 @@ addModule files = do session <- getSession io (mapM_ (GHC.addTarget session) targets) ok <- io (GHC.load session LoadAllTargets) - afterLoad ok session + afterLoad ok session Nothing changeDirectory :: String -> GHCi () changeDirectory dir = do @@ -788,18 +886,24 @@ chooseEditFile = where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f fromTarget _ = Nothing -- when would we get a module target? -defineMacro :: String -> GHCi () -defineMacro s = do +defineMacro :: Bool{-overwrite-} -> String -> GHCi () +defineMacro overwrite s = do let (macro_name, definition) = break isSpace s - cmds <- io (readIORef commands) + macros <- io (readIORef macros_ref) + let defined = map cmdName macros if (null macro_name) - then throwDyn (CmdLineError "invalid macro name") + then if null defined + then io $ putStrLn "no macros defined" + else io $ putStr ("the following macros are defined:\n" ++ + unlines defined) else do - if (macro_name `elem` map cmdName cmds) + if (not overwrite && macro_name `elem` defined) then throwDyn (CmdLineError - ("command '" ++ macro_name ++ "' is already defined")) + ("macro '" ++ macro_name ++ "' is already defined")) else do + let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ] + -- give the expression a type signature, so we can be sure we're getting -- something of the right type. let new_expr = '(' : definition ++ ") :: String -> IO String" @@ -809,8 +913,8 @@ defineMacro s = do maybe_hv <- io (GHC.compileExpr cms new_expr) case maybe_hv of Nothing -> return () - Just hv -> io (writeIORef commands -- - (cmds ++ [(macro_name, runMacro hv, False, completeNone)])) + Just hv -> io (writeIORef macros_ref -- + (filtered ++ [(macro_name, runMacro hv, False, completeNone)])) runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool runMacro fun s = do @@ -819,17 +923,14 @@ runMacro fun s = do return False undefineMacro :: String -> GHCi () -undefineMacro macro_name = do - cmds <- io (readIORef commands) - if (macro_name `elem` map cmdName builtin_commands) - then throwDyn (CmdLineError - ("command '" ++ macro_name ++ "' cannot be undefined")) - else do - if (macro_name `notElem` map cmdName cmds) - then throwDyn (CmdLineError - ("command '" ++ macro_name ++ "' not defined")) - else do - io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds)) +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 + ("macro '" ++ macro_name ++ "' is not defined")) + else do + io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds)) cmdCmd :: String -> GHCi () cmdCmd str = do @@ -870,7 +971,7 @@ loadModule' files = do -- as a ToDo for now. io (GHC.setTargets session targets) - doLoad session LoadAllTargets + doLoad session False LoadAllTargets checkModule :: String -> GHCi () checkModule m = do @@ -888,33 +989,46 @@ checkModule m = do (text "global names: " <+> ppr global) $$ (text "local names: " <+> ppr local) _ -> empty)) - afterLoad (successIf (isJust result)) session + afterLoad (successIf (isJust result)) session Nothing reloadModule :: String -> GHCi () reloadModule m = do - io (revertCAFs) -- always revert CAFs on reload. - discardActiveBreakPoints session <- getSession - doLoad session $ if null m then LoadAllTargets - else LoadUpTo (GHC.mkModuleName m) + doLoad session True $ if null m then LoadAllTargets + else LoadUpTo (GHC.mkModuleName m) return () -doLoad session howmuch = do +doLoad :: Session -> Bool -> LoadHowMuch -> GHCi SuccessFlag +doLoad session retain_context howmuch = do -- turn off breakpoints before we load: we can't turn them off later, because -- the ModBreaks will have gone away. discardActiveBreakPoints + context <- io $ GHC.getContext session ok <- io (GHC.load session howmuch) - afterLoad ok session + afterLoad ok session (if retain_context then Just context else Nothing) return ok -afterLoad ok session = do +afterLoad :: SuccessFlag -> Session -> Maybe ([Module],[Module]) -> GHCi () +afterLoad ok session maybe_context = do io (revertCAFs) -- always revert CAFs on load. discardTickArrays - graph <- io (GHC.getModuleGraph session) - graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph - setContextAfterLoad session graph' - modulesLoadedMsg ok (map GHC.ms_mod_name graph') - + loaded_mods <- getLoadedModules session + + -- try to retain the old module context for :reload. This might + -- not be possible, for example if some modules have gone away, so + -- we attempt to set the same context, backing off to the default + -- context if that fails. + case maybe_context of + Nothing -> setContextAfterLoad session loaded_mods + Just (as,bs) -> do + r <- io $ Exception.try (GHC.setContext session as bs) + case r of + Left _err -> setContextAfterLoad session loaded_mods + Right _ -> return () + + modulesLoadedMsg ok (map GHC.ms_mod_name loaded_mods) + +setContextAfterLoad :: Session -> [GHC.ModSummary] -> GHCi () setContextAfterLoad session [] = do prel_mod <- getPrelude io (GHC.setContext session [] [prel_mod]) @@ -937,7 +1051,7 @@ setContextAfterLoad session ms = do = GHC.ms_mod_name summary == m summary `matches` Target (TargetFile f _) _ | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f' - summary `matches` target + _ `matches` _ = False load_this summary | m <- GHC.ms_mod summary = do @@ -969,8 +1083,10 @@ typeOfExpr str maybe_ty <- io (GHC.exprType cms str) case maybe_ty of Nothing -> return () - Just ty -> do ty' <- cleanType ty - printForUser $ text str <> text " :: " <> ppr ty' + Just ty -> do dflags <- getDynFlags + let pefas = dopt Opt_PrintExplicitForalls dflags + printForUser $ text str <+> dcolon + <+> pprTypeForUser pefas ty kindOfType :: String -> GHCi () kindOfType str @@ -978,7 +1094,7 @@ kindOfType str maybe_ty <- io (GHC.typeKind cms str) case maybe_ty of Nothing -> return () - Just ty -> printForUser $ text str <> text " :: " <> ppr ty + Just ty -> printForUser $ text str <+> dcolon <+> ppr ty quit :: String -> GHCi Bool quit _ = return True @@ -989,51 +1105,112 @@ shellEscape str = io (system str >> return False) ----------------------------------------------------------------------------- -- Browsing a module's contents -browseCmd :: String -> GHCi () -browseCmd m = +browseCmd :: Bool -> String -> GHCi () +browseCmd bang m = case words m of - ['*':m] | looksLikeModuleName m -> browseModule m False - [m] | looksLikeModuleName m -> browseModule m True + ['*':s] | looksLikeModuleName s -> do + m <- wantInterpretedModule s + browseModule bang m False + [s] | looksLikeModuleName s -> do + m <- lookupModule s + browseModule bang m True + [] -> do + s <- getSession + (as,bs) <- io $ GHC.getContext s + -- 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 ") -browseModule m exports_only = do +-- without bang, show items in context of their parents and omit children +-- with bang, show class methods and data constructors separately, and +-- indicate import modules, to aid qualifying unqualified names +-- with sorted, sort items alphabetically +browseModule :: Bool -> Module -> Bool -> GHCi () +browseModule bang modl exports_only = do s <- getSession - modl <- if exports_only then lookupModule m - else wantInterpretedModule m - -- 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) prel_mod <- getPrelude io (if exports_only then GHC.setContext s [] [prel_mod,modl] - else GHC.setContext s [modl] []) + else GHC.setContext s [modl] []) unqual <- io (GHC.getPrintUnqual s) io (GHC.setContext s as bs) mb_mod_info <- io $ GHC.getModuleInfo s modl case mb_mod_info of - Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m)) + Nothing -> throwDyn (CmdLineError ("unknown module: " ++ + GHC.moduleNameString (GHC.moduleName modl))) Just mod_info -> do - let names - | exports_only = GHC.modInfoExports mod_info - | otherwise = GHC.modInfoTopLevelScope mod_info - `orElse` [] - - mb_things <- io $ mapM (GHC.lookupName s) names - let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things) - dflags <- getDynFlags - let pefas = dopt Opt_PrintExplicitForalls dflags - io (putStrLn (showSDocForUser unqual ( - vcat (map (pprTyThingInContext pefas) filtered_things) - ))) - -- ToDo: modInfoInstances currently throws an exception for - -- package modules. When it works, we can do this: - -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info)) + let names + | exports_only = GHC.modInfoExports mod_info + | otherwise = GHC.modInfoTopLevelScope mod_info + `orElse` [] + + -- sort alphabetically name, but putting + -- locally-defined identifiers first. + -- We would like to improve this; see #1799. + sorted_names = loc_sort local ++ occ_sort external + where + (local,external) = 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. + loc_sort names + | n:_ <- names, isGoodSrcSpan (nameSrcSpan n) + = sortBy (compare `on` nameSrcSpan) names + | otherwise + = occ_sort names + + mb_things <- io $ mapM (GHC.lookupName s) sorted_names + let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things) + + rdr_env <- io $ GHC.getGRE s + + let pefas = dopt Opt_PrintExplicitForalls dflags + things | bang = catMaybes mb_things + | otherwise = filtered_things + pretty | bang = pprTyThing + | otherwise = pprTyThingInContext + + labels [] = text "-- not currently imported" + labels l = text $ intercalate "\n" $ map qualifier l + qualifier = maybe "-- defined locally" + (("-- imported from "++) . intercalate ", " + . map GHC.moduleNameString) + importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env + modNames = map (importInfo . GHC.getName) things + + -- annotate groups of imports with their import modules + -- the default ordering is somewhat arbitrary, so we group + -- by header and sort groups; the names themselves should + -- really come in order of source appearance.. (trac #1799) + annotate mts = concatMap (\(m,ts)->labels m:ts) + $ sortBy cmpQualifiers $ group mts + where cmpQualifiers = + compare `on` (map (fmap (map moduleNameFS)) . fst) + group [] = [] + group mts@((m,_):_) = (m,map snd g) : group ng + where (g,ng) = partition ((==m).fst) mts + + let prettyThings = map (pretty pefas) things + prettyThings' | bang = annotate $ zip modNames prettyThings + | otherwise = prettyThings + io (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)) ----------------------------------------------------------------------------- -- Setting the module context +setContext :: String -> GHCi () setContext str | all sensible mods = fn mods | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn") @@ -1048,16 +1225,12 @@ setContext str separate :: Session -> [String] -> [Module] -> [Module] -> GHCi ([Module],[Module]) -separate session [] as bs = return (as,bs) +separate _ [] as bs = return (as,bs) separate session (('*':str):ms) as bs = do - m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing - b <- io $ GHC.moduleIsInterpreted session m - if b then separate session ms (m:as) bs - else throwDyn (CmdLineError ("module '" - ++ GHC.moduleNameString (GHC.moduleName m) - ++ "' is not interpreted")) + m <- wantInterpretedModule str + separate session ms (m:as) bs separate session (str:ms) as bs = do - m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing + m <- lookupModule str separate session ms as (m:bs) newContext :: [String] -> GHCi () @@ -1114,16 +1287,41 @@ setCmd "" then text "none." else hsep (map (\o -> char '+' <> text (optToStr o)) opts) )) + dflags <- getDynFlags + io $ putStrLn (showSDoc ( + vcat (text "GHCi-specific dynamic flag settings:" + :map (flagSetting dflags) ghciFlags) + )) + io $ putStrLn (showSDoc ( + vcat (text "other dynamic, non-language, flag settings:" + :map (flagSetting dflags) nonLanguageDynFlags) + )) + 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 = filter (\(_,f)->not $ f `elem` map snd xFlags) + others + flags = [Opt_PrintExplicitForalls + ,Opt_PrintBindResult + ,Opt_BreakOnException + ,Opt_BreakOnError + ,Opt_PrintEvldWithShow + ] setCmd str = case toArgs str of ("args":args) -> setArgs args ("prog":prog) -> setProg prog - ("prompt":prompt) -> setPrompt (after 6) - ("editor":cmd) -> setEditor (after 6) - ("stop":cmd) -> setStop (after 4) + ("prompt":_) -> setPrompt (after 6) + ("editor":_) -> setEditor (after 6) + ("stop":_) -> setStop (after 4) wds -> setOptions wds where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str +setArgs, setProg, setOptions :: [String] -> GHCi () +setEditor, setStop, setPrompt :: String -> GHCi () + setArgs args = do st <- getGHCiState setGHCiState st{ args = args } @@ -1166,11 +1364,12 @@ setPrompt value = do setOptions wds = do -- first, deal with the GHCi opts (+s, +t, etc.) - let (plus_opts, minus_opts) = partition isPlus wds + let (plus_opts, minus_opts) = partitionWith isPlus wds mapM_ setOpt plus_opts -- then, dynamic flags newDynFlags minus_opts +newDynFlags :: [String] -> GHCi () newDynFlags minus_opts = do dflags <- getDynFlags let pkg_flags = packageFlags dflags @@ -1201,7 +1400,7 @@ 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) = partition isPlus rest1 + (plus_opts, rest2) = partitionWith isPlus rest1 if (not (null rest2)) then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'")) @@ -1215,18 +1414,22 @@ unsetOptions str no_flags <- mapM no_flag minus_opts newDynFlags no_flags -isMinus ('-':s) = True +isMinus :: String -> Bool +isMinus ('-':_) = True isMinus _ = False -isPlus ('+':s) = True -isPlus _ = False +isPlus :: String -> Either String String +isPlus ('+':opt) = Left opt +isPlus other = Right other -setOpt ('+':str) +setOpt, unsetOpt :: String -> GHCi () + +setOpt str = case strToGHCiOpt str of Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'")) Just o -> setOption o -unsetOpt ('+':str) +unsetOpt str = case strToGHCiOpt str of Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'")) Just o -> unsetOption o @@ -1245,6 +1448,7 @@ optToStr RevertCAFs = "r" -- --------------------------------------------------------------------------- -- code for `:show' +showCmd :: String -> GHCi () showCmd str = do st <- getGHCiState case words str of @@ -1258,38 +1462,36 @@ showCmd str = do ["linker"] -> io showLinkerState ["breaks"] -> showBkptTable ["context"] -> showContext + ["packages"] -> showPackages + ["languages"] -> showLanguages _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]") +showModules :: GHCi () showModules = do session <- getSession - let show_one ms = do m <- io (GHC.showModule session ms) - io (putStrLn m) + loaded_mods <- getLoadedModules session + -- we want *loaded* modules only, see #1734 + let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m) + mapM_ show_one loaded_mods + +getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary] +getLoadedModules session = do graph <- io (GHC.getModuleGraph session) - mapM_ show_one graph + filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph +showBindings :: GHCi () showBindings = do s <- getSession - unqual <- io (GHC.getPrintUnqual s) bindings <- io (GHC.getBindings s) - mapM_ printTyThing $ sortBy compareTyThings bindings - return () + printTypeAndContents s [ id | AnId id <- sortBy compareTyThings bindings] compareTyThings :: TyThing -> TyThing -> Ordering t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2 printTyThing :: TyThing -> GHCi () -printTyThing (AnId id) = do - ty' <- cleanType (GHC.idType id) - printForUser $ ppr id <> text " :: " <> ppr ty' -printTyThing _ = return () - --- if -fglasgow-exts is on we show the foralls, otherwise we don't. -cleanType :: Type -> GHCi Type -cleanType ty = do - dflags <- getDynFlags - if dopt Opt_PrintExplicitForalls dflags - then return ty - else return $! GHC.dropForAlls ty +printTyThing tyth = do dflags <- getDynFlags + let pefas = dopt Opt_PrintExplicitForalls dflags + printForUser (pprTyThing pefas tyth) showBkptTable :: GHCi () showBkptTable = do @@ -1306,21 +1508,47 @@ showContext = do ptext SLIT("--> ") <> text (GHC.resumeStmt resume) $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume)) +showPackages :: GHCi () +showPackages = do + pkg_flags <- fmap packageFlags getDynFlags + io $ 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) pkg_ids + where showFlag (ExposePackage p) = text $ " -package " ++ p + showFlag (HidePackage p) = text $ " -hide-package " ++ p + showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p + +showLanguages :: GHCi () +showLanguages = do + dflags <- getDynFlags + io $ putStrLn $ showSDoc $ vcat $ + text "active language flags:" : + [text (" -X" ++ str) | (str,f) <- DynFlags.xFlags, dopt f dflags] -- ----------------------------------------------------------------------------- -- Completion completeNone :: String -> IO [String] -completeNone w = return [] +completeNone _w = return [] + +completeMacro, completeIdentifier, completeModule, + completeHomeModule, completeSetOptions, completeFilename, + completeHomeModuleOrFile + :: String -> IO [String] #ifdef USE_READLINE completeWord :: String -> Int -> Int -> IO (Maybe (String, [String])) completeWord w start end = do line <- Readline.getLineBuffer - case w of + let line_words = words (dropWhile isSpace line) + case w of ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w _other - | Just c <- is_cmd line -> do + | ((':':c) : _) <- line_words -> do maybe_cmd <- lookupCommand c let (n,w') = selectWord (words' 0 line) case maybe_cmd of @@ -1329,6 +1557,8 @@ completeWord w start end = do Just (_,_,True,complete) -> let complete' w = do rets <- complete w return (map (drop n) rets) in wrapCompleter complete' w' + | ("import" : _) <- line_words -> + wrapCompleter completeModule w | otherwise -> do --printf "complete %s, start = %d, end = %d\n" w start end wrapCompleter completeIdentifier w @@ -1344,18 +1574,15 @@ completeWord w start end = do | offset+length x >= start = (start-offset,take (end-offset) x) | otherwise = selectWord xs -is_cmd line - | ((':':w) : _) <- words (dropWhile isSpace line) = Just w - | otherwise = Nothing - +completeCmd :: String -> IO [String] completeCmd w = do - cmds <- readIORef commands - return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds))) + cmds <- readIORef macros_ref + return (filter (w `isPrefixOf`) (map (':':) + (map cmdName (builtin_commands ++ cmds)))) completeMacro w = do - cmds <- readIORef commands - let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ] - return (filter (w `isPrefixOf`) cmds') + cmds <- readIORef macros_ref + return (filter (w `isPrefixOf`) (map cmdName cmds)) completeIdentifier w = do s <- restoreSession @@ -1401,19 +1628,18 @@ wrapCompleter fun w = do getCommonPrefix :: [String] -> String getCommonPrefix [] = "" getCommonPrefix (s:ss) = foldl common s ss - where common s "" = "" - common "" s = "" + where common _s "" = "" + common "" _s = "" common (c:cs) (d:ds) | c == d = c : common cs ds | otherwise = "" allExposedModules :: DynFlags -> [ModuleName] allExposedModules dflags - = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db)))) + = concat (map exposedModules (filter exposed (eltsUFM pkg_db))) where pkg_db = pkgIdMap (pkgState dflags) #else -completeCmd = completeNone completeMacro = completeNone completeIdentifier = completeNone completeModule = completeNone @@ -1421,7 +1647,6 @@ completeHomeModule = completeNone completeSetOptions = completeNone completeFilename = completeNone completeHomeModuleOrFile=completeNone -completeBkpt = completeNone #endif -- --------------------------------------------------------------------------- @@ -1444,6 +1669,7 @@ handler exception = do io installSignalHandlers ghciHandle handler (showException exception >> return False) +showException :: Exception -> GHCi () showException (DynException dyn) = case fromDynamic dyn of Nothing -> io (putStrLn ("*** Exception: (unknown)")) @@ -1478,7 +1704,7 @@ expandPath :: String -> GHCi String expandPath path = case dropWhile isSpace path of ('~':d) -> do - tilde <- io (getEnv "HOME") -- will fail if HOME not defined + tilde <- io getHomeDirectory -- will fail if HOME not defined return (tilde ++ '/':d) other -> return other @@ -1492,6 +1718,9 @@ wantInterpretedModule str = do throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted")) return modl +wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String + -> (Name -> GHCi ()) + -> GHCi () wantNameFromInterpretedModule noCanDo str and_then = do session <- getSession names <- io $ GHC.parseName session str @@ -1509,37 +1738,15 @@ wantNameFromInterpretedModule noCanDo str and_then = do text " is not interpreted" else and_then n --- ---------------------------------------------------------------------------- --- Windows console setup - -setUpConsole :: IO () -setUpConsole = do -#ifdef mingw32_HOST_OS - -- On Windows we need to set a known code page, otherwise the characters - -- we read from the console will be be in some strange encoding, and - -- similarly for characters we write to the console. - -- - -- At the moment, GHCi pretends all input is Latin-1. In the - -- future we should support UTF-8, but for now we set the code pages - -- to Latin-1. - -- - -- It seems you have to set the font in the console window to - -- a Unicode font in order for output to work properly, - -- otherwise non-ASCII characters are mapped wrongly. sigh. - -- (see MSDN for SetConsoleOutputCP()). - -- - setConsoleCP 28591 -- ISO Latin-1 - setConsoleOutputCP 28591 -- ISO Latin-1 -#endif - return () - -- ----------------------------------------------------------------------------- -- commands for debugger +sprintCmd, printCmd, forceCmd :: String -> GHCi () sprintCmd = pprintCommand False False printCmd = pprintCommand True False forceCmd = pprintCommand False True +pprintCommand :: Bool -> Bool -> String -> GHCi () pprintCommand bind force str = do session <- getSession io $ pprintClosureCommand session bind force str @@ -1548,43 +1755,31 @@ stepCmd :: String -> GHCi () stepCmd [] = doContinue (const True) GHC.SingleStep stepCmd expression = do runStmt expression GHC.SingleStep; return () -stepOverCmd [] = do +stepLocalCmd :: String -> GHCi () +stepLocalCmd [] = do mb_span <- getCurrentBreakSpan case mb_span of Nothing -> stepCmd [] Just loc -> do Just mod <- getCurrentBreakModule - parent <- enclosingTickSpan mod loc - allTicksRightmost <- (sortBy rightmost . map snd) `fmap` - ticksIn mod parent - let lastTick = null allTicksRightmost || - head allTicksRightmost == loc - if not lastTick - then doContinue (`isSubspanOf` parent) GHC.SingleStep - else doContinue (const True) GHC.SingleStep - - where - -{- - So, the only tricky part in stepOver is detecting that we have - arrived to the last tick in an expression, in which case we must - step normally to the next tick. - What we do is: - 1. Retrieve the enclosing expression block (with a tick) - 2. Retrieve all the ticks there and sort them out by 'rightness' - 3. See if the current tick turned out the first one in the list --} - ---ticksIn :: Module -> SrcSpan -> GHCi [Tick] -ticksIn mod src = do - ticks <- getTickArray mod - let lines = [srcSpanStartLine src .. srcSpanEndLine src] - return [ t | line <- lines - , t@(_,span) <- ticks ! line - , srcSpanStart src <= srcSpanStart span - , srcSpanEnd src >= srcSpanEnd span - ] + current_toplevel_decl <- enclosingTickSpan mod loc + doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep +stepLocalCmd expression = stepCmd expression + +stepModuleCmd :: String -> GHCi () +stepModuleCmd [] = do + mb_span <- getCurrentBreakSpan + case mb_span of + Nothing -> stepCmd [] + Just _ -> do + Just span <- getCurrentBreakSpan + let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span + doContinue f GHC.SingleStep + +stepModuleCmd expression = stepCmd expression + +-- | Returns the span of the largest tick containing the srcspan given enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan enclosingTickSpan mod src = do ticks <- getTickArray mod @@ -1602,6 +1797,7 @@ continueCmd :: String -> GHCi () 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 @@ -1643,7 +1839,7 @@ historyCmd arg resumes <- io $ GHC.getResumeContext s case resumes of [] -> io $ putStrLn "Not stopped at a breakpoint" - (r:rs) -> do + (r:_) -> do let hist = GHC.resumeHistory r (took,rest) = splitAt num hist spans <- mapM (io . GHC.getHistorySpan s) took @@ -1652,14 +1848,18 @@ historyCmd arg printForUser (vcat(zipWith3 (\x y z -> x <+> y <+> z) (map text nums) - (map (ftext . occNameFS . nameOccName) names) + (map (bold . ppr) names) (map (parens . ppr) spans))) io $ putStrLn $ if null rest then "" else "..." +bold :: SDoc -> SDoc +bold c | do_bold = text start_bold <> c <> text end_bold + | otherwise = c + backCmd :: String -> GHCi () backCmd = noArgs $ do s <- getSession - (names, ix, span) <- io $ GHC.back s + (names, _, span) <- io $ GHC.back s printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span printTypeOfNames s names -- run the command set with ":set stop " @@ -1687,10 +1887,10 @@ breakCmd argLine = do breakSwitch :: Session -> [String] -> GHCi () breakSwitch _session [] = do io $ putStrLn "The break command requires at least one argument." -breakSwitch session args@(arg1:rest) +breakSwitch session (arg1:rest) | looksLikeModuleName arg1 = do mod <- wantInterpretedModule arg1 - breakByModule session mod rest + breakByModule mod rest | all isDigit arg1 = do (toplevel, _) <- io $ GHC.getContext session case toplevel of @@ -1711,11 +1911,11 @@ breakSwitch session args@(arg1:rest) noCanDo n why = printForUser $ text "cannot set breakpoint on " <> ppr n <> text ": " <> why -breakByModule :: Session -> Module -> [String] -> GHCi () -breakByModule session mod args@(arg1:rest) +breakByModule :: Module -> [String] -> GHCi () +breakByModule mod (arg1:rest) | all isDigit arg1 = do -- looks like a line number breakByModuleLine mod (read arg1) rest -breakByModule session mod _ +breakByModule _ _ = breakSyntax breakByModuleLine :: Module -> Int -> [String] -> GHCi () @@ -1725,6 +1925,7 @@ breakByModuleLine mod line args findBreakAndSet mod $ findBreakByCoord Nothing (line, read col) | otherwise = breakSyntax +breakSyntax :: a breakSyntax = throwDyn (CmdLineError "Syntax: :break [] []") findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi () @@ -1735,7 +1936,6 @@ findBreakAndSet mod lookupTickTree = do Nothing -> io $ putStrLn $ "No breakpoints found at that location." Just (tick, span) -> do success <- io $ setBreakFlag True breakArray tick - session <- getSession if success then do (alreadySet, nm) <- @@ -1770,11 +1970,11 @@ findBreakByLine line arr where ticks = arr ! line - starts_here = [ tick | tick@(nm,span) <- ticks, + starts_here = [ tick | tick@(_,span) <- ticks, GHC.srcSpanStartLine span == line ] (complete,incomplete) = partition ends_here starts_here - where ends_here (nm,span) = GHC.srcSpanEndLine span == line + where ends_here (_,span) = GHC.srcSpanEndLine span == line findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan) @@ -1787,30 +1987,31 @@ findBreakByCoord mb_file (line, col) arr ticks = arr ! line -- the ticks that span this coordinate - contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col), + contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col), is_correct_file span ] is_correct_file span | Just f <- mb_file = GHC.srcSpanFile span == f | otherwise = True - after_here = [ tick | tick@(nm,span) <- ticks, + after_here = [ tick | tick@(_,span) <- ticks, GHC.srcSpanStartLine span == line, GHC.srcSpanStartCol span >= col ] --- for now, use ANSI bold on Unixy systems. On Windows, we add a line --- of carets under the active expression instead. The Windows console --- doesn't support ANSI escape sequences, and most Unix terminals --- (including xterm) do, so this is a reasonable guess until we have a --- proper termcap/terminfo library. -#if !defined(mingw32_TARGET_OS) -do_bold = True -#else -do_bold = False -#endif - -start_bold = BS.pack "\ESC[1m" -end_bold = BS.pack "\ESC[0m" +-- For now, use ANSI bold on terminals that we know support it. +-- Otherwise, we add a line of carets under the active expression instead. +-- In particular, on Windows and when running the testsuite (which sets +-- TERM to vt100 for other reasons) we get carets. +-- We really ought to use a proper termcap/terminfo library. +do_bold :: Bool +do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"] + where mTerm = System.Environment.getEnv "TERM" + `Exception.catch` \_ -> return "TERM not set" + +start_bold :: String +start_bold = "\ESC[1m" +end_bold :: String +end_bold = "\ESC[0m" listCmd :: String -> GHCi () listCmd "" = do @@ -1821,6 +2022,7 @@ listCmd "" = do | otherwise -> printForUser $ text "unable to list source for" <+> ppr span listCmd str = list2 (words str) +list2 :: [String] -> GHCi () list2 [arg] | all isDigit arg = do session <- getSession (toplevel, _) <- io $ GHC.getContext session @@ -1866,6 +2068,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. +listAround :: SrcSpan -> Bool -> IO () listAround span do_highlight = do contents <- BS.readFile (unpackFS file) let @@ -1876,12 +2079,12 @@ listAround span do_highlight = do line_nos = [ fst_line .. ] highlighted | do_highlight = zipWith highlight line_nos these_lines - | otherwise = these_lines + | otherwise = [\p -> BS.concat[p,l] | l <- these_lines] bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ] - prefixed = zipWith BS.append bs_line_nos highlighted + prefixed = zipWith ($) highlighted bs_line_nos -- - BS.putStrLn (BS.join (BS.pack "\n") prefixed) + BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed) where file = GHC.srcSpanFile span line1 = GHC.srcSpanStartLine span @@ -1896,32 +2099,33 @@ listAround span do_highlight = do highlight | do_bold = highlight_bold | otherwise = highlight_carets - highlight_bold no line + highlight_bold no line prefix | no == line1 && no == line2 = let (a,r) = BS.splitAt col1 line (b,c) = BS.splitAt (col2-col1) r in - BS.concat [a,start_bold,b,end_bold,c] + BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c] | no == line1 = let (a,b) = BS.splitAt col1 line in - BS.concat [a, start_bold, b] + BS.concat [prefix, a, BS.pack start_bold, b] | no == line2 = let (a,b) = BS.splitAt col2 line in - BS.concat [a, end_bold, b] - | otherwise = line + BS.concat [prefix, a, BS.pack end_bold, b] + | otherwise = BS.concat [prefix, line] - highlight_carets no line + highlight_carets no line prefix | no == line1 && no == line2 - = BS.concat [line, nl, indent, BS.replicate col1 ' ', + = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ', BS.replicate (col2-col1) '^'] | no == line1 - = BS.concat [line, nl, indent, BS.replicate col1 ' ', - BS.replicate (BS.length line-col1) '^'] + = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl, + prefix, line] | no == line2 - = BS.concat [line, nl, indent, BS.replicate col2 '^'] - | otherwise = line + = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ', + BS.pack "^^"] + | otherwise = BS.concat [prefix, line] where - indent = BS.pack " " + indent = BS.pack (" " ++ replicate (length (show no)) ' ') nl = BS.singleton '\n' -- -------------------------------------------------------------------------- @@ -1934,7 +2138,7 @@ getTickArray modl = do case lookupModuleEnv arrmap modl of Just arr -> return arr Nothing -> do - (breakArray, ticks) <- getModBreak modl + (_breakArray, ticks) <- getModBreak modl let arr = mkTickArray (assocs ticks) setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr} return arr @@ -1978,6 +2182,7 @@ deleteBreak identity = do 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)