X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=dd24d5bc96fd0a2b9620de076abfa11e00c1a82d;hp=6d0a87086474f7eac97f70d8d2943352dd3f3a04;hb=407e1a2b222459f91749500258257c203c84c287;hpb=ae2b9180cbb5b48af77502c65366bec7b788482b diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 6d0a870..dd24d5b 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -6,10 +6,7 @@ -- (c) The GHC Team 2005-2006 -- ----------------------------------------------------------------------------- -module InteractiveUI ( - interactiveUI, - ghciWelcomeMsg - ) where +module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where #include "HsVersions.h" @@ -21,7 +18,7 @@ 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 @@ -29,6 +26,7 @@ import UniqFM import PprTyThing import Outputable hiding (printForUser) import Module -- for ModuleEnv +import Name -- Other random utilities import Digraph @@ -41,10 +39,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 ) @@ -86,12 +81,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 +102,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 +147,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 +178,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" ++ @@ -242,21 +236,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] @@ -348,28 +343,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." @@ -553,6 +548,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 @@ -569,13 +565,13 @@ afterRunStmt run_result = do case run_result of GHC.RunOk names -> do show_types <- isOptionSet ShowType - when show_types $ mapM_ (showTypeOfName session) names - GHC.RunBreak _ names info -> do + when show_types $ printTypeOfNames 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 - runBreakCmd info + printTypeOfNames session names + maybe (return ()) runBreakCmd mb_info -- run the command set with ":set stop " st <- getGHCiState enqueueCommands [stop st] @@ -601,12 +597,20 @@ runBreakCmd info = do | otherwise -> do enqueueCommands [cmd]; return () where cmd = onBreakCmd loc -showTypeOfName :: Session -> Name -> GHCi () -showTypeOfName session n +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) @@ -624,7 +628,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) @@ -719,25 +723,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 @@ -782,6 +808,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) @@ -816,7 +853,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 ( @@ -831,17 +868,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 @@ -1216,13 +1248,17 @@ 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 + +printTyThing :: TyThing -> GHCi () +printTyThing (AnId id) = do ty' <- cleanType (GHC.idType id) printForUser $ ppr id <> text " :: " <> ppr ty' -showTyThing _ = return () +printTyThing _ = return () -- if -fglasgow-exts is on we show the foralls, otherwise we don't. cleanType :: Type -> GHCi Type @@ -1440,6 +1476,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 <> @@ -1547,7 +1587,7 @@ 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 enqueueCommands [stop st] @@ -1559,7 +1599,7 @@ 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 enqueueCommands [stop st] @@ -1664,7 +1704,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 @@ -1676,6 +1717,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) @@ -1687,6 +1732,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" @@ -1695,7 +1751,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 @@ -1770,7 +1827,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 @@ -1784,6 +1844,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