X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=ec1f4bf98e892080e81cd0c69650f2ea552883ab;hb=9efeaae7dd6d720b0f44b0a73ed4881d7eb41034;hp=4494f229e22661d45a5ba619d3b9c03077cb6906;hpb=6a13ee14f604f5ab0178b326c24590402ee66615;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 4494f22..ec1f4bf 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -6,7 +6,14 @@ -- (c) The GHC Team 2005-2006 -- ----------------------------------------------------------------------------- -module InteractiveUI ( interactiveUI ) 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/Commentary/CodingStyle#Warnings +-- for details + +module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where #include "HsVersions.h" @@ -19,14 +26,16 @@ import qualified GHC import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..), Type, Module, ModuleName, TyThing(..), Phase, BreakIndex, SrcSpan, Resume, SingleStep ) +import PprTyThing import DynFlags import Packages import PackageConfig import UniqFM -import PprTyThing +import HscTypes ( implicitTyThings ) import Outputable hiding (printForUser) import Module -- for ModuleEnv import Name +import SrcLoc -- Other random utilities import Digraph @@ -36,6 +45,8 @@ import Config import StaticFlags import Linker import Util +import NameSet +import Maybes ( orElse ) import FastString #ifndef mingw32_HOST_OS @@ -65,6 +76,7 @@ import System.Exit ( exitWith, ExitCode(..) ) import System.Directory import System.IO import System.IO.Error as IO +import System.IO.Unsafe import Data.Char import Data.Dynamic import Data.Array @@ -81,16 +93,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" - -ghciShortWelcomeMsg = - "GHCi, version " ++ cProjectVersion ++ - ": http://www.haskell.org/ghc/ :? for help" +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 @@ -133,6 +138,8 @@ 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), @@ -164,8 +171,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" ++ @@ -188,6 +195,8 @@ helpText = " :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"++ @@ -366,11 +375,6 @@ runGHCi paths maybe_expr = do -- initialise the console if necessary io setUpConsole - let msg = if dopt Opt_ShortGhciBanner dflags - then ghciShortWelcomeMsg - else ghciWelcomeMsg - when (verbosity dflags >= 1) $ io $ putStrLn msg - -- enter the interactive loop interactiveLoop is_tty show_prompt Just expr -> do @@ -471,7 +475,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 @@ -566,28 +570,33 @@ runStmt stmt step session <- getSession result <- io $ withProgName (progname st) $ withArgs (args st) $ GHC.runStmt session stmt step - afterRunStmt result + afterRunStmt (const True) result -afterRunStmt :: GHC.RunResult -> GHCi Bool +--afterRunStmt :: GHC.RunResult -> GHCi Bool -- False <=> the statement failed to compile -afterRunStmt (GHC.RunException e) = throw e -afterRunStmt run_result = do - session <- getSession +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 -> do - resumes <- io $ GHC.getResumeContext session - printForUser $ ptext SLIT("Stopped at") <+> - ppr (GHC.resumeSpan (head resumes)) - printTypeOfNames session names - maybe (return ()) runBreakCmd mb_info - -- run the command set with ":set stop " - st <- getGHCiState - enqueueCommands [stop st] - return () + 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 @@ -597,6 +606,19 @@ afterRunStmt run_result = do 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) + let ids = [id | AnId id <- tythings] + terms <- mapM (io . GHC.obtainTermB session 10 False) ids + docs_terms <- mapM (io . showTerm session) terms + dflags <- getDynFlags + let pefas = dopt Opt_PrintExplicitForalls dflags + printForUser $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts) + (map (pprTyThing pefas . AnId) ids) + docs_terms + runBreakCmd :: GHC.BreakInfo -> GHCi () runBreakCmd info = do let mod = GHC.breakInfo_module info @@ -611,9 +633,11 @@ runBreakCmd info = do printTypeOfNames :: Session -> [Name] -> GHCi () printTypeOfNames session names - = mapM_ (printTypeOfName session) $ sortBy compareFun 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) - compareFun n1 n2 = compareWith n1 `compare` compareWith n2 printTypeOfName :: Session -> Name -> GHCi () printTypeOfName session n @@ -638,7 +662,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) @@ -658,6 +682,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 @@ -673,30 +711,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 @@ -863,7 +901,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 ( @@ -879,8 +917,6 @@ checkModule m = do reloadModule :: String -> GHCi () reloadModule m = do - io (revertCAFs) -- always revert CAFs on reload. - discardActiveBreakPoints session <- getSession doLoad session $ if null m then LoadAllTargets else LoadUpTo (GHC.mkModuleName m) @@ -897,10 +933,9 @@ doLoad session howmuch = do afterLoad ok session = do io (revertCAFs) -- always revert CAFs on load. discardTickArrays - 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') + loaded_mods <- getLoadedModules session + setContextAfterLoad session loaded_mods + modulesLoadedMsg ok (map GHC.ms_mod_name loaded_mods) setContextAfterLoad session [] = do prel_mod <- getPrelude @@ -956,8 +991,10 @@ typeOfExpr str maybe_ty <- io (GHC.exprType cms str) case maybe_ty of Nothing -> return () - Just ty -> do ty' <- cleanType ty - printForUser $ text str <> text " :: " <> ppr ty' + Just ty -> do dflags <- getDynFlags + let pefas = dopt Opt_PrintExplicitForalls dflags + printForUser $ text str <+> dcolon + <+> pprTypeForUser pefas ty kindOfType :: String -> GHCi () kindOfType str @@ -965,7 +1002,7 @@ kindOfType str maybe_ty <- io (GHC.typeKind cms str) case maybe_ty of Nothing -> return () - Just ty -> printForUser $ text str <> text " :: " <> ppr ty + Just ty -> printForUser $ text str <+> dcolon <+> ppr ty quit :: String -> GHCi Bool quit _ = return True @@ -1003,16 +1040,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: @@ -1249,31 +1286,30 @@ showCmd str = do showModules = do session <- getSession - let show_one ms = do m <- io (GHC.showModule session ms) - io (putStrLn m) + loaded_mods <- getLoadedModules session + -- we want *loaded* modules only, see #1734 + let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m) + mapM_ show_one loaded_mods + +getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary] +getLoadedModules session = do graph <- io (GHC.getModuleGraph session) - mapM_ show_one graph + filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph showBindings = do s <- getSession unqual <- io (GHC.getPrintUnqual s) bindings <- io (GHC.getBindings s) - mapM_ printTyThing bindings + mapM_ printTyThing $ sortBy compareTyThings bindings return () +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' -printTyThing _ = 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 - then return ty - else return $! GHC.dropForAlls ty +printTyThing tyth = do dflags <- getDynFlags + let pefas = dopt Opt_PrintExplicitForalls dflags + printForUser (pprTyThing pefas tyth) showBkptTable :: GHCi () showBkptTable = do @@ -1301,10 +1337,11 @@ completeNone w = return [] completeWord :: String -> Int -> Int -> IO (Maybe (String, [String])) completeWord w start end = do line <- Readline.getLineBuffer - case w of + let line_words = words (dropWhile isSpace line) + case w of ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w _other - | Just c <- is_cmd line -> do + | ((':':c) : _) <- line_words -> do maybe_cmd <- lookupCommand c let (n,w') = selectWord (words' 0 line) case maybe_cmd of @@ -1313,6 +1350,8 @@ completeWord w start end = do Just (_,_,True,complete) -> let complete' w = do rets <- complete w return (map (drop n) rets) in wrapCompleter complete' w' + | ("import" : _) <- line_words -> + wrapCompleter completeModule w | otherwise -> do --printf "complete %s, start = %d, end = %d\n" w start end wrapCompleter completeIdentifier w @@ -1328,9 +1367,6 @@ completeWord w start end = do | offset+length x >= start = (start-offset,take (end-offset) x) | otherwise = selectWord xs -is_cmd line - | ((':':w) : _) <- words (dropWhile isSpace line) = Just w - | otherwise = Nothing completeCmd w = do cmds <- readIORef commands @@ -1504,14 +1540,17 @@ setUpConsole = do -- similarly for characters we write to the console. -- -- At the moment, GHCi pretends all input is Latin-1. In the - -- future we should support UTF-8, but for now we set the code pages - -- to Latin-1. + -- future we should support UTF-8, but for now we set the code + -- pages to Latin-1. Doing it this way does lead to problems, + -- however: see bug #1649. -- -- It seems you have to set the font in the console window to -- a Unicode font in order for output to work properly, -- otherwise non-ASCII characters are mapped wrongly. sigh. -- (see MSDN for SetConsoleOutputCP()). -- + -- This call has been known to hang on some machines, see bug #1483 + -- setConsoleCP 28591 -- ISO Latin-1 setConsoleOutputCP 28591 -- ISO Latin-1 #endif @@ -1529,21 +1568,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 () @@ -1585,10 +1658,18 @@ 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 @@ -1648,14 +1729,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 @@ -1694,9 +1778,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 @@ -1711,8 +1795,8 @@ findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray findBreakByCoord mb_file (line, col) arr | not (inRange (bounds arr) line) = Nothing | otherwise = - listToMaybe (sortBy rightmost contains) `mplus` - listToMaybe (sortBy leftmost_smallest after_here) + listToMaybe (sortBy (rightmost `on` snd) contains ++ + sortBy (leftmost_smallest `on` snd) after_here) where ticks = arr ! line @@ -1728,30 +1812,20 @@ findBreakByCoord mb_file (line, col) arr 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) - `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 - --- 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" +-- For now, use ANSI bold on terminals that we know support it. +-- Otherwise, we add a line of carets under the active expression instead. +-- In particular, on Windows and when running the testsuite (which sets +-- TERM to vt100 for other reasons) we get carets. +-- We really ought to use a proper termcap/terminfo library. +do_bold :: Bool +do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"] + where mTerm = System.Environment.getEnv "TERM" + `Exception.catch` \e -> return "TERM not set" + +start_bold :: String +start_bold = "\ESC[1m" +end_bold :: String +end_bold = "\ESC[0m" listCmd :: String -> GHCi () listCmd "" = do @@ -1808,8 +1882,7 @@ listModuleLine modl line = do -- If the highlight flag is True, also highlight the span using -- start_bold/end_bold. listAround span do_highlight = do - pwd <- getEnv "PWD" - contents <- BS.readFile (pwd `joinFileName` unpackFS file) + contents <- BS.readFile (unpackFS file) let lines = BS.split '\n' contents these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $ @@ -1818,10 +1891,10 @@ listAround span do_highlight = do line_nos = [ fst_line .. ] highlighted | do_highlight = zipWith highlight line_nos these_lines - | otherwise = these_lines + | otherwise = [\p -> BS.concat[p,l] | l <- these_lines] bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ] - prefixed = zipWith BS.append bs_line_nos highlighted + prefixed = zipWith ($) highlighted bs_line_nos -- BS.putStrLn (BS.join (BS.pack "\n") prefixed) where @@ -1838,32 +1911,33 @@ listAround span do_highlight = do highlight | do_bold = highlight_bold | otherwise = highlight_carets - highlight_bold no line + highlight_bold no line prefix | 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 [prefix, 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 [prefix, a, BS.pack start_bold, b] | no == line2 = let (a,b) = BS.splitAt col2 line in - BS.concat [a, end_bold, b] - | otherwise = line + BS.concat [prefix, a, BS.pack end_bold, b] + | otherwise = BS.concat [prefix, line] - highlight_carets no line + highlight_carets no line prefix | no == line1 && no == line2 - = BS.concat [line, nl, indent, BS.replicate col1 ' ', + = BS.concat [prefix, 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) '^'] + = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl, + prefix, line] | no == line2 - = BS.concat [line, nl, indent, BS.replicate col2 '^'] - | otherwise = line + = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ', + BS.pack "^^"] + | otherwise = BS.concat [prefix, line] where - indent = BS.pack " " + indent = BS.pack (" " ++ replicate (length (show no)) ' ') nl = BS.singleton '\n' -- --------------------------------------------------------------------------