X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=b1baecd69a32b5a1d28f2829d5e389ccd70b30b5;hp=42424e62398288f80939433e973ede4d1f985255;hb=66579ff945831c5fc9a17c58c722ff01f2268d76;hpb=bd50bd07d54631d802598b6fb9a6f468afa823cf diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 42424e6..b1baecd 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -1,3 +1,6 @@ +{-# OPTIONS -fno-cse #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly + {-# OPTIONS -#include "Linker.h" #-} ----------------------------------------------------------------------------- -- @@ -6,38 +9,41 @@ -- (c) The GHC Team 2005-2006 -- ----------------------------------------------------------------------------- -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where #include "HsVersions.h" -import GhciMonad +import qualified GhciMonad +import GhciMonad hiding (runStmt) import GhciTags import Debugger -- The GHC interface -import qualified GHC -import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..), - Type, Module, ModuleName, TyThing(..), Phase, - BreakIndex, SrcSpan, Resume, SingleStep ) +import qualified GHC hiding (resume, runStmt) +import GHC ( LoadHowMuch(..), Target(..), TargetId(..), + Module, ModuleName, TyThing(..), Phase, + BreakIndex, SrcSpan, Resume, SingleStep, + Ghc, handleSourceError ) +import PprTyThing import DynFlags + import Packages +#ifdef USE_EDITLINE import PackageConfig import UniqFM -import HscTypes ( implicitTyThings ) -import PprTyThing -import Outputable hiding (printForUser) +#endif + +import HscTypes ( implicitTyThings, reflectGhc, reifyGhc ) +import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC? +import Outputable hiding (printForUser, printForUserPartWay) import Module -- for ModuleEnv import Name import SrcLoc -- Other random utilities +import ErrUtils +import CmdLineParser import Digraph import BasicTypes hiding (isTopLevel) import Panic hiding (showException) @@ -48,25 +54,27 @@ import Util import NameSet import Maybes ( orElse ) import FastString +import Encoding +import MonadUtils ( liftIO ) #ifndef mingw32_HOST_OS import System.Posix hiding (getEnv) #else import GHC.ConsoleHandler ( flushConsole ) -import System.Win32 ( setConsoleCP, setConsoleOutputCP ) import qualified System.Win32 #endif -#ifdef USE_READLINE +#ifdef USE_EDITLINE import Control.Concurrent ( yield ) -- Used in readline loop -import System.Console.Readline as Readline +import System.Console.Editline.Readline as Readline #endif --import SystemExts -import Control.Exception as Exception +import Exception -- import Control.Concurrent +import System.FilePath import qualified Data.ByteString.Char8 as BS import Data.List import Data.Maybe @@ -76,20 +84,22 @@ import System.Exit ( exitWith, ExitCode(..) ) import System.Directory import System.IO import System.IO.Error as IO -import System.IO.Unsafe import Data.Char import Data.Dynamic import Data.Array import Control.Monad as Monad import Text.Printf - -import Foreign.StablePtr ( newStablePtr ) +import Foreign +import Foreign.C import GHC.Exts ( unsafeCoerce# ) import GHC.IOBase ( IOErrorType(InvalidArgument) ) +import GHC.TopHandler import Data.IORef ( IORef, readIORef, writeIORef ) +#ifdef USE_EDITLINE import System.Posix.Internals ( setNonBlockingFD ) +#endif ----------------------------------------------------------------------------- @@ -97,69 +107,103 @@ ghciWelcomeMsg :: String 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]) +GLOBAL_VAR(macros_ref, [], [Command]) builtin_commands :: [Command] builtin_commands = [ -- Hugs users are accustomed to :e, so make sure it doesn't overlap - ("?", keepGoing help, False, completeNone), - ("add", keepGoingPaths addModule, False, completeFilename), - ("abandon", keepGoing abandonCmd, False, completeNone), - ("break", keepGoing breakCmd, False, completeIdentifier), - ("back", keepGoing backCmd, False, completeNone), - ("browse", keepGoing browseCmd, 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), - ("delete", keepGoing deleteCmd, False, completeNone), - ("e", keepGoing editFile, False, completeFilename), - ("edit", keepGoing editFile, False, completeFilename), - ("etags", keepGoing createETagsFileCmd, False, completeFilename), - ("force", keepGoing forceCmd, False, completeIdentifier), - ("forward", keepGoing forwardCmd, False, completeNone), - ("help", keepGoing help, False, completeNone), - ("history", keepGoing historyCmd, False, completeNone), - ("info", keepGoing info, False, completeIdentifier), - ("kind", keepGoing kindOfType, False, completeIdentifier), - ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile), - ("list", keepGoing listCmd, False, completeNone), - ("module", keepGoing setContext, False, completeModule), - ("main", keepGoing runMain, False, completeIdentifier), - ("print", keepGoing printCmd, False, completeIdentifier), - ("quit", quit, False, completeNone), - ("reload", keepGoing reloadModule, False, completeNone), - ("set", keepGoing setCmd, True, completeSetOptions), - ("show", keepGoing showCmd, False, completeNone), - ("sprint", keepGoing sprintCmd, False, completeIdentifier), - ("step", keepGoing stepCmd, 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), - ("unset", keepGoing unsetOptions, True, completeSetOptions) + ("?", keepGoing help, Nothing, completeNone), + ("add", keepGoingPaths addModule, Just filenameWordBreakChars, completeFilename), + ("abandon", keepGoing abandonCmd, Nothing, completeNone), + ("break", keepGoing breakCmd, Nothing, completeIdentifier), + ("back", keepGoing backCmd, Nothing, completeNone), + ("browse", keepGoing (browseCmd False), Nothing, completeModule), + ("browse!", keepGoing (browseCmd True), Nothing, completeModule), + ("cd", keepGoing changeDirectory, Just filenameWordBreakChars, completeFilename), + ("check", keepGoing checkModule, Nothing, completeHomeModule), + ("continue", keepGoing continueCmd, Nothing, completeNone), + ("cmd", keepGoing cmdCmd, Nothing, completeIdentifier), + ("ctags", keepGoing createCTagsFileCmd, Just filenameWordBreakChars, completeFilename), + ("def", keepGoing (defineMacro False), Nothing, completeIdentifier), + ("def!", keepGoing (defineMacro True), Nothing, completeIdentifier), + ("delete", keepGoing deleteCmd, Nothing, completeNone), + ("e", keepGoing editFile, Just filenameWordBreakChars, completeFilename), + ("edit", keepGoing editFile, Just filenameWordBreakChars, completeFilename), + ("etags", keepGoing createETagsFileCmd, Just filenameWordBreakChars, completeFilename), + ("force", keepGoing forceCmd, Nothing, completeIdentifier), + ("forward", keepGoing forwardCmd, Nothing, completeNone), + ("help", keepGoing help, Nothing, completeNone), + ("history", keepGoing historyCmd, Nothing, completeNone), + ("info", keepGoing info, Nothing, completeIdentifier), + ("kind", keepGoing kindOfType, Nothing, completeIdentifier), + ("load", keepGoingPaths loadModule_, Just filenameWordBreakChars, completeHomeModuleOrFile), + ("list", keepGoing listCmd, Nothing, completeNone), + ("module", keepGoing setContext, Nothing, completeModule), + ("main", keepGoing runMain, Nothing, completeIdentifier), + ("print", keepGoing printCmd, Nothing, completeIdentifier), + ("quit", quit, Nothing, completeNone), + ("reload", keepGoing reloadModule, Nothing, completeNone), + ("run", keepGoing runRun, Nothing, completeIdentifier), + ("set", keepGoing setCmd, Just flagWordBreakChars, completeSetOptions), + ("show", keepGoing showCmd, Nothing, completeNone), + ("sprint", keepGoing sprintCmd, Nothing, completeIdentifier), + ("step", keepGoing stepCmd, Nothing, completeIdentifier), + ("steplocal", keepGoing stepLocalCmd, Nothing, completeIdentifier), + ("stepmodule",keepGoing stepModuleCmd, Nothing, completeIdentifier), + ("type", keepGoing typeOfExpr, Nothing, completeIdentifier), + ("trace", keepGoing traceCmd, Nothing, completeIdentifier), + ("undef", keepGoing undefineMacro, Nothing, completeMacro), + ("unset", keepGoing unsetOptions, Just flagWordBreakChars, completeSetOptions) ] + +-- We initialize readline (in the interactiveUI function) to use +-- word_break_chars as the default set of completion word break characters. +-- This can be overridden for a particular command (for example, filename +-- expansion shouldn't consider '/' to be a word break) by setting the third +-- entry in the Command tuple above. +-- +-- NOTE: in order for us to override the default correctly, any custom entry +-- must be a SUBSET of word_break_chars. +#ifdef USE_EDITLINE +word_break_chars :: String +word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~" + specials = "(),;[]`{}" + spaces = " \t\n" + in spaces ++ specials ++ symbols +#endif + +flagWordBreakChars, filenameWordBreakChars :: String +flagWordBreakChars = " \t\n" +filenameWordBreakChars = " \t\n\\`@$><=;|&{(" -- bash defaults + + keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool) keepGoing a str = a str >> return False keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool) -keepGoingPaths a str = a (toArgs str) >> return False +keepGoingPaths a str + = do case toArgs str of + Left err -> io (hPutStrLn stderr err) + Right args -> a args + return False +shortHelpText :: String shortHelpText = "use :? for help.\n" +helpText :: String helpText = " Commands available from the prompt:\n" ++ "\n" ++ " evaluate/run \n" ++ - " :add ... add module(s) to the current target set\n" ++ - " :browse [*] display the names defined by \n" ++ + " : repeat last command\n" ++ + " :{\\n ..lines.. \\n:}\\n multiline command\n" ++ + " :add [*] ... add module(s) to the current target set\n" ++ + " :browse[!] [[*]] display the names defined by module \n" ++ + " (!: more details; *: all top-level names)\n" ++ " :cd change directory to \n" ++ " :cmd run the commands returned by ::IO String\n" ++ " :ctags [] create tags file for Vi (default: \"tags\")\n" ++ @@ -170,11 +214,12 @@ helpText = " :help, :? display this list of commands\n" ++ " :info [ ...] display information about the given names\n" ++ " :kind show the kind of \n" ++ - " :load ... load module(s) and their dependents\n" ++ + " :load [*] ... load module(s) and their dependents\n" ++ " :main [ ...] run the main function with the given arguments\n" ++ " :module [+/-] [*] ... set the context for expression evaluation\n" ++ " :quit exit GHCi\n" ++ " :reload reload the current module set\n" ++ + " :run function [ ...] run the function with the given arguments\n" ++ " :type show the type of \n" ++ " :undef undefine user-defined command :\n" ++ " :! run the shell command \n" ++ @@ -190,15 +235,18 @@ helpText = " :delete * delete all breakpoints\n" ++ " :force print , forcing unevaluated parts\n" ++ " :forward go forward in the history (after :back)\n" ++ - " :history [] show the last items in the history (after :trace)\n" ++ + " :history [] after :trace, show the execution history\n" ++ + " :list show the source code around current breakpoint\n" ++ + " :list identifier show the source code for \n" ++ + " :list [] show the source code around line number \n" ++ " :print [ ...] prints a value without forcing its computation\n" ++ " :sprint [ ...] simplifed version of :print\n" ++ " :step single-step after stopping at a breakpoint\n"++ " :step single-step into \n"++ - " :steplocal single-step restricted to the current top level decl.\n"++ + " :steplocal single-step within the current top-level binding\n"++ " :stepmodule single-step restricted to the current module\n"++ " :trace trace after stopping at a breakpoint\n"++ - " :trace trace into (remembers breakpoints for :history)\n"++ + " :trace evaluate with tracing on (see :history)\n"++ "\n" ++ " -- Commands for changing settings:\n" ++ @@ -218,6 +266,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" ++ @@ -225,21 +275,26 @@ helpText = " :show breaks show the active breakpoints\n" ++ " :show context show the breakpoint context\n" ++ " :show modules show the currently loaded modules\n" ++ - " :show show anything that can be set with :set (e.g. args)\n" ++ + " :show packages show the currently active package flags\n" ++ + " :show languages show the currently active language flags\n" ++ + " :show show value of , which is one of\n" ++ + " [args, prog, prompt, editor, stop]\n" ++ "\n" +findEditor :: IO String findEditor = do getEnv "EDITOR" `IO.catch` \_ -> do #if mingw32_HOST_OS - win <- System.Win32.getWindowsDirectory - return (win `joinFileName` "notepad.exe") + win <- System.Win32.getWindowsDirectory + return (win "notepad.exe") #else - return "" + return "" #endif -interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO () -interactiveUI session srcs maybe_expr = do +interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String] + -> Ghc () +interactiveUI srcs maybe_exprs = do -- HACK! If we happen to get into an infinite loop (eg the user -- types 'let x=x in x' at the prompt), then the thread will block -- on a blackhole, and become unreachable during GC. The GC will @@ -248,14 +303,14 @@ interactiveUI session srcs maybe_expr = do -- it refers to might be finalized, including the standard Handles. -- This sounds like a bug, but we don't have a good solution right -- now. - newStablePtr stdin - newStablePtr stdout - newStablePtr stderr + liftIO $ newStablePtr stdin + liftIO $ newStablePtr stdout + liftIO $ newStablePtr stderr -- Initialise buffering for the *interpreted* I/O system - initInterpBuffering session + initInterpBuffering - when (isNothing maybe_expr) $ do + liftIO $ when (isNothing maybe_exprs) $ do -- Only for GHCi (not runghc and ghc -e): -- Turn buffering off for the compiled program's stdout/stderr @@ -267,90 +322,114 @@ interactiveUI session srcs maybe_expr = do -- intended for the program, so unbuffer stdin. hSetBuffering stdin NoBuffering - -- initial context is just the Prelude - prel_mod <- GHC.findModule session prel_name (Just basePackageId) - GHC.setContext session [] [prel_mod] - -#ifdef USE_READLINE - Readline.initialize - Readline.setAttemptedCompletionFunction (Just completeWord) - --Readline.parseAndBind "set show-all-if-ambiguous 1" +#ifdef USE_EDITLINE + is_tty <- hIsTerminalDevice stdin + when is_tty $ withReadline $ do + Readline.initialize + + withGhcAppData + (\dir -> Readline.readHistory (dir "ghci_history")) + (return True) + + Readline.setAttemptedCompletionFunction (Just completeWord) + --Readline.parseAndBind "set show-all-if-ambiguous 1" + + Readline.setBasicWordBreakCharacters word_break_chars + Readline.setCompleterWordBreakCharacters word_break_chars + Readline.setCompletionAppendCharacter Nothing +#endif - let symbols = "!#$%&*+/<=>?@\\^|-~" - specials = "(),;[]`{}" - spaces = " \t\n" - word_break_chars = spaces ++ specials ++ symbols + -- initial context is just the Prelude + prel_mod <- GHC.findModule (GHC.mkModuleName "Prelude") Nothing + GHC.setContext [] [prel_mod] - Readline.setBasicWordBreakCharacters word_break_chars - Readline.setCompleterWordBreakCharacters word_break_chars -#endif + default_editor <- liftIO $ findEditor - default_editor <- findEditor + cwd <- liftIO $ getCurrentDirectory - startGHCi (runGHCi srcs maybe_expr) - GHCiState{ progname = "", - args = [], + startGHCi (runGHCi srcs maybe_exprs) + GHCiState{ progname = "", + args = [], prompt = "%s> ", stop = "", - editor = default_editor, - session = session, - options = [], + editor = default_editor, +-- session = session, + options = [], prelude = prel_mod, break_ctr = 0, breaks = [], tickarrays = emptyModuleEnv, - cmdqueue = [] + last_command = Nothing, + cmdqueue = [], + remembered_ctx = [], + virtual_path = cwd, + ghc_e = isJust maybe_exprs } -#ifdef USE_READLINE - Readline.resetTerminal Nothing +#ifdef USE_EDITLINE + liftIO $ do + Readline.stifleHistory 100 + withGhcAppData (\dir -> Readline.writeHistory (dir "ghci_history")) + (return True) + Readline.resetTerminal Nothing #endif return () -prel_name = GHC.mkModuleName "Prelude" +withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a +withGhcAppData right left = do + either_dir <- IO.try (getAppUserDataDirectory "ghc") + case either_dir of + Right dir -> right dir + _ -> left -runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi () -runGHCi paths maybe_expr = do - let read_dot_files = not opt_IgnoreDotGhci - when (read_dot_files) $ do - -- Read in ./.ghci. - let file = "./.ghci" - exists <- io (doesFileExist file) - when exists $ do - dir_ok <- io (checkPerms ".") - file_ok <- io (checkPerms file) +runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi () +runGHCi paths maybe_exprs = do + let + read_dot_files = not opt_IgnoreDotGhci + + current_dir = return (Just ".ghci") + + app_user_dir = io $ withGhcAppData + (\dir -> return (Just (dir "ghci.conf"))) + (return Nothing) + + home_dir = do + either_dir <- io $ IO.try (getEnv "HOME") + case either_dir of + Right home -> return (Just (home ".ghci")) + _ -> return Nothing + + sourceConfigFile :: FilePath -> GHCi () + sourceConfigFile file = do + exists <- io $ doesFileExist file + when exists $ do + dir_ok <- io $ checkPerms (getDirectory file) + file_ok <- io $ checkPerms file when (dir_ok && file_ok) $ do - either_hdl <- io (IO.try (openFile "./.ghci" ReadMode)) - case either_hdl of - Left e -> return () - Right hdl -> fileLoop hdl False - + either_hdl <- io $ IO.try (openFile file ReadMode) + case either_hdl of + Left _e -> return () + Right hdl -> runCommands (fileLoop hdl False False) + where + getDirectory f = case takeDirectory f of "" -> "."; d -> d + when (read_dot_files) $ do - -- Read in $HOME/.ghci - either_dir <- io (IO.try (getEnv "HOME")) - case either_dir of - Left e -> return () - Right dir -> do - cwd <- io (getCurrentDirectory) - when (dir /= cwd) $ do - let file = dir ++ "/.ghci" - ok <- io (checkPerms file) - when ok $ do - either_hdl <- io (IO.try (openFile file ReadMode)) - case either_hdl of - Left e -> return () - Right hdl -> fileLoop hdl False + cfgs0 <- sequence [ current_dir, app_user_dir, home_dir ] + cfgs <- io $ mapM canonicalizePath (catMaybes cfgs0) + mapM_ sourceConfigFile (nub cfgs) + -- nub, because we don't want to read .ghci twice if the + -- CWD is $HOME. -- Perform a :load for files given on the GHCi command line -- When in -e mode, if the load fails then we want to stop -- immediately rather than going on to evaluate the expression. when (not (null paths)) $ do - ok <- ghciHandle (\e -> do showException e; return Failed) $ - loadModule paths - when (isJust maybe_expr && failed ok) $ - io (exitWith (ExitFailure 1)) + ok <- ghciHandle (\e -> do showException e; return Failed) $ + loadModule paths + when (isJust maybe_exprs && failed ok) $ + io (exitWith (ExitFailure 1)) -- if verbosity is greater than 0, or we are connected to a -- terminal, display the prompt in the interactive loop. @@ -358,7 +437,7 @@ runGHCi paths maybe_expr = do dflags <- getDynFlags let show_prompt = verbosity dflags > 0 || is_tty - case maybe_expr of + case maybe_exprs of Nothing -> do #if defined(mingw32_HOST_OS) @@ -372,23 +451,27 @@ 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 + Just exprs -> do -- just evaluate the expression we were given - runCommandEval expr - return () + enqueueCommands exprs + let handle e = do st <- getGHCiState + -- Jump through some hoops to get the + -- current progname in the exception text: + -- : + io $ withProgName (progname st) + -- this used to be topHandlerFastExit, see #2228 + $ topHandler e + runCommands' handle (return Nothing) -- and finally, exit 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 + ghciHandleGhcException (\e -> case e of Interrupted -> do #if defined(mingw32_HOST_OS) io (putStrLn "") @@ -400,12 +483,12 @@ interactiveLoop is_tty show_prompt = -- exception handler above. -- read commands from stdin -#ifdef USE_READLINE +#ifdef USE_EDITLINE 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 @@ -419,11 +502,12 @@ 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 - Util.handle (\_ -> return False) $ do +checkPerms name = + handleIO (\_ -> return False) $ do st <- getFileStatus name me <- getRealUserID if fileOwner st /= me then do @@ -440,50 +524,79 @@ 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) - resumes <- io $ GHC.getResumeContext session + (toplevs,exports) <- GHC.getContext + resumes <- GHC.getResumeContext + -- st <- getGHCiState 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) else do let hist = GHC.resumeHistory r !! (ix-1) - span <- io$ GHC.getHistorySpan session hist + span <- GHC.getHistorySpan hist return (brackets (ppr (negate ix) <> char ':' <+> ppr span) <> space) let - dots | r:rs <- resumes, not (null rs) = text "... " + dots | _:rs <- resumes, not (null rs) = text "... " | otherwise = empty + + modules_bit = - hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+> + -- 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) deflt_prompt = dots <> context_bit <> modules_bit @@ -497,46 +610,97 @@ mkPrompt = do return (showSDoc (f (prompt st))) -#ifdef USE_READLINE -readlineLoop :: GHCi () +#ifdef USE_EDITLINE +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 + l <- io $ withReadline (readline prompt) 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 "" -> return (Just "") -- Don't put empty lines in the history + Just l -> do + io (addHistory l) + str <- io $ consoleInputToUnicode True l + return (Just str) + +withReadline :: IO a -> IO a +withReadline = bracket_ stopTimer (do startTimer; setNonBlockingFD 0) + -- Two problems are being worked around here: + -- 1. readline sometimes puts stdin into blocking mode, + -- so we need to put it back for the IO library + -- 2. editline doesn't handle some of its system calls returning + -- EINTR, so our timer signal confuses it, hence we turn off + -- the timer signal when making calls to editline. (#2277) + -- If editline is ever fixed, we can remove this. + +-- These come from the RTS +foreign import ccall unsafe startTimer :: IO () +foreign import ccall unsafe stopTimer :: IO () #endif -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 = runCommands' handler + +runCommands' :: (SomeException -> GHCi Bool) -- Exception handler + -> GHCi (Maybe String) -> GHCi () +runCommands' eh 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 eh $ + handleSourceError printErrorAndKeepGoing + (doCommand c) + if b then return () else runCommands' eh 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 + printErrorAndKeepGoing err = do + GHC.printExceptionAndWarnings err + return True + + 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 @@ -544,150 +708,142 @@ enqueueCommands cmds = do setGHCiState st{ cmdqueue = cmds ++ cmdqueue st } --- 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 c = ghciHandle handleEval (doCommand c) - where - handleEval (ExitException code) = io (exitWith code) - handleEval e = do handler e - io (exitWith (ExitFailure 1)) - - doCommand (':' : command) = specialCommand command - doCommand stmt - = do r <- runStmt stmt GHC.RunToCompletion - case r of - False -> io (exitWith (ExitFailure 1)) - -- failure to run the command causes exit(1) for ghc -e. - _ -> return True - runStmt :: String -> SingleStep -> GHCi Bool runStmt stmt step | null (filter (not.isSpace) stmt) = return False | ["import", mod] <- words stmt = keepGoing setContext ('+':mod) | otherwise - = do st <- getGHCiState - session <- getSession - result <- io $ withProgName (progname st) $ withArgs (args st) $ - GHC.runStmt session stmt step + = do result <- GhciMonad.runStmt stmt step afterRunStmt (const True) result - --afterRunStmt :: GHC.RunResult -> GHCi Bool -- False <=> the statement failed to compile +afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool afterRunStmt _ (GHC.RunException e) = throw e afterRunStmt step_here run_result = do - session <- getSession - resumes <- io $ GHC.getResumeContext session + resumes <- GHC.getResumeContext case run_result of GHC.RunOk names -> do show_types <- isOptionSet ShowType - when show_types $ printTypeOfNames session names + when show_types $ printTypeOfNames names GHC.RunBreak _ names mb_info | isNothing mb_info || step_here (GHC.resumeSpan $ head resumes) -> do - printForUser $ ptext SLIT("Stopped at") <+> + printForUser $ ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan $ head resumes) -- printTypeOfNames session names - printTypeAndContentOfNames session names + let namesSorted = sortBy compareNames names + tythings <- catMaybes `liftM` + mapM GHC.lookupName namesSorted + docs <- pprTypeAndContents [id | AnId id <- tythings] + printForUserPartWay docs maybe (return ()) runBreakCmd mb_info -- run the command set with ":set stop " st <- getGHCiState enqueueCommands [stop st] return () - | otherwise -> io(GHC.resume session GHC.SingleStep) >>= + | otherwise -> resume GHC.SingleStep >>= afterRunStmt step_here >> return () _ -> return () flushInterpBuffers io installSignalHandlers b <- isOptionSet RevertCAFs - io (when b revertCAFs) + when b revertCAFs return (case run_result of GHC.RunOk _ -> True; _ -> False) - where printTypeAndContentOfNames session names = do - let namesSorted = sortBy compareNames names - tythings <- catMaybes `liftM` - io (mapM (GHC.lookupName session) namesSorted) - docs_ty <- mapM showTyThing tythings - terms <- mapM (io . GHC.obtainTermB session 10 False) - [ id | (AnId id, Just _) <- zip tythings docs_ty] - docs_terms <- mapM (io . showTerm session) terms - printForUser $ vcat $ zipWith (\ty cts -> ty <> text " = " <> cts) - (catMaybes docs_ty) - docs_terms - runBreakCmd :: GHC.BreakInfo -> GHCi () 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 () | otherwise -> do enqueueCommands [cmd]; return () where cmd = onBreakCmd loc -printTypeOfNames :: Session -> [Name] -> GHCi () -printTypeOfNames session names - = mapM_ (printTypeOfName session) $ sortBy compareNames names +printTypeOfNames :: [Name] -> GHCi () +printTypeOfNames names + = mapM_ (printTypeOfName ) $ sortBy compareNames names compareNames :: Name -> Name -> Ordering n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2 where compareWith n = (getOccString n, getSrcSpan n) -printTypeOfName :: Session -> Name -> GHCi () -printTypeOfName session n - = do maybe_tything <- io (GHC.lookupName session n) +printTypeOfName :: Name -> GHCi () +printTypeOfName n + = do maybe_tything <- GHC.lookupName n case maybe_tything of Nothing -> return () Just thing -> printTyThing thing + +data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand + specialCommand :: String -> GHCi Bool specialCommand ('!':str) = shellEscape (dropWhile isSpace str) specialCommand str = do let (cmd,rest) = break isSpace str - maybe_cmd <- io (lookupCommand cmd) + maybe_cmd <- lookupCommand cmd case maybe_cmd of - Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n" - ++ shortHelpText) >> return False) - Just (_,f,_,_) -> f (dropWhile isSpace rest) - -lookupCommand :: String -> IO (Maybe Command) + GotCommand (_,f,_,_) -> f (dropWhile isSpace rest) + BadCommand -> + do io $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n" + ++ shortHelpText) + return False + NoLastCommand -> + do io $ hPutStr stdout ("there is no last command to perform\n" + ++ shortHelpText) + return False + +lookupCommand :: String -> GHCi (MaybeCommand) +lookupCommand "" = do + st <- getGHCiState + case last_command st of + Just c -> return $ GotCommand c + Nothing -> return NoLastCommand lookupCommand str = do - cmds <- readIORef commands + mc <- io $ lookupCommand' str + st <- getGHCiState + setGHCiState st{ last_command = mc } + return $ case mc of + Just c -> GotCommand c + Nothing -> BadCommand + +lookupCommand' :: String -> IO (Maybe Command) +lookupCommand' str = do + 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) - [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of - [] -> return Nothing - c:_ -> return (Just c) - + return $ case [ c | c <- cmds, str == cmdName c ] of + c:_ -> Just c + [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of + [] -> Nothing + c:_ -> Just c getCurrentBreakSpan :: GHCi (Maybe SrcSpan) getCurrentBreakSpan = do - session <- getSession - resumes <- io $ GHC.getResumeContext session + resumes <- GHC.getResumeContext case resumes of [] -> return Nothing - (r:rs) -> do + (r:_) -> do let ix = GHC.resumeHistoryIx r if ix == 0 then return (Just (GHC.resumeSpan r)) else do let hist = GHC.resumeHistory r !! (ix-1) - span <- io $ GHC.getHistorySpan session hist + span <- GHC.getHistorySpan hist return (Just span) getCurrentBreakModule :: GHCi (Maybe Module) getCurrentBreakModule = do - session <- getSession - resumes <- io $ GHC.getResumeContext session + resumes <- GHC.getResumeContext case resumes of [] -> return Nothing - (r:rs) -> do + (r:_) -> do let ix = GHC.resumeHistoryIx r if ix == 0 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r) @@ -700,27 +856,28 @@ 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) info :: String -> GHCi () -info "" = throwDyn (CmdLineError "syntax: ':i '") -info s = do { let names = words s - ; session <- getSession +info "" = ghcError (CmdLineError "syntax: ':i '") +info s = handleSourceError GHC.printExceptionAndWarnings $ do + { let names = words s ; dflags <- getDynFlags ; let pefas = dopt Opt_PrintExplicitForalls dflags - ; mapM_ (infoThing pefas session) names } + ; mapM_ (infoThing pefas) names } where - infoThing pefas session str = io $ do - names <- GHC.parseName session str - mb_stuffs <- mapM (GHC.getInfo session) names - let filtered = filterOutChildren (\(t,f,i) -> t) (catMaybes mb_stuffs) - unqual <- GHC.getPrintUnqual session - putStrLn (showSDocForUser unqual $ - vcat (intersperse (text "") $ - map (pprInfo pefas) filtered)) + infoThing pefas str = do + names <- GHC.parseName str + mb_stuffs <- mapM GHC.getInfo names + let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) + unqual <- GHC.getPrintUnqual + liftIO $ + putStrLn (showSDocForUser unqual $ + vcat (intersperse (text "") $ + map (pprInfo pefas) filtered)) -- Filter out names whose parent is also there Good -- example is '[]', which is both a type and data @@ -742,40 +899,67 @@ pprInfo pefas (thing, fixity, insts) | otherwise = ppr fix <+> ppr (GHC.getName thing) runMain :: String -> GHCi () -runMain args = do - let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args)) - enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"] +runMain s = case toArgs s of + Left err -> io (hPutStrLn stderr err) + Right args -> + do dflags <- getDynFlags + case mainFunIs dflags of + Nothing -> doWithArgs args "main" + Just f -> doWithArgs args f + +runRun :: String -> GHCi () +runRun s = case toCmdArgs s of + Left err -> io (hPutStrLn stderr err) + Right (cmd, args) -> doWithArgs args cmd + +doWithArgs :: [String] -> String -> GHCi () +doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++ + show args ++ " (" ++ cmd ++ ")"] addModule :: [FilePath] -> GHCi () addModule files = do - io (revertCAFs) -- always revert CAFs on load/add. + revertCAFs -- always revert CAFs on load/add. files <- mapM expandPath files - targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files - session <- getSession - io (mapM_ (GHC.addTarget session) targets) - ok <- io (GHC.load session LoadAllTargets) - afterLoad ok session + targets <- mapM (\m -> GHC.guessTarget m Nothing) files + -- remove old targets with the same id; e.g. for :add *M + mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ] + mapM_ GHC.addTarget targets + prev_context <- GHC.getContext + ok <- trySuccess $ GHC.load LoadAllTargets + afterLoad ok False prev_context changeDirectory :: String -> GHCi () +changeDirectory "" = do + -- :cd on its own changes to the user's home directory + either_dir <- io (IO.try getHomeDirectory) + case either_dir of + Left _e -> return () + Right dir -> changeDirectory dir changeDirectory dir = do - session <- getSession - graph <- io (GHC.getModuleGraph session) + graph <- GHC.getModuleGraph when (not (null graph)) $ io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n" - io (GHC.setTargets session []) - io (GHC.load session LoadAllTargets) - setContextAfterLoad session [] - io (GHC.workingDirectoryChanged session) + prev_context <- GHC.getContext + GHC.setTargets [] + GHC.load LoadAllTargets + setContextAfterLoad prev_context False [] + GHC.workingDirectoryChanged dir <- expandPath dir io (setCurrentDirectory dir) +trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag +trySuccess act = + handleSourceError (\e -> do GHC.printExceptionAndWarnings e + return Failed) $ do + act + editFile :: String -> GHCi () editFile str = do file <- if null str then chooseEditFile else return str st <- getGHCiState let cmd = editor st when (null cmd) - $ throwDyn (CmdLineError "editor not set, use :set editor") + $ ghcError (CmdLineError "editor not set, use :set editor") io $ system (cmd ++ ' ':file) return () @@ -791,10 +975,9 @@ editFile str = -- of those. chooseEditFile :: GHCi String chooseEditFile = - do session <- getSession - let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x + do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x - graph <- io (GHC.getModuleGraph session) + graph <- GHC.getModuleGraph failed_graph <- filterM hasFailed graph let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing pick xs = case xs of @@ -804,37 +987,41 @@ chooseEditFile = case pick (order failed_graph) of Just file -> return file Nothing -> - do targets <- io (GHC.getTargets session) + do targets <- GHC.getTargets case msum (map fromTarget targets) of Just file -> return file - Nothing -> throwDyn (CmdLineError "No files to edit.") + Nothing -> ghcError (CmdLineError "No files to edit.") - where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f + where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f fromTarget _ = Nothing -- when would we get a module target? -defineMacro :: 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) - then throwDyn (CmdLineError - ("command '" ++ macro_name ++ "' is already defined")) + if (not overwrite && macro_name `elem` defined) + then ghcError (CmdLineError + ("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" -- compile the expression - cms <- getSession - 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)])) + handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do + hv <- GHC.compileExpr new_expr + io (writeIORef macros_ref -- + (filtered ++ [(macro_name, runMacro hv, Nothing, completeNone)])) runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool runMacro fun s = do @@ -843,29 +1030,23 @@ 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 ghcError (CmdLineError + ("macro '" ++ macro_name ++ "' is not defined")) + else do + io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds)) cmdCmd :: String -> GHCi () cmdCmd str = do let expr = '(' : str ++ ") :: IO String" - session <- getSession - maybe_hv <- io (GHC.compileExpr session expr) - case maybe_hv of - Nothing -> return () - Just hv -> do - cmds <- io $ (unsafeCoerce# hv :: IO String) - enqueueCommands (lines cmds) - return () + handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do + hv <- GHC.compileExpr expr + cmds <- io $ (unsafeCoerce# hv :: IO String) + enqueueCommands (lines cmds) + return () loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag loadModule fs = timeIt (loadModule' fs) @@ -875,74 +1056,83 @@ loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return () loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag loadModule' files = do - session <- getSession + prev_context <- GHC.getContext -- unload first + GHC.abandonAll discardActiveBreakPoints - io (GHC.setTargets session []) - io (GHC.load session LoadAllTargets) + GHC.setTargets [] + GHC.load LoadAllTargets -- expand tildes let (filenames, phases) = unzip files exp_filenames <- mapM expandPath filenames let files' = zip exp_filenames phases - targets <- io (mapM (uncurry GHC.guessTarget) files') + targets <- mapM (uncurry GHC.guessTarget) files' -- NOTE: we used to do the dependency anal first, so that if it -- fails we didn't throw away the current set of modules. This would -- require some re-working of the GHC interface, so we'll leave it -- as a ToDo for now. - io (GHC.setTargets session targets) - doLoad session LoadAllTargets + GHC.setTargets targets + doLoad False prev_context LoadAllTargets checkModule :: String -> GHCi () checkModule m = do let modl = GHC.mkModuleName m - session <- getSession - result <- io (GHC.checkModule session modl False) - case result of - Nothing -> io $ putStrLn "Nothing" - Just r -> io $ putStrLn (showSDoc ( - case GHC.checkedModuleInfo r of - Just cm | Just scope <- GHC.modInfoTopLevelScope cm -> + prev_context <- GHC.getContext + ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do + r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl + io $ putStrLn (showSDoc ( + case GHC.moduleInfo r of + cm | Just scope <- GHC.modInfoTopLevelScope cm -> let - (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope + (local,global) = ASSERT( all isExternalName scope ) + partition ((== modl) . GHC.moduleName . GHC.nameModule) scope in (text "global names: " <+> ppr global) $$ (text "local names: " <+> ppr local) - _ -> empty)) - afterLoad (successIf (isJust result)) session + _ -> empty)) + return True + afterLoad (successIf ok) False prev_context reloadModule :: String -> GHCi () reloadModule m = do - session <- getSession - doLoad session $ if null m then LoadAllTargets - else LoadUpTo (GHC.mkModuleName m) + prev_context <- GHC.getContext + doLoad True prev_context $ + if null m then LoadAllTargets + else LoadUpTo (GHC.mkModuleName m) return () -doLoad session howmuch = do +doLoad :: Bool -> ([Module],[Module]) -> LoadHowMuch -> GHCi SuccessFlag +doLoad retain_context prev_context howmuch = do -- turn off breakpoints before we load: we can't turn them off later, because -- the ModBreaks will have gone away. discardActiveBreakPoints - ok <- io (GHC.load session howmuch) - afterLoad ok session + ok <- trySuccess $ GHC.load howmuch + afterLoad ok retain_context prev_context return ok -afterLoad ok session = do - io (revertCAFs) -- always revert CAFs on load. +afterLoad :: SuccessFlag -> Bool -> ([Module],[Module]) -> GHCi () +afterLoad ok retain_context prev_context = do + revertCAFs -- always revert CAFs on load. discardTickArrays - 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_mod_summaries <- getLoadedModules + let loaded_mods = map GHC.ms_mod loaded_mod_summaries + loaded_mod_names = map GHC.moduleName loaded_mods + modulesLoadedMsg ok loaded_mod_names + + setContextAfterLoad prev_context retain_context loaded_mod_summaries -setContextAfterLoad session [] = do + +setContextAfterLoad :: ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi () +setContextAfterLoad prev keep_ctxt [] = do prel_mod <- getPrelude - io (GHC.setContext session [] [prel_mod]) -setContextAfterLoad session ms = do + setContextKeepingPackageModules prev keep_ctxt ([], [prel_mod]) +setContextAfterLoad prev keep_ctxt ms = do -- load a target if one is available, otherwise load the topmost module. - targets <- io (GHC.getTargets session) + targets <- GHC.getTargets case [ m | Just m <- map (findTarget ms) targets ] of [] -> let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in @@ -955,20 +1145,42 @@ setContextAfterLoad session ms = do [] -> Nothing (m:_) -> Just m - summary `matches` Target (TargetModule m) _ + summary `matches` Target (TargetModule m) _ _ = GHC.ms_mod_name summary == m - summary `matches` Target (TargetFile f _) _ + summary `matches` Target (TargetFile f _) _ _ | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f' - summary `matches` target + _ `matches` _ = False load_this summary | m <- GHC.ms_mod summary = do - b <- io (GHC.moduleIsInterpreted session m) - if b then io (GHC.setContext session [m] []) + b <- GHC.moduleIsInterpreted m + if b then setContextKeepingPackageModules prev keep_ctxt ([m], []) else do - prel_mod <- getPrelude - io (GHC.setContext session [] [prel_mod,m]) + prel_mod <- getPrelude + setContextKeepingPackageModules prev keep_ctxt ([],[prel_mod,m]) + +-- | Keep any package modules (except Prelude) when changing the context. +setContextKeepingPackageModules + :: ([Module],[Module]) -- previous context + -> Bool -- re-execute :module commands + -> ([Module],[Module]) -- 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)) + if keep_ctxt + then do + st <- getGHCiState + mapM_ (playCtxtCmd False) (remembered_ctx st) + else do + st <- getGHCiState + setGHCiState st{ remembered_ctx = [] } +isHomeModule :: Module -> Bool +isHomeModule mod = GHC.modulePackageId mod == mainPackageId modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi () modulesLoadedMsg ok mods = do @@ -987,20 +1199,18 @@ modulesLoadedMsg ok mods = do typeOfExpr :: String -> GHCi () typeOfExpr str - = do cms <- getSession - maybe_ty <- io (GHC.exprType cms str) - case maybe_ty of - Nothing -> return () - Just ty -> do ty' <- cleanType ty - printForUser $ text str <> text " :: " <> ppr ty' + = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do + ty <- GHC.exprType str + dflags <- getDynFlags + let pefas = dopt Opt_PrintExplicitForalls dflags + printForUser $ text str <+> dcolon + <+> pprTypeForUser pefas ty kindOfType :: String -> GHCi () kindOfType str - = do cms <- getSession - maybe_ty <- io (GHC.typeKind cms str) - case maybe_ty of - Nothing -> return () - Just ty -> printForUser $ text str <> text " :: " <> ppr ty + = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do + ty <- GHC.typeKind str + printForUser $ text str <+> dcolon <+> ppr ty quit :: String -> GHCi Bool quit _ = return True @@ -1011,110 +1221,174 @@ 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 - _ -> throwDyn (CmdLineError "syntax: :browse ") - -browseModule m exports_only = do - s <- getSession - modl <- if exports_only then lookupModule m - else wantInterpretedModule m - + ['*':s] | looksLikeModuleName s -> do + m <- wantInterpretedModule s + browseModule bang m False + [s] | looksLikeModuleName s -> do + m <- lookupModule s + browseModule bang m True + [] -> do + (as,bs) <- GHC.getContext + -- Guess which module the user wants to browse. Pick + -- modules that are interpreted first. The most + -- recently-added module occurs last, it seems. + case (as,bs) of + (as@(_:_), _) -> browseModule bang (last as) True + ([], bs@(_:_)) -> browseModule bang (last bs) True + ([], []) -> ghcError (CmdLineError ":browse: no current module") + _ -> ghcError (CmdLineError "syntax: :browse ") + +-- without bang, show items in context of their parents and omit children +-- with bang, show class methods and data constructors separately, and +-- indicate import modules, to aid qualifying unqualified names +-- with sorted, sort items alphabetically +browseModule :: Bool -> Module -> Bool -> GHCi () +browseModule bang modl exports_only = do + -- :browse! reports qualifiers wrt current context + current_unqual <- GHC.getPrintUnqual -- Temporarily set the context to the module we're interested in, -- just so we can get an appropriate PrintUnqualified - (as,bs) <- io (GHC.getContext s) + (as,bs) <- GHC.getContext prel_mod <- getPrelude - io (if exports_only then GHC.setContext s [] [prel_mod,modl] - else GHC.setContext s [modl] []) - unqual <- io (GHC.getPrintUnqual s) - io (GHC.setContext s as bs) + if exports_only then GHC.setContext [] [prel_mod,modl] + else GHC.setContext [modl] [] + target_unqual <- GHC.getPrintUnqual + GHC.setContext as bs - mb_mod_info <- io $ GHC.getModuleInfo s modl + let unqual = if bang then current_unqual else target_unqual + + mb_mod_info <- GHC.getModuleInfo modl case mb_mod_info of - Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m)) + Nothing -> ghcError (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) = ASSERT( all isExternalName names ) + partition ((==modl) . nameModule) names + occ_sort = sortBy (compare `on` nameOccName) + -- try to sort by src location. If the first name in + -- our list has a good source location, then they all should. + loc_sort names + | n:_ <- names, isGoodSrcSpan (nameSrcSpan n) + = sortBy (compare `on` nameSrcSpan) names + | otherwise + = occ_sort names + + mb_things <- mapM GHC.lookupName sorted_names + let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things) + + rdr_env <- GHC.getGRE + + 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 via "++) . 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") + | all sensible strs = do + playCtxtCmd True (cmd, as, bs) + st <- getGHCiState + setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] } + | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn") where - (fn, mods) = case str of - '+':stuff -> (addToContext, words stuff) - '-':stuff -> (removeFromContext, words stuff) - stuff -> (newContext, words stuff) + (cmd, strs, as, bs) = + case str of + '+':stuff -> rest AddModules stuff + '-':stuff -> rest RemModules stuff + stuff -> rest SetContext stuff + + rest cmd stuff = (cmd, strs, as, bs) + where strs = words stuff + (as,bs) = partitionWith starred strs sensible ('*':m) = looksLikeModuleName m sensible m = looksLikeModuleName m -separate :: Session -> [String] -> [Module] -> [Module] - -> GHCi ([Module],[Module]) -separate session [] 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")) -separate session (str:ms) as bs = do - m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing - separate session ms as (m:bs) - -newContext :: [String] -> GHCi () -newContext strs = do - s <- getSession - (as,bs) <- separate s strs [] [] - prel_mod <- getPrelude - let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs - io $ GHC.setContext s as bs' - - -addToContext :: [String] -> GHCi () -addToContext strs = do - s <- getSession - (as,bs) <- io $ GHC.getContext s - - (new_as,new_bs) <- separate s strs [] [] - - let as_to_add = new_as \\ (as ++ bs) - bs_to_add = new_bs \\ (as ++ bs) - - io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add) - - -removeFromContext :: [String] -> GHCi () -removeFromContext strs = do - s <- getSession - (as,bs) <- io $ GHC.getContext s - - (as_to_remove,bs_to_remove) <- separate s strs [] [] - - let as' = as \\ (as_to_remove ++ bs_to_remove) - bs' = bs \\ (as_to_remove ++ bs_to_remove) - - io $ GHC.setContext s as' bs' + starred ('*':m) = Left m + starred m = Right m + +playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi () +playCtxtCmd fail (cmd, as, bs) + = do + (as',bs') <- do_checks fail + (prev_as,prev_bs) <- GHC.getContext + (new_as, new_bs) <- + case cmd of + SetContext -> do + prel_mod <- getPrelude + let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs' + else bs' + return (as',bs'') + AddModules -> do + let as_to_add = as' \\ (prev_as ++ prev_bs) + bs_to_add = bs' \\ (prev_as ++ prev_bs) + return (prev_as ++ as_to_add, prev_bs ++ bs_to_add) + RemModules -> do + let new_as = prev_as \\ (as' ++ bs') + new_bs = prev_bs \\ (as' ++ bs') + return (new_as, new_bs) + GHC.setContext new_as new_bs + where + do_checks True = do + as' <- mapM wantInterpretedModule as + bs' <- mapM lookupModule bs + return (as',bs') + do_checks False = do + as' <- mapM (trymaybe . wantInterpretedModule) as + bs' <- mapM (trymaybe . lookupModule) bs + return (catMaybes as', catMaybes bs') + + trymaybe m = do + r <- ghciTry m + case r of + Left _ -> return Nothing + Right a -> return (Just a) ---------------------------------------------------------------------------- -- Code for `:set' @@ -1136,25 +1410,55 @@ 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 = filterOut (\(_, f, _) -> f `elem` languageOptions) + 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) - wds -> setOptions wds - where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str + = case getCmd str of + Right ("args", rest) -> + case toArgs rest of + Left err -> io (hPutStrLn stderr err) + Right args -> setArgs args + Right ("prog", rest) -> + case toArgs rest of + Right [prog] -> setProg prog + _ -> io (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) + Right wds -> setOptions wds + +setArgs, setOptions :: [String] -> GHCi () +setProg, setEditor, setStop, setPrompt :: String -> GHCi () setArgs args = do st <- getGHCiState setGHCiState st{ args = args } -setProg [prog] = do +setProg prog = do st <- getGHCiState setGHCiState st{ progname = prog } -setProg _ = do - io (hPutStrLn stderr "syntax: :set prog ") setEditor cmd = do st <- getGHCiState @@ -1188,20 +1492,21 @@ 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 - (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts + (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts + io $ handleFlagWarnings dflags' warns if (not (null leftovers)) - then throwDyn (CmdLineError ("unrecognised flags: " ++ - unwords leftovers)) - else return () + then ghcError $ errorsToGhcException leftovers + else return () new_pkgs <- setDynFlags dflags' @@ -1209,12 +1514,12 @@ newDynFlags minus_opts = do -- and link the new packages. dflags <- getDynFlags when (packageFlags dflags /= pkg_flags) $ do - io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..." - session <- getSession - io (GHC.setTargets session []) - io (GHC.load session LoadAllTargets) + io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..." + GHC.setTargets [] + GHC.load LoadAllTargets io (linkPackages dflags new_pkgs) - setContextAfterLoad session [] + -- package flags changed, we can't re-use any of the old context + setContextAfterLoad ([],[]) False [] return () @@ -1223,7 +1528,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 ++ "'")) @@ -1232,23 +1537,27 @@ unsetOptions str mapM_ unsetOpt plus_opts let no_flag ('-':'f':rest) = return ("-fno-" ++ rest) - no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f)) + no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f)) no_flags <- mapM no_flag minus_opts newDynFlags no_flags -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, unsetOpt :: String -> GHCi () -setOpt ('+':str) +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 @@ -1267,6 +1576,7 @@ optToStr RevertCAFs = "r" -- --------------------------------------------------------------------------- -- code for `:show' +showCmd :: String -> GHCi () showCmd str = do st <- getGHCiState case words str of @@ -1280,45 +1590,37 @@ showCmd str = do ["linker"] -> io showLinkerState ["breaks"] -> showBkptTable ["context"] -> showContext - _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]") + ["packages"] -> showPackages + ["languages"] -> showLanguages + _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++ + " | breaks | context | packages | languages ]")) +showModules :: GHCi () showModules = do - session <- getSession - let show_one ms = do m <- io (GHC.showModule session ms) - io (putStrLn m) - graph <- io (GHC.getModuleGraph session) - mapM_ show_one graph + loaded_mods <- getLoadedModules + -- we want *loaded* modules only, see #1734 + let show_one ms = do m <- GHC.showModule ms; io (putStrLn m) + mapM_ show_one loaded_mods + +getLoadedModules :: GHCi [GHC.ModSummary] +getLoadedModules = do + graph <- GHC.getModuleGraph + filterM (GHC.isLoaded . 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 () + bindings <- GHC.getBindings + docs <- pprTypeAndContents + [ id | AnId id <- sortBy compareTyThings bindings] + printForUserPartWay docs compareTyThings :: TyThing -> TyThing -> Ordering t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2 -showTyThing :: TyThing -> GHCi (Maybe SDoc) -showTyThing (AnId id) = do - ty' <- cleanType (GHC.idType id) - return $ Just $ ppr id <> text " :: " <> ppr ty' -showTyThing _ = return Nothing - printTyThing :: TyThing -> GHCi () -printTyThing tyth = do - mb_x <- showTyThing tyth - case mb_x of - Just x -> printForUser x - Nothing -> 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 @@ -1327,22 +1629,47 @@ showBkptTable = do showContext :: GHCi () showContext = do - session <- getSession - resumes <- io $ GHC.getResumeContext session + resumes <- GHC.getResumeContext printForUser $ vcat (map pp_resume (reverse resumes)) where pp_resume resume = - ptext SLIT("--> ") <> text (GHC.resumeStmt resume) - $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume)) - + ptext (sLit "--> ") <> text (GHC.resumeStmt resume) + $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume)) + +showPackages :: GHCi () +showPackages = do + 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) + (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 + +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 [] -#ifdef USE_READLINE +completeMacro, completeIdentifier, completeModule, + completeHomeModule, completeSetOptions, completeFilename, + completeHomeModuleOrFile + :: String -> IO [String] + +#ifdef USE_EDITLINE completeWord :: String -> Int -> Int -> IO (Maybe (String, [String])) completeWord w start end = do line <- Readline.getLineBuffer @@ -1351,55 +1678,63 @@ completeWord w start end = do ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w _other | ((':':c) : _) <- line_words -> do - maybe_cmd <- lookupCommand c - let (n,w') = selectWord (words' 0 line) - case maybe_cmd of - Nothing -> return Nothing - Just (_,_,False,complete) -> wrapCompleter complete w - Just (_,_,True,complete) -> let complete' w = do rets <- complete w - return (map (drop n) rets) - in wrapCompleter complete' w' + completionVars <- lookupCompletionVars c + case completionVars of + (Nothing,complete) -> wrapCompleter complete w + (Just breakChars,complete) + -> let (n,w') = selectWord + (words' (`elem` breakChars) 0 line) + 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 - where words' _ [] = [] - words' n str = let (w,r) = break isSpace str - (s,r') = span isSpace r - in (n,w):words' (n+length w+length s) r' + where words' _ _ [] = [] + words' isBreak n str = let (w,r) = break isBreak str + (s,r') = span isBreak r + in (n,w):words' isBreak (n+length w+length s) r' -- In a Haskell expression we want to parse 'a-b' as three words - -- where a compiler flag (ie. -fno-monomorphism-restriction) should + -- where a compiler flag (e.g. -ddump-simpl) should -- only be a single word. selectWord [] = (0,w) selectWord ((offset,x):xs) | offset+length x >= start = (start-offset,take (end-offset) x) | otherwise = selectWord xs + + lookupCompletionVars ('!':_) = return (Just filenameWordBreakChars, + completeFilename) + lookupCompletionVars c = do + maybe_cmd <- lookupCommand' c + case maybe_cmd of + Just (_,_,ws,f) -> return (ws,f) + Nothing -> return (Just filenameWordBreakChars, + completeFilename) +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 - rdrs <- GHC.getRdrNamesInScope s + rdrs <- withRestoredSession GHC.getRdrNamesInScope return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs)) completeModule w = do - s <- restoreSession - dflags <- GHC.getSessionDynFlags s + dflags <- withRestoredSession GHC.getSessionDynFlags let pkg_mods = allExposedModules dflags return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods)) completeHomeModule w = do - s <- restoreSession - g <- GHC.getModuleGraph s + g <- withRestoredSession GHC.getModuleGraph let home_mods = map GHC.ms_mod_name g return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods)) @@ -1407,7 +1742,18 @@ completeSetOptions w = do return (filter (w `isPrefixOf`) options) where options = "args":"prog":allFlags -completeFilename = Readline.filenameCompletionFunction +completeFilename w = do + ws <- Readline.filenameCompletionFunction w + case ws of + -- If we only found one result, and it's a directory, + -- add a trailing slash. + [file] -> do + isDir <- expandPathIO file >>= doesDirectoryExist + if isDir && last file /= '/' + then return [file ++ "/"] + else return [file] + _ -> return ws + completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename @@ -1421,8 +1767,10 @@ wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String] wrapCompleter fun w = do strs <- fun w case strs of - [] -> return Nothing - [x] -> return (Just (x,[])) + [] -> Readline.setAttemptedCompletionOver True >> return Nothing + [x] -> -- Add a trailing space, unless it already has an appended slash. + let appended = if last x == '/' then x else x ++ " " + in return (Just (appended,[])) xs -> case getCommonPrefix xs of "" -> return (Just ("",xs)) pref -> return (Just (pref,xs)) @@ -1430,19 +1778,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 @@ -1450,7 +1797,6 @@ completeHomeModule = completeNone completeSetOptions = completeNone completeFilename = completeNone completeHomeModuleOrFile=completeNone -completeBkpt = completeNone #endif -- --------------------------------------------------------------------------- @@ -1466,13 +1812,15 @@ completeBkpt = completeNone -- raising another exception. We therefore don't put the recursive -- handler arond the flushing operation, so if stderr is closed -- GHCi will just die gracefully rather than going into an infinite loop. -handler :: Exception -> GHCi Bool +handler :: SomeException -> GHCi Bool handler exception = do flushInterpBuffers io installSignalHandlers ghciHandle handler (showException exception >> return False) +showException :: SomeException -> GHCi () +#if __GLASGOW_HASKELL__ < 609 showException (DynException dyn) = case fromDynamic dyn of Nothing -> io (putStrLn ("*** Exception: (unknown)")) @@ -1483,6 +1831,17 @@ showException (DynException dyn) = showException other_exception = io (putStrLn ("*** Exception: " ++ show other_exception)) +#else +showException (SomeException e) = + io $ case cast e of + Just Interrupted -> putStrLn "Interrupted." + -- omit the location for CmdLineError: + Just (CmdLineError s) -> putStrLn s + -- ditto: + Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "") + Just other_ghc_ex -> print other_ghc_ex + Nothing -> putStrLn ("*** Exception: " ++ show e) +#endif ----------------------------------------------------------------------------- -- recursive exception handlers @@ -1491,87 +1850,76 @@ showException other_exception -- in an exception loop (eg. let a = error a in a) the ^C exception -- may never be delivered. Thanks to Marcin for pointing out the bug. -ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a +ghciHandle :: (SomeException -> GHCi a) -> GHCi a -> GHCi a ghciHandle h (GHCi m) = GHCi $ \s -> - Exception.catch (m s) + gcatch (m s) (\e -> unGHCi (ghciUnblock (h e)) s) ghciUnblock :: GHCi a -> GHCi a -ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s) +ghciUnblock (GHCi a) = + GHCi $ \s -> reifyGhc $ \gs -> + Exception.unblock (reflectGhc (a s) gs) +ghciTry :: GHCi a -> GHCi (Either SomeException a) +ghciTry (GHCi m) = GHCi $ \s -> gtry (m s) -- ---------------------------------------------------------------------------- -- Utils expandPath :: String -> GHCi String -expandPath path = +expandPath path = io (expandPathIO path) + +expandPathIO :: String -> IO String +expandPathIO path = case dropWhile isSpace path of ('~':d) -> do - tilde <- io (getEnv "HOME") -- will fail if HOME not defined + tilde <- getHomeDirectory -- will fail if HOME not defined return (tilde ++ '/':d) other -> return other wantInterpretedModule :: String -> GHCi Module wantInterpretedModule str = do - session <- getSession modl <- lookupModule str - is_interpreted <- io (GHC.moduleIsInterpreted session modl) + dflags <- getDynFlags + when (GHC.modulePackageId modl /= thisPackage dflags) $ + ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module")) + is_interpreted <- GHC.moduleIsInterpreted modl when (not is_interpreted) $ - throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted")) + ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first")) return modl -wantNameFromInterpretedModule noCanDo str and_then = do - session <- getSession - names <- io $ GHC.parseName session str +wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String + -> (Name -> GHCi ()) + -> GHCi () +wantNameFromInterpretedModule noCanDo str and_then = + handleSourceError (GHC.printExceptionAndWarnings) $ do + names <- GHC.parseName str case names of [] -> return () (n:_) -> do - let modl = GHC.nameModule n + let modl = ASSERT( isExternalName n ) GHC.nameModule n if not (GHC.isExternalName n) then noCanDo n $ ppr n <> text " is not defined in an interpreted module" else do - is_interpreted <- io (GHC.moduleIsInterpreted session modl) + is_interpreted <- GHC.moduleIsInterpreted modl if not is_interpreted then noCanDo n $ text "module " <> ppr modl <> text " is not interpreted" 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 + pprintClosureCommand bind force str stepCmd :: String -> GHCi () stepCmd [] = doContinue (const True) GHC.SingleStep @@ -1594,9 +1942,9 @@ stepModuleCmd [] = do mb_span <- getCurrentBreakSpan case mb_span of Nothing -> stepCmd [] - Just loc -> do + Just _ -> do Just span <- getCurrentBreakSpan - let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span + let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span doContinue f GHC.SingleStep stepModuleCmd expression = stepCmd expression @@ -1619,16 +1967,15 @@ 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 + runResult <- resume step afterRunStmt pred runResult return () abandonCmd :: String -> GHCi () abandonCmd = noArgs $ do - s <- getSession - b <- io $ GHC.abandon s -- the prompt will change to indicate the new context + b <- GHC.abandon -- the prompt will change to indicate the new context when (not b) $ io $ putStrLn "There is no computation running." return () @@ -1656,44 +2003,46 @@ historyCmd arg | otherwise = io $ putStrLn "Syntax: :history [num]" where history num = do - s <- getSession - resumes <- io $ GHC.getResumeContext s + resumes <- GHC.getResumeContext case resumes of [] -> io $ putStrLn "Not stopped at a breakpoint" - (r:rs) -> do + (r:_) -> do let hist = GHC.resumeHistory r (took,rest) = splitAt num hist - spans <- mapM (io . GHC.getHistorySpan s) took - let nums = map (printf "-%-3d:") [(1::Int)..] - let names = map GHC.historyEnclosingDecl took - printForUser (vcat(zipWith3 - (\x y z -> x <+> y <+> z) - (map text nums) - (map (bold . ppr) names) - (map (parens . ppr) spans))) - io $ putStrLn $ if null rest then "" else "..." - + case hist of + [] -> io $ 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 + printForUser (vcat(zipWith3 + (\x y z -> x <+> y <+> z) + (map text nums) + (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 - printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span - printTypeOfNames s names + (names, _, span) <- GHC.back + printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span + printTypeOfNames names -- run the command set with ":set stop " st <- getGHCiState enqueueCommands [stop st] forwardCmd :: String -> GHCi () forwardCmd = noArgs $ do - s <- getSession - (names, ix, span) <- io $ GHC.forward s + (names, ix, span) <- GHC.forward printForUser $ (if (ix == 0) - then ptext SLIT("Stopped at") - else ptext SLIT("Logged breakpoint at")) <+> ppr span - printTypeOfNames s names + then ptext (sLit "Stopped at") + else ptext (sLit "Logged breakpoint at")) <+> ppr span + printTypeOfNames names -- run the command set with ":set stop " st <- getGHCiState enqueueCommands [stop st] @@ -1701,18 +2050,17 @@ forwardCmd = noArgs $ do -- handle the "break" command breakCmd :: String -> GHCi () breakCmd argLine = do - session <- getSession - breakSwitch session $ words argLine + breakSwitch $ words argLine -breakSwitch :: Session -> [String] -> GHCi () -breakSwitch _session [] = do +breakSwitch :: [String] -> GHCi () +breakSwitch [] = do io $ putStrLn "The break command requires at least one argument." -breakSwitch session args@(arg1:rest) - | looksLikeModuleName arg1 = do +breakSwitch (arg1:rest) + | looksLikeModuleName arg1 && not (null rest) = do mod <- wantInterpretedModule arg1 - breakByModule session mod rest + breakByModule mod rest | all isDigit arg1 = do - (toplevel, _) <- io $ GHC.getContext session + (toplevel, _) <- GHC.getContext case toplevel of (mod : _) -> breakByModuleLine mod (read arg1) rest [] -> do @@ -1722,7 +2070,8 @@ breakSwitch session args@(arg1:rest) wantNameFromInterpretedModule noCanDo arg1 $ \name -> do let loc = GHC.srcSpanStart (GHC.nameSrcSpan name) if GHC.isGoodSrcLoc loc - then findBreakAndSet (GHC.nameModule name) $ + then ASSERT( isExternalName name ) + findBreakAndSet (GHC.nameModule name) $ findBreakByCoord (Just (GHC.srcLocFile loc)) (GHC.srcLocLine loc, GHC.srcLocCol loc) @@ -1731,11 +2080,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 () @@ -1745,7 +2094,8 @@ breakByModuleLine mod line args findBreakAndSet mod $ findBreakByCoord Nothing (line, read col) | otherwise = breakSyntax -breakSyntax = throwDyn (CmdLineError "Syntax: :break [] []") +breakSyntax :: a +breakSyntax = ghcError (CmdLineError "Syntax: :break [] []") findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi () findBreakAndSet mod lookupTickTree = do @@ -1755,7 +2105,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) <- @@ -1790,11 +2139,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) @@ -1807,14 +2156,14 @@ 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 ] @@ -1824,8 +2173,9 @@ findBreakByCoord mb_file (line, col) arr -- TERM to vt100 for other reasons) we get carets. -- We really ought to use a proper termcap/terminfo library. do_bold :: Bool -do_bold = unsafePerformIO (System.Environment.getEnv "TERM") `elem` - ["xterm", "linux"] +do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"] + where mTerm = System.Environment.getEnv "TERM" + `catchIO` \_ -> return "TERM not set" start_bold :: String start_bold = "\ESC[1m" @@ -1836,14 +2186,27 @@ listCmd :: String -> GHCi () listCmd "" = do mb_span <- getCurrentBreakSpan case mb_span of - Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list" - Just span | GHC.isGoodSrcSpan span -> io $ listAround span True - | otherwise -> printForUser $ text "unable to list source for" <+> ppr span + Nothing -> + printForUser $ text "Not stopped at a breakpoint; nothing to list" + Just span + | GHC.isGoodSrcSpan span -> io $ listAround span True + | otherwise -> + do resumes <- GHC.getResumeContext + case resumes of + [] -> panic "No resumes" + (r:_) -> + do let traceIt = case GHC.resumeHistory r of + [] -> text "rerunning with :trace," + _ -> empty + doWhat = traceIt <+> text ":back then :list" + printForUser (text "Unable to list source for" <+> + ppr span + $$ text "Try" <+> doWhat) listCmd str = list2 (words str) +list2 :: [String] -> GHCi () list2 [arg] | all isDigit arg = do - session <- getSession - (toplevel, _) <- io $ GHC.getContext session + (toplevel, _) <- GHC.getContext case toplevel of [] -> io $ putStrLn "No module to list" (mod : _) -> listModuleLine mod (read arg) @@ -1855,7 +2218,8 @@ list2 [arg] = do let loc = GHC.srcSpanStart (GHC.nameSrcSpan name) if GHC.isGoodSrcLoc loc then do - tickArray <- getTickArray (GHC.nameModule name) + tickArray <- ASSERT( isExternalName name ) + getTickArray (GHC.nameModule name) let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc)) (GHC.srcLocLine loc, GHC.srcLocCol loc) tickArray @@ -1873,8 +2237,7 @@ list2 _other = listModuleLine :: Module -> Int -> GHCi () listModuleLine modl line = do - session <- getSession - graph <- io (GHC.getModuleGraph session) + graph <- GHC.getModuleGraph let this = filter ((== modl) . GHC.ms_mod) graph case this of [] -> panic "listModuleLine" @@ -1885,7 +2248,8 @@ listModuleLine modl line = do -- | list a section of a source file around a particular SrcSpan. -- If the highlight flag is True, also highlight the span using --- start_bold/end_bold. +-- start_bold\/end_bold. +listAround :: SrcSpan -> Bool -> IO () listAround span do_highlight = do contents <- BS.readFile (unpackFS file) let @@ -1896,12 +2260,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 @@ -1916,32 +2280,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,BS.pack start_bold,b,BS.pack 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, BS.pack 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, BS.pack 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' -- -------------------------------------------------------------------------- @@ -1954,7 +2319,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 @@ -1976,8 +2341,7 @@ mkTickArray ticks lookupModule :: String -> GHCi Module lookupModule modName - = do session <- getSession - io (GHC.findModule session (GHC.mkModuleName modName) Nothing) + = GHC.findModule (GHC.mkModuleName modName) Nothing -- don't reset the counter back to zero? discardActiveBreakPoints :: GHCi () @@ -1998,14 +2362,14 @@ 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) getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan) getModBreak mod = do - session <- getSession - Just mod_info <- io $ GHC.getModuleInfo session mod + Just mod_info <- GHC.getModuleInfo mod let modBreaks = GHC.modInfoModBreaks mod_info let array = GHC.modBreaks_flags modBreaks let ticks = GHC.modBreaks_locs modBreaks @@ -2015,4 +2379,3 @@ setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool setBreakFlag toggle array index | toggle = GHC.setBreakOn array index | otherwise = GHC.setBreakOff array index -