X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=4a98b9e60a1210e700854f1ce9a1a3e0e5c0f75e;hb=38e7ac3ffa32d75c1922e7247a910e06d9957116;hp=485e329d3975cfa012457da27a187ae7b062ed3e;hpb=bd6cfcc12e3a047b1fd6d62cf79ea2cc2bd010b9;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 485e329..4a98b9e 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -3,7 +3,7 @@ -- -- GHC Interactive User Interface -- --- (c) The GHC Team 2005 +-- (c) The GHC Team 2005-2006 -- ----------------------------------------------------------------------------- module InteractiveUI ( @@ -13,52 +13,35 @@ module InteractiveUI ( #include "HsVersions.h" -#if defined(GHCI) && defined(BREAKPOINT) -import GHC.Exts ( Int(..), Ptr(..), int2Addr# ) -import Foreign.StablePtr ( deRefStablePtr, castPtrToStablePtr ) -import System.IO.Unsafe ( unsafePerformIO ) -import Var ( Id, globaliseId, idName, idType ) -import HscTypes ( Session(..), InteractiveContext(..), HscEnv(..) - , extendTypeEnvWithIds ) -import RdrName ( extendLocalRdrEnv, mkRdrUnqual, lookupLocalRdrEnv ) -import NameEnv ( delListFromNameEnv ) -import TcType ( tidyTopType ) -import qualified Id ( setIdType ) -import IdInfo ( GlobalIdDetails(..) ) -import Linker ( HValue, extendLinkEnv, withExtendedLinkEnv, - initDynLinker ) -import PrelNames ( breakpointJumpName, breakpointCondJumpName ) -#endif +import GhciMonad -- The GHC interface import qualified GHC -import GHC ( Session, dopt, DynFlag(..), Target(..), - TargetId(..), DynFlags(..), - pprModule, Type, Module, ModuleName, SuccessFlag(..), - TyThing(..), Name, LoadHowMuch(..), Phase, - GhcException(..), showGhcException, - CheckedModule(..), SrcLoc ) -import DynFlags ( allFlags ) -import Packages ( PackageState(..) ) -import PackageConfig ( InstalledPackageInfo(..) ) -import UniqFM ( eltsUFM ) +import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..), + Type, Module, ModuleName, TyThing(..), Phase, + BreakIndex ) +import Debugger +import DynFlags +import Packages +import PackageConfig +import UniqFM import PprTyThing import Outputable +import Module -- for ModuleEnv --- for createtags (should these come via GHC?) -import Name ( nameSrcLoc, nameModule, nameOccName ) -import OccName ( pprOccName ) -import SrcLoc ( isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol ) +-- for createtags +import Name +import OccName +import SrcLoc -- Other random utilities -import Digraph ( flattenSCCs ) -import BasicTypes ( failed, successIf ) -import Panic ( panic, installSignalHandlers ) +import Digraph +import BasicTypes hiding (isTopLevel) +import Panic hiding (showException) import Config -import StaticFlags ( opt_IgnoreDotGhci ) -import Linker ( showLinkerState, linkPackages ) -import Util ( removeSpaces, handle, global, toArgs, - looksLikeModuleName, prefixMatch, sortLe ) +import StaticFlags +import Linker +import Util #ifndef mingw32_HOST_OS import System.Posix @@ -68,6 +51,7 @@ import System.Posix #else import GHC.ConsoleHandler ( flushConsole ) import System.Win32 ( setConsoleCP, setConsoleOutputCP ) +import qualified System.Win32 #endif #ifdef USE_READLINE @@ -78,31 +62,34 @@ import System.Console.Readline as Readline --import SystemExts import Control.Exception as Exception -import Data.Dynamic -- import Control.Concurrent -import Numeric import Data.List -import Data.Int ( Int64 ) -import Data.Maybe ( isJust, isNothing, fromMaybe, catMaybes ) +import Data.Maybe import System.Cmd -import System.CPUTime import System.Environment import System.Exit ( exitWith, ExitCode(..) ) import System.Directory import System.IO import System.IO.Error as IO import Data.Char +import Data.Dynamic +import Data.Array import Control.Monad as Monad -import Foreign.StablePtr ( newStablePtr ) +import Foreign.StablePtr ( newStablePtr ) import GHC.Exts ( unsafeCoerce# ) -import GHC.IOBase ( IOErrorType(InvalidArgument) ) +import GHC.IOBase ( IOErrorType(InvalidArgument), IO(IO) ) -import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) +import Data.IORef ( IORef, readIORef, writeIORef ) import System.Posix.Internals ( setNonBlockingFD ) +-- these are needed by the new ghci debugger +import ByteCodeLink (HValue) +import ByteCodeInstr (BreakInfo (..)) +import BreakArray + ----------------------------------------------------------------------------- ghciWelcomeMsg = @@ -119,27 +106,37 @@ GLOBAL_VAR(commands, builtin_commands, [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), + ("break", breakCmd, False, completeNone), ("browse", keepGoing browseCmd, False, completeModule), - ("cd", keepGoing changeDirectory, False, completeFilename), + ("cd", keepGoing changeDirectory, False, completeFilename), + ("check", keepGoing checkModule, False, completeHomeModule), + ("continue", continueCmd, False, completeNone), + ("ctags", keepGoing createCTagsFileCmd, False, completeFilename), ("def", keepGoing defineMacro, False, completeIdentifier), + ("delete", deleteCmd, False, completeNone), + ("e", keepGoing editFile, False, completeFilename), + ("edit", keepGoing editFile, False, completeFilename), + ("etags", keepGoing createETagsFileCmd, False, completeFilename), + ("force", keepGoing (pprintClosureCommand False True), False, completeIdentifier), ("help", keepGoing help, False, completeNone), - ("?", keepGoing help, False, completeNone), ("info", keepGoing info, False, completeIdentifier), - ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile), + ("kind", keepGoing kindOfType, False, completeIdentifier), + ("load", keepGoingPaths loadModule_,False, completeHomeModuleOrFile), ("module", keepGoing setContext, False, completeModule), ("main", keepGoing runMain, False, completeIdentifier), - ("reload", keepGoing reloadModule, False, completeNone), - ("check", keepGoing checkModule, False, completeHomeModule), + ("print", keepGoing (pprintClosureCommand True False), False, completeIdentifier), + ("quit", quit, False, completeNone), + ("reload", keepGoing reloadModule, False, completeNone), ("set", keepGoing setCmd, True, completeSetOptions), ("show", keepGoing showCmd, False, completeNone), - ("etags", keepGoing createETagsFileCmd, False, completeFilename), - ("ctags", keepGoing createCTagsFileCmd, False, completeFilename), + ("sprint", keepGoing (pprintClosureCommand False False),False, completeIdentifier), + ("step", stepCmd, False, completeNone), ("type", keepGoing typeOfExpr, False, completeIdentifier), - ("kind", keepGoing kindOfType, False, completeIdentifier), - ("unset", keepGoing unsetOptions, True, completeSetOptions), ("undef", keepGoing undefineMacro, False, completeMacro), - ("quit", quit, False, completeNone) + ("unset", keepGoing unsetOptions, True, completeSetOptions) ] keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool) @@ -159,8 +156,12 @@ helpText = " :browse [*] display the names defined by \n" ++ " :cd change directory to \n" ++ " :def define a command :\n" ++ + " :edit edit file\n" ++ + " :edit edit last module\n" ++ " :help, :? display this list of commands\n" ++ " :info [ ...] display information about the given names\n" ++ + " :print [ ...] prints a value without forcing its computation\n" ++ + " :sprint [ ...] simplified version of :print\n" ++ " :load ... load module(s) and their dependents\n" ++ " :module [+/-] [*] ... set the context for expression evaluation\n" ++ " :main [ ...] run the main function with the given arguments\n" ++ @@ -170,12 +171,13 @@ helpText = " :set args ... set the arguments returned by System.getArgs\n" ++ " :set prog set the value returned by System.getProgName\n" ++ " :set prompt set the prompt used in GHCi\n" ++ + " :set editor set the command used for :edit\n" ++ "\n" ++ " :show modules show the currently loaded modules\n" ++ " :show bindings show the current bindings made at the prompt\n" ++ "\n" ++ " :ctags [] create tags file for Vi (default: \"tags\")\n" ++ - " :etags [] create tags file for Emacs (defauilt: \"TAGS\")\n" ++ + " :etags [] create tags file for Emacs (default: \"TAGS\")\n" ++ " :type show the type of \n" ++ " :kind show the kind of \n" ++ " :undef undefine user-defined command :\n" ++ @@ -189,79 +191,22 @@ helpText = " +s print timing/memory stats after each evaluation\n" ++ " +t print type after evaluation\n" ++ " - most GHC command line flags can also be set here\n" ++ - " (eg. -v2, -fglasgow-exts, etc.)\n" - - -#if defined(GHCI) && defined(BREAKPOINT) -globaliseAndTidy :: Id -> Id -globaliseAndTidy id --- Give the Id a Global Name, and tidy its type - = Id.setIdType (globaliseId VanillaGlobal id) tidy_type - where - tidy_type = tidyTopType (idType id) - - -printScopeMsg :: Session -> String -> [Id] -> IO () -printScopeMsg session location ids - = GHC.getPrintUnqual session >>= \unqual -> - printForUser stdout unqual $ - text "Local bindings in scope:" $$ - nest 2 (pprWithCommas showId ids) - where showId id = ppr (idName id) <+> dcolon <+> ppr (idType id) - -jumpCondFunction :: Session -> Int -> [HValue] -> String -> Bool -> b -> b -jumpCondFunction session ptr hValues location True b = b -jumpCondFunction session ptr hValues location False b - = jumpFunction session ptr hValues location b - -jumpFunction :: Session -> Int -> [HValue] -> String -> b -> b -jumpFunction session@(Session ref) (I# idsPtr) hValues location b - = unsafePerformIO $ - do ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr))) - let names = map idName ids - ASSERT (length names == length hValues) return () - printScopeMsg session location ids - hsc_env <- readIORef ref - - let ictxt = hsc_IC hsc_env - global_ids = map globaliseAndTidy ids - rn_env = ic_rn_local_env ictxt - type_env = ic_type_env ictxt - bound_names = map idName global_ids - new_rn_env = extendLocalRdrEnv rn_env bound_names - -- Remove any shadowed bindings from the type_env; - -- they are inaccessible but might, I suppose, cause - -- a space leak if we leave them there - shadowed = [ n | name <- bound_names, - let rdr_name = mkRdrUnqual (nameOccName name), - Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] - filtered_type_env = delListFromNameEnv type_env shadowed - new_type_env = extendTypeEnvWithIds filtered_type_env global_ids - new_ic = ictxt { ic_rn_local_env = new_rn_env, - ic_type_env = new_type_env } - writeIORef ref (hsc_env { hsc_IC = new_ic }) - is_tty <- hIsTerminalDevice stdin - prel_mod <- GHC.findModule session prel_name Nothing - withExtendedLinkEnv (zip names hValues) $ - startGHCi (interactiveLoop is_tty True) - GHCiState{ progname = "", - args = [], - prompt = location++"> ", - session = session, - options = [], - prelude = prel_mod } - writeIORef ref hsc_env - putStrLn $ "Returning to normal execution..." - return b + " (eg. -v2, -fglasgow-exts, etc.)\n" ++ + "\n" +-- Todo: add help for breakpoint commands here + +findEditor = do + getEnv "EDITOR" + `IO.catch` \_ -> do +#if mingw32_HOST_OS + win <- System.Win32.getWindowsDirectory + return (win `joinFileName` "notepad.exe") +#else + return "" #endif interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO () interactiveUI session srcs maybe_expr = do -#if defined(GHCI) && defined(BREAKPOINT) - initDynLinker =<< GHC.getSessionDynFlags session - extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session)) - ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))] -#endif -- 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 @@ -289,7 +234,7 @@ interactiveUI session srcs maybe_expr = do hSetBuffering stdin NoBuffering -- initial context is just the Prelude - prel_mod <- GHC.findModule session prel_name Nothing + prel_mod <- GHC.findModule session prel_name (Just basePackageId) GHC.setContext session [] [prel_mod] #ifdef USE_READLINE @@ -306,13 +251,20 @@ interactiveUI session srcs maybe_expr = do Readline.setCompleterWordBreakCharacters word_break_chars #endif + default_editor <- findEditor + startGHCi (runGHCi srcs maybe_expr) GHCiState{ progname = "", args = [], prompt = "%s> ", + editor = default_editor, session = session, options = [], - prelude = prel_mod } + prelude = prel_mod, + resume = [], + breaks = emptyActiveBreakPoints, + tickarrays = emptyModuleEnv + } #ifdef USE_READLINE Readline.resetTerminal Nothing @@ -492,7 +444,7 @@ mkPrompt toplevs exports prompt perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+> hsep (map (ppr . GHC.moduleName) exports) - + #ifdef USE_READLINE readlineLoop :: GHCi () @@ -543,52 +495,44 @@ runCommandEval c = ghciHandle handleEval (doCommand c) -- failure to run the command causes exit(1) for ghc -e. _ -> finishEvalExpr nms --- This is the exception handler for exceptions generated by the --- user's code; it normally just prints out the exception. The --- handler must be recursive, in case showing the exception causes --- more exceptions to be raised. --- --- Bugfix: if the user closed stdout or stderr, the flushing will fail, --- 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 exception = do - flushInterpBuffers - io installSignalHandlers - ghciHandle handler (showException exception >> return False) - -showException (DynException dyn) = - case fromDynamic dyn of - Nothing -> io (putStrLn ("*** Exception: (unknown)")) - Just Interrupted -> io (putStrLn "Interrupted.") - Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError - Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto - Just other_ghc_ex -> io (print other_ghc_ex) - -showException other_exception - = io (putStrLn ("*** Exception: " ++ show other_exception)) - -runStmt :: String -> GHCi (Maybe [Name]) +runStmt :: String -> GHCi (Maybe (Bool,[Name])) runStmt stmt - | null (filter (not.isSpace) stmt) = return (Just []) + | null (filter (not.isSpace) stmt) = return (Just (False,[])) | otherwise = do st <- getGHCiState session <- getSession result <- io $ withProgName (progname st) $ withArgs (args st) $ GHC.runStmt session stmt - case result of - GHC.RunFailed -> return Nothing - GHC.RunException e -> throw e -- this is caught by runCommand(Eval) - GHC.RunOk names -> return (Just names) + switchOnRunResult result + +switchOnRunResult :: GHC.RunResult -> GHCi (Maybe (Bool,[Name])) +switchOnRunResult GHC.RunFailed = return Nothing +switchOnRunResult (GHC.RunException e) = throw e +switchOnRunResult (GHC.RunOk names) = return $ Just (False,names) +switchOnRunResult (GHC.RunBreak threadId names info resume) = do + session <- getSession + Just mod_info <- io $ GHC.getModuleInfo session (breakInfo_module info) + let modBreaks = GHC.modInfoModBreaks mod_info + let ticks = GHC.modBreaks_locs modBreaks + + -- display information about the breakpoint + let location = ticks ! breakInfo_number info + unqual <- io $ GHC.getPrintUnqual session + io $ printForUser stdout unqual $ + ptext SLIT("Stopped at") <+> ppr location + + pushResume location threadId resume + return (Just (True,names)) -- possibly print the type and revert CAFs after evaluating an expression finishEvalExpr mb_names - = do b <- isOptionSet ShowType + = do show_types <- isOptionSet ShowType session <- getSession case mb_names of Nothing -> return () - Just names -> when b (mapM_ (showTypeOfName session) names) + Just (is_break,names) -> + when (is_break || show_types) $ + mapM_ (showTypeOfName session) names flushInterpBuffers io installSignalHandlers @@ -603,12 +547,6 @@ showTypeOfName session n Nothing -> return () Just thing -> showTyThing thing -showForUser :: SDoc -> GHCi String -showForUser doc = do - session <- getSession - unqual <- io (GHC.getPrintUnqual session) - return $! showSDocForUser unqual doc - specialCommand :: String -> GHCi Bool specialCommand ('!':str) = shellEscape (dropWhile isSpace str) specialCommand str = do @@ -630,43 +568,6 @@ lookupCommand str = do c:_ -> return (Just c) ----------------------------------------------------------------------------- --- To flush buffers for the *interpreted* computation we need --- to refer to *its* stdout/stderr handles - -GLOBAL_VAR(flush_interp, error "no flush_interp", IO ()) -GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ()) - -no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++ - " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering" -flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr" - -initInterpBuffering :: Session -> IO () -initInterpBuffering session - = do maybe_hval <- GHC.compileExpr session no_buf_cmd - - case maybe_hval of - Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ()) - other -> panic "interactiveUI:setBuffering" - - maybe_hval <- GHC.compileExpr session flush_cmd - case maybe_hval of - Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ()) - _ -> panic "interactiveUI:flush" - - return () - - -flushInterpBuffers :: GHCi () -flushInterpBuffers - = io $ do Monad.join (readIORef flush_interp) - return () - -turnOffBuffering :: IO () -turnOffBuffering - = do Monad.join (readIORef turn_off_buffering) - return () - ------------------------------------------------------------------------------ -- Commands help :: String -> GHCi () @@ -695,7 +596,8 @@ info s = do { let names = words s filterOutChildren :: [Name] -> [Name] filterOutChildren names = filter (not . parent_is_there) names where parent_is_there n - | Just p <- GHC.nameParent_maybe n = p `elem` names +-- | Just p <- GHC.nameParent_maybe n = p `elem` names +-- ToDo!! | otherwise = False pprInfo exts (thing, fixity, insts) @@ -739,6 +641,27 @@ changeDirectory dir = do dir <- expandPath dir io (setCurrentDirectory dir) +editFile :: String -> GHCi () +editFile str + | null str = do + -- find the name of the "topmost" file loaded + session <- getSession + graph0 <- io (GHC.getModuleGraph session) + graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0 + let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing) + case GHC.ml_hs_file (GHC.ms_location (last graph2)) of + Just file -> do_edit file + Nothing -> throwDyn (CmdLineError "unknown file name") + | otherwise = do_edit str + where + do_edit file = do + st <- getGHCiState + let cmd = editor st + when (null cmd) $ + throwDyn (CmdLineError "editor not set, use :set editor") + io $ system (cmd ++ ' ':file) + return () + defineMacro :: String -> GHCi () defineMacro s = do let (macro_name, definition) = break isSpace s @@ -820,7 +743,7 @@ checkModule m = do case result of Nothing -> io $ putStrLn "Nothing" Just r -> io $ putStrLn (showSDoc ( - case checkedModuleInfo r of + case GHC.checkedModuleInfo r of Just cm | Just scope <- GHC.modInfoTopLevelScope cm -> let (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope @@ -844,14 +767,13 @@ reloadModule m = do afterLoad ok session = do io (revertCAFs) -- always revert CAFs on load. + discardResumeContext + discardTickArrays + discardActiveBreakPoints 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') -#if defined(GHCI) && defined(BREAKPOINT) - io (extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session)) - ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))]) -#endif setContextAfterLoad session [] = do prel_mod <- getPrelude @@ -919,7 +841,7 @@ kindOfType str Nothing -> return () Just ty -> do tystr <- showForUser (ppr ty) io (putStrLn (str ++ " :: " ++ tystr)) - + quit :: String -> GHCi Bool quit _ = return True @@ -1050,10 +972,8 @@ browseCmd m = browseModule m exports_only = do s <- getSession - modl <- io $ GHC.findModule s (GHC.mkModuleName m) Nothing - is_interpreted <- io (GHC.moduleIsInterpreted s modl) - when (not is_interpreted && not exports_only) $ - throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted")) + modl <- if exports_only then lookupModule s m + else wantInterpretedModule s m -- Temporarily set the context to the module we're interested in, -- just so we can get an appropriate PrintUnqualified @@ -1169,11 +1089,13 @@ setCmd "" else hsep (map (\o -> char '+' <> text (optToStr o)) opts) )) setCmd str - = case words str of + = case toArgs str of ("args":args) -> setArgs args ("prog":prog) -> setProg prog - ("prompt":prompt) -> setPrompt (dropWhile isSpace $ drop 6 $ dropWhile isSpace str) + ("prompt":prompt) -> setPrompt (after 6) + ("editor":cmd) -> setEditor (after 6) wds -> setOptions wds + where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str setArgs args = do st <- getGHCiState @@ -1185,6 +1107,10 @@ setProg [prog] = do setProg _ = do io (hPutStrLn stderr "syntax: :set prog ") +setEditor cmd = do + st <- getGHCiState + setGHCiState st{ editor = cmd } + setPrompt value = do st <- getGHCiState if null value @@ -1277,6 +1203,7 @@ showCmd str = ["modules" ] -> showModules ["bindings"] -> showBindings ["linker"] -> io showLinkerState + ["breaks"] -> showBkptTable _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]") showModules = do @@ -1307,6 +1234,12 @@ cleanType ty = do then return ty else return $! GHC.dropForAlls ty +showBkptTable :: GHCi () +showBkptTable = do + activeBreaks <- getActiveBreakPoints + str <- showForUser $ ppr activeBreaks + io $ putStrLn str + -- ----------------------------------------------------------------------------- -- Completion @@ -1401,7 +1334,7 @@ wrapCompleter fun w = do getCommonPrefix :: [String] -> String getCommonPrefix [] = "" getCommonPrefix (s:ss) = foldl common s ss - where common s "" = s + where common s "" = "" common "" s = "" common (c:cs) (d:ds) | c == d = c : common cs ds @@ -1421,77 +1354,39 @@ completeHomeModule = completeNone completeSetOptions = completeNone completeFilename = completeNone completeHomeModuleOrFile=completeNone +completeBkpt = completeNone #endif ------------------------------------------------------------------------------ --- GHCi monad - -data GHCiState = GHCiState - { - progname :: String, - args :: [String], - prompt :: String, - session :: GHC.Session, - options :: [GHCiOption], - prelude :: Module - } - -data GHCiOption - = ShowTiming -- show time/allocs after evaluation - | ShowType -- show the type of expressions - | RevertCAFs -- revert CAFs after every evaluation - deriving Eq - -newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a } - -startGHCi :: GHCi a -> GHCiState -> IO a -startGHCi g state = do ref <- newIORef state; unGHCi g ref - -instance Monad GHCi where - (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s - return a = GHCi $ \s -> return a - -ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a -ghciHandleDyn h (GHCi m) = GHCi $ \s -> - Exception.catchDyn (m s) (\e -> unGHCi (h e) s) - -getGHCiState = GHCi $ \r -> readIORef r -setGHCiState s = GHCi $ \r -> writeIORef r s - --- for convenience... -getSession = getGHCiState >>= return . session -getPrelude = getGHCiState >>= return . prelude - -GLOBAL_VAR(saved_sess, no_saved_sess, Session) -no_saved_sess = error "no saved_ses" -saveSession = getSession >>= io . writeIORef saved_sess -splatSavedSession = io (writeIORef saved_sess no_saved_sess) -restoreSession = readIORef saved_sess - -getDynFlags = do - s <- getSession - io (GHC.getSessionDynFlags s) -setDynFlags dflags = do - s <- getSession - io (GHC.setSessionDynFlags s dflags) +-- --------------------------------------------------------------------------- +-- User code exception handling -isOptionSet :: GHCiOption -> GHCi Bool -isOptionSet opt - = do st <- getGHCiState - return (opt `elem` options st) +-- This is the exception handler for exceptions generated by the +-- user's code and exceptions coming from children sessions; +-- it normally just prints out the exception. The +-- handler must be recursive, in case showing the exception causes +-- more exceptions to be raised. +-- +-- Bugfix: if the user closed stdout or stderr, the flushing will fail, +-- 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 -setOption :: GHCiOption -> GHCi () -setOption opt - = do st <- getGHCiState - setGHCiState (st{ options = opt : filter (/= opt) (options st) }) +handler exception = do + flushInterpBuffers + io installSignalHandlers + ghciHandle handler (showException exception >> return False) -unsetOption :: GHCiOption -> GHCi () -unsetOption opt - = do st <- getGHCiState - setGHCiState (st{ options = filter (/= opt) (options st) }) +showException (DynException dyn) = + case fromDynamic dyn of + Nothing -> io (putStrLn ("*** Exception: (unknown)")) + Just Interrupted -> io (putStrLn "Interrupted.") + Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError + Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto + Just other_ghc_ex -> io (print other_ghc_ex) -io :: IO a -> GHCi a -io m = GHCi { unGHCi = \s -> m >>= return } +showException other_exception + = io (putStrLn ("*** Exception: " ++ show other_exception)) ----------------------------------------------------------------------------- -- recursive exception handlers @@ -1508,46 +1403,6 @@ ghciHandle h (GHCi m) = GHCi $ \s -> ghciUnblock :: GHCi a -> GHCi a ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s) ------------------------------------------------------------------------------ --- timing & statistics - -timeIt :: GHCi a -> GHCi a -timeIt action - = do b <- isOptionSet ShowTiming - if not b - then action - else do allocs1 <- io $ getAllocations - time1 <- io $ getCPUTime - a <- action - allocs2 <- io $ getAllocations - time2 <- io $ getCPUTime - io $ printTimes (fromIntegral (allocs2 - allocs1)) - (time2 - time1) - return a - -foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64 - -- defined in ghc/rts/Stats.c - -printTimes :: Integer -> Integer -> IO () -printTimes allocs psecs - = do let secs = (fromIntegral psecs / (10^12)) :: Float - secs_str = showFFloat (Just 2) secs - putStrLn (showSDoc ( - parens (text (secs_str "") <+> text "secs" <> comma <+> - text (show allocs) <+> text "bytes"))) - ------------------------------------------------------------------------------ --- reverting CAFs - -revertCAFs :: IO () -revertCAFs = do - rts_revertCAFs - turnOffBuffering - -- Have to turn off buffering again, because we just - -- reverted stdout, stderr & stdin to their defaults. - -foreign import ccall "revertCAFs" rts_revertCAFs :: IO () - -- Make it "safe", just in case -- ---------------------------------------------------------------------------- -- Utils @@ -1584,3 +1439,238 @@ setUpConsole = do setConsoleOutputCP 28591 -- ISO Latin-1 #endif return () + +-- commands for debugger +foreign import ccall "rts_setStepFlag" setStepFlag :: IO () + +stepCmd :: String -> GHCi Bool +stepCmd [] = doContinue setStepFlag +stepCmd expression = do + io $ setStepFlag + runCommand expression + +continueCmd :: String -> GHCi Bool +continueCmd [] = doContinue $ return () +continueCmd other = do + io $ putStrLn "The continue command accepts no arguments." + return False + +doContinue :: IO () -> GHCi Bool +doContinue actionBeforeCont = do + resumeAction <- popResume + case resumeAction of + Nothing -> do + io $ putStrLn "There is no computation running." + return False + Just (_,_,handle) -> do + io $ actionBeforeCont + session <- getSession + runResult <- io $ GHC.resume session handle + names <- switchOnRunResult runResult + finishEvalExpr names + return False + +deleteCmd :: String -> GHCi Bool +deleteCmd argLine = do + deleteSwitch $ words argLine + return False + where + deleteSwitch :: [String] -> GHCi () + deleteSwitch [] = + io $ putStrLn "The delete command requires at least one argument." + -- delete all break points + deleteSwitch ("*":_rest) = discardActiveBreakPoints + deleteSwitch idents = do + mapM_ deleteOneBreak idents + where + deleteOneBreak :: String -> GHCi () + deleteOneBreak str + | all isDigit str = deleteBreak (read str) + | otherwise = return () + +-- handle the "break" command +breakCmd :: String -> GHCi Bool +breakCmd argLine = do + session <- getSession + breakSwitch session $ words argLine + +breakSwitch :: Session -> [String] -> GHCi Bool +breakSwitch _session [] = do + io $ putStrLn "The break command requires at least one argument." + return False +breakSwitch session args@(arg1:rest) + | looksLikeModule arg1 = do + mod <- wantInterpretedModule session arg1 + breakByModule mod rest + return False + | otherwise = do + (toplevel, _) <- io $ GHC.getContext session + case toplevel of + (mod : _) -> breakByModule mod args + [] -> do + io $ putStrLn "Cannot find default module for breakpoint." + io $ putStrLn "Perhaps no modules are loaded for debugging?" + return False + where + -- Todo there may be a nicer way to test this + looksLikeModule :: String -> Bool + looksLikeModule [] = False + looksLikeModule (x:_) = isUpper x + +wantInterpretedModule :: Session -> String -> GHCi Module +wantInterpretedModule session str = do + modl <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing + is_interpreted <- io (GHC.moduleIsInterpreted session modl) + when (not is_interpreted) $ + throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted")) + return modl + +breakByModule :: Module -> [String] -> GHCi () +breakByModule mod args@(arg1:rest) + | all isDigit arg1 = do -- looks like a line number + breakByModuleLine mod (read arg1) rest + | looksLikeVar arg1 = do + -- break by a function definition + io $ putStrLn "Break by function definition not implemented." + | otherwise = io $ putStrLn "Invalid arguments to break command." + where + -- Todo there may be a nicer way to test this + looksLikeVar :: String -> Bool + looksLikeVar [] = False + looksLikeVar (x:_) = isLower x || x `elem` "~!@#$%^&*-+" + +breakByModuleLine :: Module -> Int -> [String] -> GHCi () +breakByModuleLine mod line args + | [] <- args = findBreakAndSet mod $ findBreakByLine line + | [col] <- args, all isDigit col = + findBreakAndSet mod $ findBreakByCoord (line, read col) + | otherwise = io $ putStrLn "Invalid arguments to break command." + +findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi () +findBreakAndSet mod lookupTickTree = do + tickArray <- getTickArray mod + (breakArray, _) <- getModBreak mod + case lookupTickTree tickArray of + Nothing -> io $ putStrLn $ "No breakpoints found at that location." + Just (tick, span) -> do + success <- io $ setBreakFlag True breakArray tick + session <- getSession + unqual <- io $ GHC.getPrintUnqual session + if success + then do + (alreadySet, nm) <- + recordBreak $ BreakLocation + { breakModule = mod + , breakLoc = span + , breakTick = tick + } + io $ printForUser stdout unqual $ + text "Breakpoint " <> ppr nm <> + if alreadySet + then text " was already set at " <> ppr span + else text " activated at " <> ppr span + else do + str <- showForUser $ text "Breakpoint could not be activated at" + <+> ppr span + io $ putStrLn str + +-- When a line number is specified, the current policy for choosing +-- the best breakpoint is this: +-- - the leftmost complete subexpression on the specified line, or +-- - the leftmost subexpression starting on the specified line, or +-- - the rightmost subexpression enclosing the specified line +-- +findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan) +findBreakByLine line arr = + listToMaybe (sortBy leftmost complete) `mplus` + listToMaybe (sortBy leftmost incomplete) `mplus` + listToMaybe (sortBy rightmost ticks) + where + ticks = arr ! line + + starts_here = [ tick | tick@(nm,span) <- ticks, + srcSpanStartLine span == line ] + + (complete,incomplete) = partition ends_here starts_here + where ends_here (nm,span) = srcSpanEndLine span == line + +findBreakByCoord :: (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan) +findBreakByCoord (line, col) arr = + listToMaybe (sortBy rightmost contains) + where + ticks = arr ! line + + -- the ticks that span this coordinate + contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col) ] + +leftmost (_,a) (_,b) = a `compare` b +rightmost (_,a) (_,b) = b `compare` a + +spans :: SrcSpan -> (Int,Int) -> Bool +spans span (l,c) = srcSpanStart span <= loc && loc <= srcSpanEnd span + where loc = mkSrcLoc (srcSpanFile span) l c + + +-- -------------------------------------------------------------------------- +-- Tick arrays + +getTickArray :: Module -> GHCi TickArray +getTickArray modl = do + st <- getGHCiState + let arrmap = tickarrays st + case lookupModuleEnv arrmap modl of + Just arr -> return arr + Nothing -> do + (breakArray, ticks) <- getModBreak modl + let arr = mkTickArray (assocs ticks) + setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr} + return arr + +discardTickArrays :: GHCi () +discardTickArrays = do + st <- getGHCiState + setGHCiState st{tickarrays = emptyModuleEnv} + +mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray +mkTickArray ticks + = accumArray (flip (:)) [] (1, max_line) + [ (line, (nm,span)) | (nm,span) <- ticks, + line <- srcSpanLines span ] + where + max_line = maximum (map srcSpanEndLine (map snd ticks)) + srcSpanLines span = [ srcSpanStartLine span .. srcSpanEndLine span ] + +getModBreak :: Module -> GHCi (BreakArray, Array Int SrcSpan) +getModBreak mod = do + session <- getSession + Just mod_info <- io $ GHC.getModuleInfo session mod + let modBreaks = GHC.modInfoModBreaks mod_info + let array = GHC.modBreaks_flags modBreaks + let ticks = GHC.modBreaks_locs modBreaks + return (array, ticks) + +lookupModule :: Session -> String -> GHCi Module +lookupModule session modName + = io (GHC.findModule session (GHC.mkModuleName modName) Nothing) + +setBreakFlag :: Bool -> BreakArray -> Int -> IO Bool +setBreakFlag toggle array index + | toggle = setBreakOn array index + | otherwise = setBreakOff array index + + +{- these should probably go to the GHC API at some point -} +enableBreakPoint :: Session -> Module -> Int -> IO () +enableBreakPoint session mod index = return () + +disableBreakPoint :: Session -> Module -> Int -> IO () +disableBreakPoint session mod index = return () + +activeBreakPoints :: Session -> IO [(Module,Int)] +activeBreakPoints session = return [] + +enableSingleStep :: Session -> IO () +enableSingleStep session = return () + +disableSingleStep :: Session -> IO () +disableSingleStep session = return ()