X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=31ca03f1e2dd949add2b3977eca59e9c430fe987;hb=7f2529748488a004c1b4d748ddce0eecf71656be;hp=fd84f9dd7f1ed64c9f3ce790d07a4126cfcfddd1;hpb=b59ce959a2a107bbcf68245287e4ed508b2cb351;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index fd84f9d..31ca03f 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -6,12 +6,6 @@ -- (c) The GHC Team 2005-2006 -- ----------------------------------------------------------------------------- -{-# 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 @@ -24,14 +18,18 @@ import Debugger -- The GHC interface import qualified GHC import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..), - Type, Module, ModuleName, TyThing(..), Phase, + Module, ModuleName, TyThing(..), Phase, BreakIndex, SrcSpan, Resume, SingleStep ) +import PprTyThing import DynFlags + +#ifdef USE_READLINE import Packages import PackageConfig import UniqFM +#endif + import HscTypes ( implicitTyThings ) -import PprTyThing import Outputable hiding (printForUser) import Module -- for ModuleEnv import Name @@ -89,7 +87,9 @@ import GHC.IOBase ( IOErrorType(InvalidArgument) ) import Data.IORef ( IORef, readIORef, writeIORef ) +#ifdef USE_READLINE import System.Posix.Internals ( setNonBlockingFD ) +#endif ----------------------------------------------------------------------------- @@ -98,8 +98,11 @@ ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++ ": http://www.haskell.org/ghc/ :? for help" type Command = (String, String -> GHCi Bool, Bool, String -> IO [String]) + +cmdName :: Command -> String cmdName (n,_,_,_) = n +commands :: IORef [Command] GLOBAL_VAR(commands, builtin_commands, [Command]) builtin_commands :: [Command] @@ -152,8 +155,10 @@ keepGoing a str = a str >> return False keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool) keepGoingPaths a str = a (toArgs str) >> return False +shortHelpText :: String shortHelpText = "use :? for help.\n" +helpText :: String helpText = " Commands available from the prompt:\n" ++ "\n" ++ @@ -228,6 +233,7 @@ helpText = " :show show anything that can be set with :set (e.g. args)\n" ++ "\n" +findEditor :: IO String findEditor = do getEnv "EDITOR" `IO.catch` \_ -> do @@ -268,7 +274,8 @@ interactiveUI session srcs maybe_expr = do hSetBuffering stdin NoBuffering -- initial context is just the Prelude - prel_mod <- GHC.findModule session prel_name (Just basePackageId) + prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude") + (Just basePackageId) GHC.setContext session [] [prel_mod] #ifdef USE_READLINE @@ -308,8 +315,6 @@ interactiveUI session srcs maybe_expr = do return () -prel_name = GHC.mkModuleName "Prelude" - runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi () runGHCi paths maybe_expr = do let read_dot_files = not opt_IgnoreDotGhci @@ -324,14 +329,14 @@ runGHCi paths maybe_expr = do when (dir_ok && file_ok) $ do either_hdl <- io (IO.try (openFile "./.ghci" ReadMode)) case either_hdl of - Left e -> return () + Left _e -> return () Right hdl -> fileLoop hdl False when (read_dot_files) $ do -- Read in $HOME/.ghci either_dir <- io (IO.try (getEnv "HOME")) case either_dir of - Left e -> return () + Left _e -> return () Right dir -> do cwd <- io (getCurrentDirectory) when (dir /= cwd) $ do @@ -340,7 +345,7 @@ runGHCi paths maybe_expr = do when ok $ do either_hdl <- io (IO.try (openFile file ReadMode)) case either_hdl of - Left e -> return () + Left _e -> return () Right hdl -> fileLoop hdl False -- Perform a :load for files given on the GHCi command line @@ -386,6 +391,7 @@ runGHCi paths maybe_expr = do io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi." +interactiveLoop :: Bool -> Bool -> GHCi () interactiveLoop is_tty show_prompt = -- Ignore ^C exceptions caught here ghciHandleDyn (\e -> case e of @@ -461,6 +467,7 @@ fileLoop hdl show_prompt = do l -> do quit <- runCommands l if quit then return () else fileLoop hdl show_prompt +mkPrompt :: GHCi String mkPrompt = do session <- getSession (toplevs,exports) <- io (GHC.getContext session) @@ -469,7 +476,7 @@ mkPrompt = do context_bit <- case resumes of [] -> return empty - r:rs -> do + r:_ -> do let ix = GHC.resumeHistoryIx r if ix == 0 then return (brackets (ppr (GHC.resumeSpan r)) <> space) @@ -479,7 +486,7 @@ mkPrompt = do return (brackets (ppr (negate ix) <> char ':' <+> ppr span) <> space) let - dots | r:rs <- resumes, not (null rs) = text "... " + dots | _:rs <- resumes, not (null rs) = text "... " | otherwise = empty modules_bit = @@ -500,12 +507,8 @@ mkPrompt = do #ifdef USE_READLINE readlineLoop :: GHCi () readlineLoop = do - session <- getSession - (mod,imports) <- io (GHC.getContext session) io yield saveSession -- for use by completion - st <- getGHCiState - mb_span <- getCurrentBreakSpan prompt <- mkPrompt l <- io (readline prompt `finally` setNonBlockingFD 0) -- readline sometimes puts stdin into blocking mode, @@ -547,6 +550,7 @@ enqueueCommands cmds = do -- This version is for the GHC command-line option -e. The only difference -- from runCommand is that it catches the ExitException exception and -- exits, rather than printing out the exception. +runCommandEval :: String -> GHCi Bool runCommandEval c = ghciHandle handleEval (doCommand c) where handleEval (ExitException code) = io (exitWith code) @@ -575,6 +579,7 @@ runStmt stmt step --afterRunStmt :: GHC.RunResult -> GHCi Bool -- False <=> the statement failed to compile +afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool afterRunStmt _ (GHC.RunException e) = throw e afterRunStmt step_here run_result = do session <- getSession @@ -610,12 +615,13 @@ afterRunStmt step_here run_result = 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] + let ids = [id | AnId id <- tythings] + terms <- mapM (io . GHC.obtainTermB session 10 False) ids docs_terms <- mapM (io . showTerm session) terms - printForUser $ vcat $ zipWith (\ty cts -> ty <> text " = " <> cts) - (catMaybes docs_ty) + 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 () @@ -623,7 +629,7 @@ runBreakCmd info = do let mod = GHC.breakInfo_module info nm = GHC.breakInfo_number info st <- getGHCiState - case [ loc | (i,loc) <- breaks st, + case [ loc | (_,loc) <- breaks st, breakModule loc == mod, breakTick loc == nm ] of [] -> return () loc:_ | null cmd -> return () @@ -672,7 +678,7 @@ getCurrentBreakSpan = do resumes <- io $ GHC.getResumeContext session case resumes of [] -> return Nothing - (r:rs) -> do + (r:_) -> do let ix = GHC.resumeHistoryIx r if ix == 0 then return (Just (GHC.resumeSpan r)) @@ -687,7 +693,7 @@ getCurrentBreakModule = do resumes <- io $ GHC.getResumeContext session case resumes of [] -> return Nothing - (r:rs) -> do + (r:_) -> do let ix = GHC.resumeHistoryIx r if ix == 0 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r) @@ -700,7 +706,7 @@ getCurrentBreakModule = do noArgs :: GHCi () -> String -> GHCi () noArgs m "" = m -noArgs m _ = io $ putStrLn "This command takes no arguments" +noArgs _ _ = io $ putStrLn "This command takes no arguments" help :: String -> GHCi () help _ = io (putStr helpText) @@ -716,7 +722,7 @@ info s = do { let names = words s 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) + let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) unqual <- GHC.getPrintUnqual session putStrLn (showSDocForUser unqual $ vcat (intersperse (text "") $ @@ -921,6 +927,7 @@ reloadModule m = do else LoadUpTo (GHC.mkModuleName m) return () +doLoad :: Session -> LoadHowMuch -> GHCi SuccessFlag doLoad session howmuch = do -- turn off breakpoints before we load: we can't turn them off later, because -- the ModBreaks will have gone away. @@ -929,14 +936,15 @@ doLoad session howmuch = do afterLoad ok session return ok +afterLoad :: SuccessFlag -> Session -> GHCi () 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 -> [GHC.ModSummary] -> GHCi () setContextAfterLoad session [] = do prel_mod <- getPrelude io (GHC.setContext session [] [prel_mod]) @@ -959,7 +967,7 @@ setContextAfterLoad session ms = do = GHC.ms_mod_name summary == m summary `matches` Target (TargetFile f _) _ | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f' - summary `matches` target + _ `matches` _ = False load_this summary | m <- GHC.ms_mod summary = do @@ -991,8 +999,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 @@ -1000,7 +1010,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 @@ -1018,6 +1028,7 @@ browseCmd m = [m] | looksLikeModuleName m -> browseModule m True _ -> throwDyn (CmdLineError "syntax: :browse ") +browseModule :: String -> Bool -> GHCi () browseModule m exports_only = do s <- getSession modl <- if exports_only then lookupModule m @@ -1056,6 +1067,7 @@ browseModule m exports_only = do ----------------------------------------------------------------------------- -- Setting the module context +setContext :: String -> GHCi () setContext str | all sensible mods = fn mods | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn") @@ -1070,7 +1082,7 @@ setContext str separate :: Session -> [String] -> [Module] -> [Module] -> GHCi ([Module],[Module]) -separate session [] as bs = return (as,bs) +separate _ [] as bs = return (as,bs) separate session (('*':str):ms) as bs = do m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing b <- io $ GHC.moduleIsInterpreted session m @@ -1140,12 +1152,15 @@ setCmd str = case toArgs str of ("args":args) -> setArgs args ("prog":prog) -> setProg prog - ("prompt":prompt) -> setPrompt (after 6) - ("editor":cmd) -> setEditor (after 6) - ("stop":cmd) -> setStop (after 4) + ("prompt":_) -> setPrompt (after 6) + ("editor":_) -> setEditor (after 6) + ("stop":_) -> setStop (after 4) wds -> setOptions wds where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str +setArgs, setProg, setOptions :: [String] -> GHCi () +setEditor, setStop, setPrompt :: String -> GHCi () + setArgs args = do st <- getGHCiState setGHCiState st{ args = args } @@ -1188,11 +1203,12 @@ setPrompt value = do setOptions wds = do -- first, deal with the GHCi opts (+s, +t, etc.) - let (plus_opts, minus_opts) = partition isPlus wds + let (plus_opts, minus_opts) = partitionWith isPlus wds mapM_ setOpt plus_opts -- then, dynamic flags newDynFlags minus_opts +newDynFlags :: [String] -> GHCi () newDynFlags minus_opts = do dflags <- getDynFlags let pkg_flags = packageFlags dflags @@ -1223,7 +1239,7 @@ unsetOptions str = do -- first, deal with the GHCi opts (+s, +t, etc.) let opts = words str (minus_opts, rest1) = partition isMinus opts - (plus_opts, rest2) = partition isPlus rest1 + (plus_opts, rest2) = partitionWith isPlus rest1 if (not (null rest2)) then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'")) @@ -1237,18 +1253,22 @@ unsetOptions str no_flags <- mapM no_flag minus_opts newDynFlags no_flags -isMinus ('-':s) = True +isMinus :: String -> Bool +isMinus ('-':_) = True isMinus _ = False -isPlus ('+':s) = True -isPlus _ = False +isPlus :: String -> Either String String +isPlus ('+':opt) = Left opt +isPlus other = Right other + +setOpt, unsetOpt :: String -> GHCi () -setOpt ('+':str) +setOpt str = case strToGHCiOpt str of Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'")) Just o -> setOption o -unsetOpt ('+':str) +unsetOpt str = case strToGHCiOpt str of Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'")) Just o -> unsetOption o @@ -1267,6 +1287,7 @@ optToStr RevertCAFs = "r" -- --------------------------------------------------------------------------- -- code for `:show' +showCmd :: String -> GHCi () showCmd str = do st <- getGHCiState case words str of @@ -1282,16 +1303,22 @@ showCmd str = do ["context"] -> showContext _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]") +showModules :: GHCi () 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 :: GHCi () showBindings = do s <- getSession - unqual <- io (GHC.getPrintUnqual s) bindings <- io (GHC.getBindings s) mapM_ printTyThing $ sortBy compareTyThings bindings return () @@ -1299,26 +1326,10 @@ showBindings = 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) - 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_PrintExplicitForalls 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 @@ -1340,7 +1351,12 @@ showContext = do -- Completion completeNone :: String -> IO [String] -completeNone w = return [] +completeNone _w = return [] + +completeMacro, completeIdentifier, completeModule, + completeHomeModule, completeSetOptions, completeFilename, + completeHomeModuleOrFile + :: String -> IO [String] #ifdef USE_READLINE completeWord :: String -> Int -> Int -> IO (Maybe (String, [String])) @@ -1376,7 +1392,7 @@ completeWord w start end = do | offset+length x >= start = (start-offset,take (end-offset) x) | otherwise = selectWord xs - +completeCmd :: String -> IO [String] completeCmd w = do cmds <- readIORef commands return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds))) @@ -1430,19 +1446,18 @@ wrapCompleter fun w = do getCommonPrefix :: [String] -> String getCommonPrefix [] = "" getCommonPrefix (s:ss) = foldl common s ss - where common s "" = "" - common "" s = "" + where common _s "" = "" + common "" _s = "" common (c:cs) (d:ds) | c == d = c : common cs ds | otherwise = "" allExposedModules :: DynFlags -> [ModuleName] allExposedModules dflags - = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db)))) + = concat (map exposedModules (filter exposed (eltsUFM pkg_db))) where pkg_db = pkgIdMap (pkgState dflags) #else -completeCmd = completeNone completeMacro = completeNone completeIdentifier = completeNone completeModule = completeNone @@ -1450,7 +1465,6 @@ completeHomeModule = completeNone completeSetOptions = completeNone completeFilename = completeNone completeHomeModuleOrFile=completeNone -completeBkpt = completeNone #endif -- --------------------------------------------------------------------------- @@ -1473,6 +1487,7 @@ handler exception = do io installSignalHandlers ghciHandle handler (showException exception >> return False) +showException :: Exception -> GHCi () showException (DynException dyn) = case fromDynamic dyn of Nothing -> io (putStrLn ("*** Exception: (unknown)")) @@ -1521,6 +1536,9 @@ wantInterpretedModule str = do throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted")) return modl +wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String + -> (Name -> GHCi ()) + -> GHCi () wantNameFromInterpretedModule noCanDo str and_then = do session <- getSession names <- io $ GHC.parseName session str @@ -1549,14 +1567,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 @@ -1565,10 +1586,12 @@ setUpConsole = do -- ----------------------------------------------------------------------------- -- commands for debugger +sprintCmd, printCmd, forceCmd :: String -> GHCi () sprintCmd = pprintCommand False False printCmd = pprintCommand True False forceCmd = pprintCommand False True +pprintCommand :: Bool -> Bool -> String -> GHCi () pprintCommand bind force str = do session <- getSession io $ pprintClosureCommand session bind force str @@ -1594,7 +1617,7 @@ stepModuleCmd [] = do mb_span <- getCurrentBreakSpan case mb_span of Nothing -> stepCmd [] - Just loc -> do + Just _ -> do Just span <- getCurrentBreakSpan let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span doContinue f GHC.SingleStep @@ -1619,6 +1642,7 @@ continueCmd :: String -> GHCi () continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion -- doContinue :: SingleStep -> GHCi () +doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi () doContinue pred step = do session <- getSession runResult <- io $ GHC.resume session step @@ -1660,7 +1684,7 @@ historyCmd arg resumes <- io $ GHC.getResumeContext s case resumes of [] -> io $ putStrLn "Not stopped at a breakpoint" - (r:rs) -> do + (r:_) -> do let hist = GHC.resumeHistory r (took,rest) = splitAt num hist spans <- mapM (io . GHC.getHistorySpan s) took @@ -1673,13 +1697,14 @@ historyCmd arg (map (parens . ppr) spans))) io $ putStrLn $ if null rest then "" else "..." +bold :: SDoc -> SDoc 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 + (names, _, span) <- io $ GHC.back s printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span printTypeOfNames s names -- run the command set with ":set stop " @@ -1707,10 +1732,10 @@ breakCmd argLine = do breakSwitch :: Session -> [String] -> GHCi () breakSwitch _session [] = do io $ putStrLn "The break command requires at least one argument." -breakSwitch session args@(arg1:rest) +breakSwitch session (arg1:rest) | looksLikeModuleName arg1 = do mod <- wantInterpretedModule arg1 - breakByModule session mod rest + breakByModule mod rest | all isDigit arg1 = do (toplevel, _) <- io $ GHC.getContext session case toplevel of @@ -1731,11 +1756,11 @@ breakSwitch session args@(arg1:rest) noCanDo n why = printForUser $ text "cannot set breakpoint on " <> ppr n <> text ": " <> why -breakByModule :: Session -> Module -> [String] -> GHCi () -breakByModule session mod args@(arg1:rest) +breakByModule :: Module -> [String] -> GHCi () +breakByModule mod (arg1:rest) | all isDigit arg1 = do -- looks like a line number breakByModuleLine mod (read arg1) rest -breakByModule session mod _ +breakByModule _ _ = breakSyntax breakByModuleLine :: Module -> Int -> [String] -> GHCi () @@ -1745,6 +1770,7 @@ breakByModuleLine mod line args findBreakAndSet mod $ findBreakByCoord Nothing (line, read col) | otherwise = breakSyntax +breakSyntax :: a breakSyntax = throwDyn (CmdLineError "Syntax: :break [] []") findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi () @@ -1755,7 +1781,6 @@ findBreakAndSet mod lookupTickTree = do Nothing -> io $ putStrLn $ "No breakpoints found at that location." Just (tick, span) -> do success <- io $ setBreakFlag True breakArray tick - session <- getSession if success then do (alreadySet, nm) <- @@ -1790,11 +1815,11 @@ findBreakByLine line arr where ticks = arr ! line - starts_here = [ tick | tick@(nm,span) <- ticks, + starts_here = [ tick | tick@(_,span) <- ticks, GHC.srcSpanStartLine span == line ] (complete,incomplete) = partition ends_here starts_here - where ends_here (nm,span) = GHC.srcSpanEndLine span == line + where ends_here (_,span) = GHC.srcSpanEndLine span == line findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan) @@ -1807,14 +1832,14 @@ findBreakByCoord mb_file (line, col) arr ticks = arr ! line -- the ticks that span this coordinate - contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col), + contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col), is_correct_file span ] is_correct_file span | Just f <- mb_file = GHC.srcSpanFile span == f | otherwise = True - after_here = [ tick | tick@(nm,span) <- ticks, + after_here = [ tick | tick@(_,span) <- ticks, GHC.srcSpanStartLine span == line, GHC.srcSpanStartCol span >= col ] @@ -1824,8 +1849,9 @@ findBreakByCoord mb_file (line, col) arr -- TERM to vt100 for other reasons) we get carets. -- We really ought to use a proper termcap/terminfo library. do_bold :: Bool -do_bold = unsafePerformIO (System.Environment.getEnv "TERM") `elem` - ["xterm", "linux"] +do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"] + where mTerm = System.Environment.getEnv "TERM" + `Exception.catch` \_ -> return "TERM not set" start_bold :: String start_bold = "\ESC[1m" @@ -1841,6 +1867,7 @@ listCmd "" = do | otherwise -> printForUser $ text "unable to list source for" <+> ppr span listCmd str = list2 (words str) +list2 :: [String] -> GHCi () list2 [arg] | all isDigit arg = do session <- getSession (toplevel, _) <- io $ GHC.getContext session @@ -1886,6 +1913,7 @@ listModuleLine modl line = do -- | list a section of a source file around a particular SrcSpan. -- If the highlight flag is True, also highlight the span using -- start_bold/end_bold. +listAround :: SrcSpan -> Bool -> IO () listAround span do_highlight = do contents <- BS.readFile (unpackFS file) let @@ -1901,7 +1929,7 @@ listAround span do_highlight = do bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ] prefixed = zipWith ($) highlighted bs_line_nos -- - BS.putStrLn (BS.join (BS.pack "\n") prefixed) + BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed) where file = GHC.srcSpanFile span line1 = GHC.srcSpanStartLine span @@ -1955,7 +1983,7 @@ getTickArray modl = do case lookupModuleEnv arrmap modl of Just arr -> return arr Nothing -> do - (breakArray, ticks) <- getModBreak modl + (_breakArray, ticks) <- getModBreak modl let arr = mkTickArray (assocs ticks) setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr} return arr @@ -1999,6 +2027,7 @@ deleteBreak identity = do mapM (turnOffBreak.snd) this setGHCiState $ st { breaks = rest } +turnOffBreak :: BreakLocation -> GHCi Bool turnOffBreak loc = do (arr, _) <- getModBreak (breakModule loc) io $ setBreakFlag False arr (breakTick loc)