X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=dddbb347038f7e5c62bbe84d7df644217e2d1b1a;hb=ad94d40948668032189ad22a0ad741ac1f645f50;hp=33030bcfeafcffc2ca83d1ab96a9b054f5ab2732;hpb=f03a7287057767143926fdba55bac2325a47ca86;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 33030bc..dddbb34 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -6,10 +6,14 @@ -- (c) The GHC Team 2005-2006 -- ----------------------------------------------------------------------------- -module InteractiveUI ( - interactiveUI, - ghciWelcomeMsg - ) where +{-# 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/CodingStyle#Warnings +-- for details + +module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where #include "HsVersions.h" @@ -21,14 +25,17 @@ import Debugger import qualified GHC import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..), Type, Module, ModuleName, TyThing(..), Phase, - BreakIndex, Name, SrcSpan, Resume, SingleStep ) + BreakIndex, SrcSpan, Resume, SingleStep ) import DynFlags import Packages import PackageConfig import UniqFM +import HscTypes ( implicitTyThings ) import PprTyThing import Outputable hiding (printForUser) import Module -- for ModuleEnv +import Name +import SrcLoc -- Other random utilities import Digraph @@ -38,13 +45,12 @@ import Config import StaticFlags import Linker import Util +import NameSet +import Maybes ( orElse ) import FastString #ifndef mingw32_HOST_OS -import System.Posix -#if __GLASGOW_HASKELL__ > 504 - hiding (getEnv) -#endif +import System.Posix hiding (getEnv) #else import GHC.ConsoleHandler ( flushConsole ) import System.Win32 ( setConsoleCP, setConsoleOutputCP ) @@ -86,12 +92,9 @@ import System.Posix.Internals ( setNonBlockingFD ) ----------------------------------------------------------------------------- -ghciWelcomeMsg = - " ___ ___ _\n"++ - " / _ \\ /\\ /\\/ __(_)\n"++ - " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++ - "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++ - "\\____/\\/ /_/\\____/|_| Type :? for help.\n" +ghciWelcomeMsg :: String +ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++ + ": http://www.haskell.org/ghc/ :? for help" type Command = (String, String -> GHCi Bool, Bool, String -> IO [String]) cmdName (n,_,_,_) = n @@ -110,6 +113,7 @@ builtin_commands = [ ("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), @@ -133,11 +137,12 @@ builtin_commands = [ ("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), - ("where", keepGoing whereCmd, True, completeNone) + ("unset", keepGoing unsetOptions, True, completeSetOptions) ] keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool) @@ -155,6 +160,7 @@ helpText = " :add ... add module(s) to the current target set\n" ++ " :browse [*] display the names defined by \n" ++ " :cd change directory to \n" ++ + " :cmd run the commands returned by ::IO String\n" ++ " :ctags [] create tags file for Vi (default: \"tags\")\n" ++ " :def define a command :\n" ++ " :edit edit file\n" ++ @@ -164,8 +170,8 @@ helpText = " :info [ ...] display information about the given names\n" ++ " :kind show the kind of \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" ++ + " :module [+/-] [*] ... set the context for expression evaluation\n" ++ " :quit exit GHCi\n" ++ " :reload reload the current module set\n" ++ " :type show the type of \n" ++ @@ -185,11 +191,13 @@ helpText = " :forward go forward in the history (after :back)\n" ++ " :history [] show the last items in the history (after :trace)\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"++ + " :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"++ - " :sprint [ ...] simplifed version of :print\n" ++ "\n" ++ " -- Commands for changing settings:\n" ++ @@ -243,21 +251,22 @@ interactiveUI session srcs maybe_expr = do newStablePtr stdout newStablePtr stderr - -- Initialise buffering for the *interpreted* I/O system + -- Initialise buffering for the *interpreted* I/O system initInterpBuffering session when (isNothing maybe_expr) $ do - -- Only for GHCi (not runghc and ghc -e): - -- Turn buffering off for the compiled program's stdout/stderr - turnOffBuffering - -- Turn buffering off for GHCi's stdout - hFlush stdout - hSetBuffering stdout NoBuffering - -- We don't want the cmd line to buffer any input that might be - -- intended for the program, so unbuffer stdin. - hSetBuffering stdin NoBuffering - - -- initial context is just the Prelude + -- Only for GHCi (not runghc and ghc -e): + + -- Turn buffering off for the compiled program's stdout/stderr + turnOffBuffering + -- Turn buffering off for GHCi's stdout + hFlush stdout + hSetBuffering stdout NoBuffering + -- We don't want the cmd line to buffer any input that might be + -- 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] @@ -288,7 +297,8 @@ interactiveUI session srcs maybe_expr = do prelude = prel_mod, break_ctr = 0, breaks = [], - tickarrays = emptyModuleEnv + tickarrays = emptyModuleEnv, + cmdqueue = [] } #ifdef USE_READLINE @@ -348,28 +358,28 @@ runGHCi paths maybe_expr = do let show_prompt = verbosity dflags > 0 || is_tty case maybe_expr of - Nothing -> + Nothing -> do #if defined(mingw32_HOST_OS) - -- The win32 Console API mutates the first character of + -- The win32 Console API mutates the first character of -- type-ahead when reading from it in a non-buffered manner. Work -- around this by flushing the input buffer of type-ahead characters, -- but only if stdin is available. flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin)) - case flushed of - Left err | isDoesNotExistError err -> return () - | otherwise -> io (ioError err) - Right () -> return () + case flushed of + Left err | isDoesNotExistError err -> return () + | otherwise -> io (ioError err) + Right () -> return () #endif - -- initialise the console if necessary - io setUpConsole + -- initialise the console if necessary + io setUpConsole - -- enter the interactive loop - interactiveLoop is_tty show_prompt - Just expr -> do - -- just evaluate the expression we were given - runCommandEval expr - return () + -- enter the interactive loop + interactiveLoop is_tty show_prompt + Just expr -> do + -- just evaluate the expression we were given + runCommandEval expr + return () -- and finally, exit io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi." @@ -447,17 +457,9 @@ fileLoop hdl show_prompt = do Right l -> case removeSpaces l of "" -> fileLoop hdl show_prompt - l -> do quit <- runCommand l + l -> do quit <- runCommands l if quit then return () else fileLoop hdl show_prompt -stringLoop :: [String] -> GHCi Bool{-True: we quit-} -stringLoop [] = return False -stringLoop (s:ss) = do - case removeSpaces s of - "" -> stringLoop ss - l -> do quit <- runCommand l - if quit then return True else stringLoop ss - mkPrompt = do session <- getSession (toplevs,exports) <- io (GHC.getContext session) @@ -472,7 +474,7 @@ mkPrompt = do then return (brackets (ppr (GHC.resumeSpan r)) <> space) else do let hist = GHC.resumeHistory r !! (ix-1) - span <- io $ GHC.getHistorySpan session hist + span <- io$ GHC.getHistorySpan session hist return (brackets (ppr (negate ix) <> char ':' <+> ppr span) <> space) let @@ -515,17 +517,31 @@ readlineLoop = do "" -> readlineLoop l -> do io (addHistory l) - quit <- runCommand l + quit <- runCommands l if quit then return () else readlineLoop #endif -runCommand :: String -> GHCi Bool -runCommand c = ghciHandle handler (doCommand c) - where - doCommand (':' : command) = specialCommand command - doCommand stmt - = do timeIt $ runStmt stmt GHC.RunToCompletion - return False +runCommands :: String -> GHCi Bool +runCommands cmd = do + q <- ghciHandle handler (doCommand cmd) + if q then return True else runNext + 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 + +enqueueCommands :: [String] -> GHCi () +enqueueCommands cmds = do + st <- getGHCiState + 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 @@ -547,67 +563,86 @@ runCommandEval c = ghciHandle handleEval (doCommand c) 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 - afterRunStmt result - return (isRunResultOk result) + afterRunStmt (const True) result -afterRunStmt :: GHC.RunResult -> GHCi (Maybe (Bool,[Name])) -afterRunStmt run_result = do - mb_result <- switchOnRunResult run_result - -- possibly print the type and revert CAFs after evaluating an expression - show_types <- isOptionSet ShowType - session <- getSession - case mb_result of - Nothing -> return () - Just (is_break,names) -> - when (is_break || show_types) $ - mapM_ (showTypeOfName session) names - +--afterRunStmt :: GHC.RunResult -> GHCi Bool + -- False <=> the statement failed to compile +afterRunStmt _ (GHC.RunException e) = throw e +afterRunStmt step_here run_result = do + session <- getSession + resumes <- io $ GHC.getResumeContext session + case run_result of + GHC.RunOk names -> do + show_types <- isOptionSet ShowType + when show_types $ printTypeOfNames session names + GHC.RunBreak _ names mb_info + | isNothing mb_info || + step_here (GHC.resumeSpan $ head resumes) -> do + printForUser $ ptext SLIT("Stopped at") <+> + ppr (GHC.resumeSpan $ head resumes) +-- printTypeOfNames session names + printTypeAndContentOfNames session names + maybe (return ()) runBreakCmd mb_info + -- run the command set with ":set stop " + st <- getGHCiState + enqueueCommands [stop st] + return () + | otherwise -> io(GHC.resume session GHC.SingleStep) >>= + afterRunStmt step_here >> return () + _ -> return () + flushInterpBuffers io installSignalHandlers b <- isOptionSet RevertCAFs io (when b revertCAFs) - return mb_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) = do - session <- getSession - Just mod_info <- io $ GHC.getModuleInfo session (GHC.breakInfo_module info) - let modBreaks = GHC.modInfoModBreaks mod_info - let ticks = GHC.modBreaks_locs modBreaks - - -- display information about the breakpoint - let location = ticks ! GHC.breakInfo_number info - printForUser $ ptext SLIT("Stopped at") <+> ppr location - - -- run the command set with ":set stop " - st <- getGHCiState - runCommand (stop st) - - return (Just (True,names)) - - -isRunResultOk :: GHC.RunResult -> Bool -isRunResultOk (GHC.RunOk _) = True -isRunResultOk _ = False - - -showTypeOfName :: Session -> Name -> GHCi () -showTypeOfName session n + 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, + 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 + +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) - case maybe_tything of - Nothing -> return () - Just thing -> showTyThing thing + case maybe_tything of + Nothing -> return () + Just thing -> printTyThing thing specialCommand :: String -> GHCi Bool specialCommand ('!':str) = shellEscape (dropWhile isSpace str) @@ -625,7 +660,7 @@ lookupCommand str = do -- 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, prefixMatch str s ] of + [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of [] -> return Nothing c:_ -> return (Just c) @@ -645,6 +680,20 @@ getCurrentBreakSpan = do span <- io $ GHC.getHistorySpan session hist return (Just span) +getCurrentBreakModule :: GHCi (Maybe Module) +getCurrentBreakModule = do + session <- getSession + resumes <- io $ GHC.getResumeContext session + case resumes of + [] -> return Nothing + (r:rs) -> do + let ix = GHC.resumeHistoryIx r + if ix == 0 + then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r) + else do + let hist = GHC.resumeHistory r !! (ix-1) + return $ Just $ GHC.getHistoryModule hist + ----------------------------------------------------------------------------- -- Commands @@ -660,30 +709,30 @@ info "" = throwDyn (CmdLineError "syntax: ':i '") info s = do { let names = words s ; session <- getSession ; dflags <- getDynFlags - ; let exts = dopt Opt_GlasgowExts dflags - ; mapM_ (infoThing exts session) names } + ; let pefas = dopt Opt_PrintExplicitForalls dflags + ; mapM_ (infoThing pefas session) names } where - infoThing exts session str = io $ do - names <- GHC.parseName session str - let filtered = filterOutChildren names - mb_stuffs <- mapM (GHC.getInfo session) filtered + 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 "") $ - [ pprInfo exts stuff | Just stuff <- mb_stuffs ])) + map (pprInfo pefas) filtered)) -- Filter out names whose parent is also there Good -- example is '[]', which is both a type and data -- constructor in the same type -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 --- ToDo!! - | otherwise = False - -pprInfo exts (thing, fixity, insts) - = pprTyThingInContextLoc exts thing +filterOutChildren :: (a -> TyThing) -> [a] -> [a] +filterOutChildren get_thing xs + = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)] + where + implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] + +pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc +pprInfo pefas (thing, fixity, insts) + = pprTyThingInContextLoc pefas thing $$ show_fixity fixity $$ vcat (map GHC.pprInstance insts) where @@ -694,8 +743,7 @@ pprInfo exts (thing, fixity, insts) runMain :: String -> GHCi () runMain args = do let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args)) - runCommand $ '[': ss ++ "] `System.Environment.withArgs` main" - return () + enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"] addModule :: [FilePath] -> GHCi () addModule files = do @@ -721,25 +769,47 @@ changeDirectory dir = do 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 () +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") + io $ system (cmd ++ ' ':file) + return () + +-- The user didn't specify a file so we pick one for them. +-- Our strategy is to pick the first module that failed to load, +-- or otherwise the first target. +-- +-- XXX: Can we figure out what happened if the depndecy analysis fails +-- (e.g., because the porgrammeer mistyped the name of a module)? +-- XXX: Can we figure out the location of an error to pass to the editor? +-- XXX: if we could figure out the list of errors that occured during the +-- last load/reaload, then we could start the editor focused on the first +-- of those. +chooseEditFile :: GHCi String +chooseEditFile = + do session <- getSession + let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x + + graph <- io (GHC.getModuleGraph session) + failed_graph <- filterM hasFailed graph + let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing + pick xs = case xs of + x : _ -> GHC.ml_hs_file (GHC.ms_location x) + _ -> Nothing + + case pick (order failed_graph) of + Just file -> return file + Nothing -> + do targets <- io (GHC.getTargets session) + case msum (map fromTarget targets) of + Just file -> return file + Nothing -> throwDyn (CmdLineError "No files to edit.") + + where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f + fromTarget _ = Nothing -- when would we get a module target? defineMacro :: String -> GHCi () defineMacro s = do @@ -768,7 +838,8 @@ defineMacro s = do runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool runMacro fun s = do str <- io ((unsafeCoerce# fun :: String -> IO String) s) - stringLoop (lines str) + enqueueCommands (lines str) + return False undefineMacro :: String -> GHCi () undefineMacro macro_name = do @@ -783,6 +854,17 @@ undefineMacro macro_name = do else do io (writeIORef commands (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 () loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag loadModule fs = timeIt (loadModule' fs) @@ -817,7 +899,7 @@ checkModule :: String -> GHCi () checkModule m = do let modl = GHC.mkModuleName m session <- getSession - result <- io (GHC.checkModule session modl) + result <- io (GHC.checkModule session modl False) case result of Nothing -> io $ putStrLn "Nothing" Just r -> io $ putStrLn (showSDoc ( @@ -832,17 +914,10 @@ checkModule m = do afterLoad (successIf (isJust result)) session reloadModule :: String -> GHCi () -reloadModule "" = do - io (revertCAFs) -- always revert CAFs on reload. - discardActiveBreakPoints - session <- getSession - doLoad session LoadAllTargets - return () reloadModule m = do - io (revertCAFs) -- always revert CAFs on reload. - discardActiveBreakPoints session <- getSession - doLoad session (LoadUpTo (GHC.mkModuleName m)) + doLoad session $ if null m then LoadAllTargets + else LoadUpTo (GHC.mkModuleName m) return () doLoad session howmuch = do @@ -962,16 +1037,16 @@ browseModule m exports_only = do Just mod_info -> do let names | exports_only = GHC.modInfoExports mod_info - | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info) + | otherwise = GHC.modInfoTopLevelScope mod_info + `orElse` [] - filtered = filterOutChildren names - - things <- io $ mapM (GHC.lookupName s) filtered + mb_things <- io $ mapM (GHC.lookupName s) names + let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things) dflags <- getDynFlags - let exts = dopt Opt_GlasgowExts dflags + let pefas = dopt Opt_PrintExplicitForalls dflags io (putStrLn (showSDocForUser unqual ( - vcat (map (pprTyThingInContext exts) (catMaybes things)) + vcat (map (pprTyThingInContext pefas) filtered_things) ))) -- ToDo: modInfoInstances currently throws an exception for -- package modules. When it works, we can do this: @@ -1084,6 +1159,19 @@ setEditor cmd = do st <- getGHCiState setGHCiState st{ editor = cmd } +setStop str@(c:_) | isDigit c + = do let (nm_str,rest) = break (not.isDigit) str + nm = read nm_str + st <- getGHCiState + let old_breaks = breaks st + if all ((/= nm) . fst) old_breaks + then printForUser (text "Breakpoint" <+> ppr nm <+> + text "does not exist") + else do + let new_breaks = map fn old_breaks + fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest }) + | otherwise = (i,loc) + setGHCiState st{ breaks = new_breaks } setStop cmd = do st <- getGHCiState setGHCiState st{ stop = cmd } @@ -1204,19 +1292,30 @@ showBindings = do s <- getSession unqual <- io (GHC.getPrintUnqual s) bindings <- io (GHC.getBindings s) - mapM_ showTyThing bindings + mapM_ printTyThing $ sortBy compareTyThings bindings return () -showTyThing (AnId id) = do +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) - printForUser $ ppr id <> text " :: " <> ppr ty' -showTyThing _ = return () + 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_GlasgowExts dflags + if dopt Opt_PrintExplicitForalls dflags then return ty else return $! GHC.dropForAlls ty @@ -1428,6 +1527,10 @@ wantNameFromInterpretedModule noCanDo str and_then = do [] -> return () (n:_) -> do let modl = 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) if not is_interpreted then noCanDo n $ text "module " <> ppr modl <> @@ -1470,21 +1573,55 @@ pprintCommand bind force str = do io $ pprintClosureCommand session bind force str stepCmd :: String -> GHCi () -stepCmd [] = doContinue GHC.SingleStep +stepCmd [] = doContinue (const True) GHC.SingleStep stepCmd expression = do runStmt expression GHC.SingleStep; return () +stepLocalCmd :: String -> GHCi () +stepLocalCmd [] = do + mb_span <- getCurrentBreakSpan + case mb_span of + Nothing -> stepCmd [] + Just loc -> do + Just mod <- getCurrentBreakModule + current_toplevel_decl <- enclosingTickSpan mod loc + doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep + +stepLocalCmd expression = stepCmd expression + +stepModuleCmd :: String -> GHCi () +stepModuleCmd [] = do + mb_span <- getCurrentBreakSpan + case mb_span of + Nothing -> stepCmd [] + Just loc -> do + Just span <- getCurrentBreakSpan + let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span + doContinue f GHC.SingleStep + +stepModuleCmd expression = stepCmd expression + +-- | Returns the span of the largest tick containing the srcspan given +enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan +enclosingTickSpan mod src = do + ticks <- getTickArray mod + let line = srcSpanStartLine src + ASSERT (inRange (bounds ticks) line) do + let enclosing_spans = [ span | (_,span) <- ticks ! line + , srcSpanEnd span >= srcSpanEnd src] + return . head . sortBy leftmost_largest $ enclosing_spans + traceCmd :: String -> GHCi () -traceCmd [] = doContinue GHC.RunAndLogSteps +traceCmd [] = doContinue (const True) GHC.RunAndLogSteps traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return () continueCmd :: String -> GHCi () -continueCmd = noArgs $ doContinue GHC.RunToCompletion +continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion -doContinue :: SingleStep -> GHCi () -doContinue step = do +-- doContinue :: SingleStep -> GHCi () +doContinue pred step = do session <- getSession runResult <- io $ GHC.resume session step - afterRunStmt runResult + afterRunStmt pred runResult return () abandonCmd :: String -> GHCi () @@ -1526,20 +1663,27 @@ historyCmd arg let hist = GHC.resumeHistory r (took,rest) = splitAt num hist spans <- mapM (io . GHC.getHistorySpan s) took - let nums = map (printf "-%-3d:") [(1::Int)..] - printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans))) + 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 "..." +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 - mapM_ (showTypeOfName s) names + printTypeOfNames s names -- run the command set with ":set stop " st <- getGHCiState - runCommand (stop st) - return () + enqueueCommands [stop st] forwardCmd :: String -> GHCi () forwardCmd = noArgs $ do @@ -1548,11 +1692,10 @@ forwardCmd = noArgs $ do printForUser $ (if (ix == 0) then ptext SLIT("Stopped at") else ptext SLIT("Logged breakpoint at")) <+> ppr span - mapM_ (showTypeOfName s) names + printTypeOfNames s names -- run the command set with ":set stop " st <- getGHCiState - runCommand (stop st) - return () + enqueueCommands [stop st] -- handle the "break" command breakCmd :: String -> GHCi () @@ -1576,7 +1719,7 @@ breakSwitch session args@(arg1:rest) io $ putStrLn "Perhaps no modules are loaded for debugging?" | otherwise = do -- try parsing it as an identifier wantNameFromInterpretedModule noCanDo arg1 $ \name -> do - let loc = GHC.nameSrcLoc name + let loc = GHC.srcSpanStart (GHC.nameSrcSpan name) if GHC.isGoodSrcLoc loc then findBreakAndSet (GHC.nameModule name) $ findBreakByCoord (Just (GHC.srcLocFile loc)) @@ -1591,14 +1734,17 @@ breakByModule :: Session -> Module -> [String] -> GHCi () breakByModule session mod args@(arg1:rest) | all isDigit arg1 = do -- looks like a line number breakByModuleLine mod (read arg1) rest - | otherwise = io $ putStrLn "Invalid arguments to :break" +breakByModule session mod _ + = breakSyntax breakByModuleLine :: Module -> Int -> [String] -> GHCi () breakByModuleLine mod line args | [] <- args = findBreakAndSet mod $ findBreakByLine line | [col] <- args, all isDigit col = findBreakAndSet mod $ findBreakByCoord Nothing (line, read col) - | otherwise = io $ putStrLn "Invalid arguments to :break" + | otherwise = breakSyntax + +breakSyntax = throwDyn (CmdLineError "Syntax: :break [] []") findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi () findBreakAndSet mod lookupTickTree = do @@ -1616,6 +1762,7 @@ findBreakAndSet mod lookupTickTree = do { breakModule = mod , breakLoc = span , breakTick = tick + , onBreakCmd = "" } printForUser $ text "Breakpoint " <> ppr nm <> @@ -1636,9 +1783,9 @@ findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan) findBreakByLine line arr | not (inRange (bounds arr) line) = Nothing | otherwise = - listToMaybe (sortBy leftmost_largest complete) `mplus` - listToMaybe (sortBy leftmost_smallest incomplete) `mplus` - listToMaybe (sortBy rightmost ticks) + listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus` + listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus` + listToMaybe (sortBy (rightmost `on` snd) ticks) where ticks = arr ! line @@ -1653,7 +1800,8 @@ findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray findBreakByCoord mb_file (line, col) arr | not (inRange (bounds arr) line) = Nothing | otherwise = - listToMaybe (sortBy rightmost contains) + listToMaybe (sortBy (rightmost `on` snd) contains ++ + sortBy (leftmost_smallest `on` snd) after_here) where ticks = arr ! line @@ -1665,26 +1813,31 @@ findBreakByCoord mb_file (line, col) arr | Just f <- mb_file = GHC.srcSpanFile span == f | otherwise = True + after_here = [ tick | tick@(nm,span) <- ticks, + GHC.srcSpanStartLine span == line, + GHC.srcSpanStartCol span >= col ] + +-- for now, use ANSI bold on Unixy systems. On Windows, we add a line +-- of carets under the active expression instead. The Windows console +-- doesn't support ANSI escape sequences, and most Unix terminals +-- (including xterm) do, so this is a reasonable guess until we have a +-- proper termcap/terminfo library. +#if !defined(mingw32_TARGET_OS) +do_bold = True +#else +do_bold = False +#endif -leftmost_smallest (_,a) (_,b) = a `compare` b -leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b) - `thenCmp` - (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a) -rightmost (_,a) (_,b) = b `compare` a - -spans :: SrcSpan -> (Int,Int) -> Bool -spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span - where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c - -start_bold = BS.pack "\ESC[1m" -end_bold = BS.pack "\ESC[0m" +start_bold = "\ESC[1m" +end_bold = "\ESC[0m" 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 -> io $ listAround span True + Just span | GHC.isGoodSrcSpan span -> io $ listAround span True + | otherwise -> printForUser $ text "unable to list source for" <+> ppr span listCmd str = list2 (words str) list2 [arg] | all isDigit arg = do @@ -1698,7 +1851,7 @@ list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do listModuleLine mod (read arg2) list2 [arg] = do wantNameFromInterpretedModule noCanDo arg $ \name -> do - let loc = GHC.nameSrcLoc name + let loc = GHC.srcSpanStart (GHC.nameSrcSpan name) if GHC.isGoodSrcLoc loc then do tickArray <- getTickArray (GHC.nameModule name) @@ -1759,19 +1912,36 @@ listAround span do_highlight = do | otherwise = 1 pad_after = 1 - highlight no line + highlight | do_bold = highlight_bold + | otherwise = highlight_carets + + highlight_bold no line | no == line1 && no == line2 = let (a,r) = BS.splitAt col1 line (b,c) = BS.splitAt (col2-col1) r in - BS.concat [a,start_bold,b,end_bold,c] + BS.concat [a,BS.pack start_bold,b,BS.pack end_bold,c] | no == line1 = let (a,b) = BS.splitAt col1 line in - BS.concat [a, start_bold, b] + BS.concat [a, BS.pack start_bold, b] | no == line2 = let (a,b) = BS.splitAt col2 line in - BS.concat [a, end_bold, b] + BS.concat [a, BS.pack end_bold, b] + | otherwise = line + + highlight_carets no line + | no == line1 && no == line2 + = BS.concat [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) '^'] + | no == line2 + = BS.concat [line, nl, indent, BS.replicate col2 '^'] | otherwise = line + where + indent = BS.pack " " + nl = BS.singleton '\n' -- -------------------------------------------------------------------------- -- Tick arrays