X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=02344cf561fdbd0e7663ca66ad2eaa3fa122a40b;hb=9f589efb688f22cb0637f9c1164dd9027b4378a3;hp=3de1c7bc50862448e03d37ff57c7e9530f318c66;hpb=4da439a6b1e343fc5216d5c6bb51858c6d9aacd6;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 3de1c7b..02344cf 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -41,10 +41,7 @@ import Util 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 ) @@ -110,6 +107,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), @@ -154,6 +152,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" ++ @@ -184,11 +183,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 +286,8 @@ interactiveUI session srcs maybe_expr = do prelude = prel_mod, break_ctr = 0, breaks = [], - tickarrays = emptyModuleEnv + tickarrays = emptyModuleEnv, + cmdqueue = [] } #ifdef USE_READLINE @@ -446,17 +446,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 +506,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 @@ -546,6 +552,7 @@ 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 @@ -563,14 +570,15 @@ afterRunStmt run_result = do GHC.RunOk names -> do show_types <- isOptionSet ShowType when show_types $ mapM_ (showTypeOfName session) names - GHC.RunBreak _ names _ -> do + 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 - runCommand (stop st) + enqueueCommands [stop st] return () _ -> return () @@ -581,6 +589,17 @@ afterRunStmt run_result = do 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 @@ -674,8 +693,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 @@ -701,25 +719,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 @@ -748,7 +788,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 @@ -763,6 +804,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) @@ -812,17 +864,12 @@ 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 @@ -1064,6 +1111,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 } @@ -1408,6 +1468,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 <> @@ -1518,8 +1582,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 @@ -1531,8 +1594,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 () @@ -1556,7 +1618,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)) @@ -1596,6 +1658,7 @@ findBreakAndSet mod lookupTickTree = do { breakModule = mod , breakLoc = span , breakTick = tick + , onBreakCmd = "" } printForUser $ text "Breakpoint " <> ppr nm <> @@ -1633,7 +1696,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 contains) `mplus` + listToMaybe (sortBy leftmost_smallest after_here) where ticks = arr ! line @@ -1645,6 +1709,10 @@ 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 ] + leftmost_smallest (_,a) (_,b) = a `compare` b leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b) @@ -1656,6 +1724,17 @@ 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 +-- for now, use ANSI bold on Unixy systems. On Windows, we add a line +-- of carets under the active expression instead. The Windows console +-- doesn't support ANSI escape sequences, and most Unix terminals +-- (including xterm) do, so this is a reasonable guess until we have a +-- proper termcap/terminfo library. +#if !defined(mingw32_TARGET_OS) +do_bold = True +#else +do_bold = False +#endif + start_bold = BS.pack "\ESC[1m" end_bold = BS.pack "\ESC[0m" @@ -1664,7 +1743,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 @@ -1678,7 +1758,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) @@ -1713,7 +1793,8 @@ listModuleLine modl line = do -- If the highlight flag is True, also highlight the span using -- start_bold/end_bold. listAround span do_highlight = do - contents <- BS.readFile (unpackFS file) + pwd <- getEnv "PWD" + contents <- BS.readFile (pwd `joinFileName` unpackFS file) let lines = BS.split '\n' contents these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $ @@ -1739,7 +1820,10 @@ 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 @@ -1753,6 +1837,20 @@ listAround span do_highlight = do BS.concat [a, 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