X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=91ce0f444f60af516a6027a45f02b6ef5c9b33f5;hb=98b004a37fdfe0347eaaf379789ac0d595f70f25;hp=4fb1ad34fe5ffc01606a0bf31a107667c44c096b;hpb=4a6a64b9f9437e40706368bf288d62f1aa5060a5;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 4fb1ad3..91ce0f4 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -109,7 +109,8 @@ builtin_commands = [ ("browse", keepGoing browseCmd, False, completeModule), ("cd", keepGoing changeDirectory, False, completeFilename), ("check", keepGoing checkModule, False, completeHomeModule), - ("continue", continueCmd, False, completeNone), + ("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), @@ -132,9 +133,9 @@ builtin_commands = [ ("set", keepGoing setCmd, True, completeSetOptions), ("show", keepGoing showCmd, False, completeNone), ("sprint", keepGoing sprintCmd, False, completeIdentifier), - ("step", stepCmd, False, completeIdentifier), + ("step", keepGoing stepCmd, False, completeIdentifier), ("type", keepGoing typeOfExpr, False, completeIdentifier), - ("trace", traceCmd, False, completeIdentifier), + ("trace", keepGoing traceCmd, False, completeIdentifier), ("undef", keepGoing undefineMacro, False, completeMacro), ("unset", keepGoing unsetOptions, True, completeSetOptions) ] @@ -154,6 +155,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"++ " :ctags [] create tags file for Vi (default: \"tags\")\n" ++ " :def define a command :\n" ++ " :edit edit file\n" ++ @@ -184,11 +186,11 @@ 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"++ " :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" ++ @@ -287,7 +289,8 @@ interactiveUI session srcs maybe_expr = do prelude = prel_mod, break_ctr = 0, breaks = [], - tickarrays = emptyModuleEnv + tickarrays = emptyModuleEnv, + cmdqueue = [] } #ifdef USE_READLINE @@ -446,17 +449,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) @@ -514,17 +509,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 @@ -552,54 +561,47 @@ runStmt stmt step result <- io $ withProgName (progname st) $ withArgs (args st) $ GHC.runStmt session stmt step afterRunStmt result - return (isRunResultOk result) -afterRunStmt :: GHC.RunResult -> GHCi (Maybe (Bool,[Name])) +afterRunStmt :: GHC.RunResult -> GHCi Bool + -- False <=> the statement failed to compile +afterRunStmt (GHC.RunException e) = throw e 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 - + case run_result of + GHC.RunOk names -> do + show_types <- isOptionSet ShowType + when show_types $ mapM_ (showTypeOfName session) names + GHC.RunBreak _ names mb_info -> do + resumes <- io $ GHC.getResumeContext session + printForUser $ ptext SLIT("Stopped at") <+> + ppr (GHC.resumeSpan (head resumes)) + mapM_ (showTypeOfName session) names + maybe (return ()) runBreakCmd mb_info + -- run the command set with ":set stop " + st <- getGHCiState + enqueueCommands [stop st] + 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 + return (case run_result of GHC.RunOk _ -> True; _ -> False) +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 showTypeOfName :: Session -> Name -> GHCi () showTypeOfName session n @@ -693,8 +695,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 @@ -767,7 +768,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 @@ -782,6 +784,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) @@ -794,6 +807,7 @@ loadModule' files = do session <- getSession -- unload first + discardActiveBreakPoints io (GHC.setTargets session []) io (GHC.load session LoadAllTargets) @@ -809,9 +823,7 @@ loadModule' files = do -- as a ToDo for now. io (GHC.setTargets session targets) - ok <- io (GHC.load session LoadAllTargets) - afterLoad ok session - return ok + doLoad session LoadAllTargets checkModule :: String -> GHCi () checkModule m = do @@ -834,19 +846,28 @@ checkModule m = do reloadModule :: String -> GHCi () reloadModule "" = do io (revertCAFs) -- always revert CAFs on reload. + discardActiveBreakPoints session <- getSession - ok <- io (GHC.load session LoadAllTargets) - afterLoad ok session + doLoad session LoadAllTargets + return () reloadModule m = do io (revertCAFs) -- always revert CAFs on reload. + discardActiveBreakPoints session <- getSession - ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m))) + doLoad session (LoadUpTo (GHC.mkModuleName m)) + return () + +doLoad session 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 + return ok afterLoad ok session = do io (revertCAFs) -- always revert CAFs on load. discardTickArrays - discardActiveBreakPoints graph <- io (GHC.getModuleGraph session) graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph setContextAfterLoad session graph' @@ -1075,6 +1096,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 } @@ -1460,26 +1494,23 @@ pprintCommand bind force str = do session <- getSession io $ pprintClosureCommand session bind force str -stepCmd :: String -> GHCi Bool +stepCmd :: String -> GHCi () stepCmd [] = doContinue GHC.SingleStep -stepCmd expression = runStmt expression GHC.SingleStep +stepCmd expression = do runStmt expression GHC.SingleStep; return () -traceCmd :: String -> GHCi Bool +traceCmd :: String -> GHCi () traceCmd [] = doContinue GHC.RunAndLogSteps -traceCmd expression = runStmt expression GHC.RunAndLogSteps +traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return () -continueCmd :: String -> GHCi Bool -continueCmd [] = doContinue GHC.RunToCompletion -continueCmd other = do - io $ putStrLn "The continue command accepts no arguments." - return False +continueCmd :: String -> GHCi () +continueCmd = noArgs $ doContinue GHC.RunToCompletion -doContinue :: SingleStep -> GHCi Bool +doContinue :: SingleStep -> GHCi () doContinue step = do session <- getSession runResult <- io $ GHC.resume session step afterRunStmt runResult - return False + return () abandonCmd :: String -> GHCi () abandonCmd = noArgs $ do @@ -1532,8 +1563,7 @@ backCmd = noArgs $ do mapM_ (showTypeOfName s) names -- run the command set with ":set stop " st <- getGHCiState - runCommand (stop st) - return () + enqueueCommands [stop st] forwardCmd :: String -> GHCi () forwardCmd = noArgs $ do @@ -1545,8 +1575,7 @@ forwardCmd = noArgs $ do mapM_ (showTypeOfName 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 () @@ -1570,7 +1599,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)) @@ -1610,6 +1639,7 @@ findBreakAndSet mod lookupTickTree = do { breakModule = mod , breakLoc = span , breakTick = tick + , onBreakCmd = "" } printForUser $ text "Breakpoint " <> ppr nm <> @@ -1678,7 +1708,8 @@ 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 @@ -1692,7 +1723,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) @@ -1793,7 +1824,7 @@ mkTickArray ticks [ (line, (nm,span)) | (nm,span) <- ticks, line <- srcSpanLines span ] where - max_line = maximum (map GHC.srcSpanEndLine (map snd ticks)) + max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks)) srcSpanLines span = [ GHC.srcSpanStartLine span .. GHC.srcSpanEndLine span ]