Be a bit more flexible in terminal identification for do_bold

[ghc-hetmet.git] / compiler / ghci / InteractiveUI.hs

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index c574a8a..ec1f4bf 100644 (file)
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -6,6 +6,13 @@
 -- (c) The GHC Team 2005-2006
 --
 -----------------------------------------------------------------------------
 -- (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
 
 #include "HsVersions.h"
 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 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 DynFlags
 import Packages
 import PackageConfig
 import UniqFM

-import PprTyThing
+import HscTypes                ( implicitTyThings )

 import Outputable       hiding (printForUser)
 import Module           -- for ModuleEnv
 import Name
 import Outputable       hiding (printForUser)
 import Module           -- for ModuleEnv
 import Name

+import SrcLoc

 
 -- Other random utilities
 import Digraph
 
 -- Other random utilities
 import Digraph

@@ -36,6 +45,8 @@ import Config
 import StaticFlags
 import Linker
 import Util
 import StaticFlags
 import Linker
 import Util

+import NameSet
+import Maybes          ( orElse )

 import FastString
 
 #ifndef mingw32_HOST_OS
 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.Directory
 import System.IO
 import System.IO.Error as IO

+import System.IO.Unsafe

 import Data.Char
 import Data.Dynamic
 import Data.Array
 import Data.Char
 import Data.Dynamic
 import Data.Array

@@ -126,6 +138,8 @@ builtin_commands = [
   ("show",     keepGoing showCmd,              False, completeNone),
   ("sprint",    keepGoing sprintCmd,            False, completeIdentifier),
   ("step",      keepGoing stepCmd,              False, completeIdentifier), 
   ("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),
   ("type",     keepGoing typeOfExpr,           False, completeIdentifier),
   ("trace",     keepGoing traceCmd,             False, completeIdentifier), 
   ("undef",     keepGoing undefineMacro,       False, completeMacro),

@@ -157,8 +171,8 @@ helpText =
  "   :info [<name> ...]          display information about the given names\n" ++
  "   :kind <type>                show the kind of <type>\n" ++
  "   :load <filename> ...        load module(s) and their dependents\n" ++
  "   :info [<name> ...]          display information about the given names\n" ++
  "   :kind <type>                show the kind of <type>\n" ++
  "   :load <filename> ...        load module(s) and their dependents\n" ++

- "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++

  "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
  "   :main [<arguments> ...]     run the main function with the given arguments\n" ++

+ "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++

  "   :quit                       exit GHCi\n" ++
  "   :reload                     reload the current module set\n" ++
  "   :type <expr>                show the type of <expr>\n" ++
  "   :quit                       exit GHCi\n" ++
  "   :reload                     reload the current module set\n" ++
  "   :type <expr>                show the type of <expr>\n" ++

@@ -181,6 +195,8 @@ helpText =
  "   :sprint [<name> ...]        simplifed version of :print\n" ++
  "   :step                       single-step after stopping at a breakpoint\n"++
  "   :step <expr>                single-step into <expr>\n"++
  "   :sprint [<name> ...]        simplifed version of :print\n" ++
  "   :step                       single-step after stopping at a breakpoint\n"++
  "   :step <expr>                single-step into <expr>\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 <expr>               trace into <expr> (remembers breakpoints for :history)\n"++
 
  "   :trace                      trace after stopping at a breakpoint\n"++
  "   :trace <expr>               trace into <expr> (remembers breakpoints for :history)\n"++
 

@@ -459,7 +475,7 @@ mkPrompt = do
                    then return (brackets (ppr (GHC.resumeSpan r)) <> space)
                    else do
                         let hist = GHC.resumeHistory r !! (ix-1)
                    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
                         return (brackets (ppr (negate ix) <> char ':' 
                                           <+> ppr span) <> space)
   let

@@ -554,28 +570,33 @@ runStmt stmt step
       session <- getSession
       result <- io $ withProgName (progname st) $ withArgs (args st) $
                     GHC.runStmt session 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
                                  -- 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
   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 <cmd>"
-        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 <cmd>"
+               st <- getGHCiState
+               enqueueCommands [stop st]
+               return ()
+         | otherwise -> io(GHC.resume session GHC.SingleStep) >>= 
+                        afterRunStmt step_here >> return ()

      _ -> return ()
 
   flushInterpBuffers
      _ -> return ()
 
   flushInterpBuffers

@@ -585,6 +606,19 @@ afterRunStmt run_result = do
 
   return (case run_result of GHC.RunOk _ -> True; _ -> False)
 
 
   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
 runBreakCmd :: GHC.BreakInfo -> GHCi ()
 runBreakCmd info = do
   let mod = GHC.breakInfo_module info

@@ -648,6 +682,20 @@ getCurrentBreakSpan = do
                 span <- io $ GHC.getHistorySpan session hist
                 return (Just span)
 
                 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
 
 -----------------------------------------------------------------------------
 -- Commands
 

@@ -667,23 +715,22 @@ info s  = do { let names = words s
             ; mapM_ (infoThing pefas session) names }
   where
     infoThing pefas session str = io $ do
             ; mapM_ (infoThing pefas session) names }
   where
     infoThing pefas session str = io $ do

-       names <- GHC.parseName session str
-       let filtered = filterOutChildren names
-       mb_stuffs <- mapM (GHC.getInfo session) filtered
+       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 "") $
        unqual <- GHC.getPrintUnqual session
        putStrLn (showSDocForUser unqual $
                   vcat (intersperse (text "") $

-                  [ pprInfo pefas 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
 
   -- 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
+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)
 
 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
 pprInfo pefas (thing, fixity, insts)

@@ -870,8 +917,6 @@ checkModule m = do
 
 reloadModule :: String -> GHCi ()
 reloadModule 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)
   session <- getSession
   doLoad session $ if null m then LoadAllTargets 
                              else LoadUpTo (GHC.mkModuleName m)

@@ -888,10 +933,9 @@ doLoad session howmuch = do
 afterLoad ok session = do
   io (revertCAFs)  -- always revert CAFs on load.
   discardTickArrays
 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
 
 setContextAfterLoad session [] = do
   prel_mod <- getPrelude

@@ -947,8 +991,10 @@ typeOfExpr str
        maybe_ty <- io (GHC.exprType cms str)
        case maybe_ty of
          Nothing -> return ()
        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 
 
 kindOfType :: String -> GHCi ()
 kindOfType str 

@@ -956,7 +1002,7 @@ kindOfType str
        maybe_ty <- io (GHC.typeKind cms str)
        case maybe_ty of
          Nothing    -> return ()
        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
           
 quit :: String -> GHCi Bool
 quit _ = return True

@@ -994,16 +1040,16 @@ browseModule m exports_only = do
     Just mod_info -> do
         let names
               | exports_only = GHC.modInfoExports mod_info
     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 pefas = dopt Opt_PrintExplicitForalls dflags
        io (putStrLn (showSDocForUser unqual (
 
         dflags <- getDynFlags
        let pefas = dopt Opt_PrintExplicitForalls dflags
        io (putStrLn (showSDocForUser unqual (

-               vcat (map (pprTyThingInContext pefas) (catMaybes things))
+               vcat (map (pprTyThingInContext pefas) filtered_things)

           )))
        -- ToDo: modInfoInstances currently throws an exception for
        -- package modules.  When it works, we can do this:
           )))
        -- ToDo: modInfoInstances currently throws an exception for
        -- package modules.  When it works, we can do this:

@@ -1240,10 +1286,15 @@ showCmd str = do
 
 showModules = do
   session <- getSession
 
 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)
   graph <- io (GHC.getModuleGraph session)

-  mapM_ show_one graph
+  filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph

 
 showBindings = do
   s <- getSession
 
 showBindings = do
   s <- getSession

@@ -1256,18 +1307,9 @@ compareTyThings :: TyThing -> TyThing -> Ordering
 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
 
 printTyThing :: TyThing -> GHCi ()
 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_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
 
 showBkptTable :: GHCi ()
 showBkptTable = do

@@ -1295,10 +1337,11 @@ completeNone w = return []
 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
 completeWord w start end = do
   line <- Readline.getLineBuffer
 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
      ':':_ | 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
           maybe_cmd <- lookupCommand c
            let (n,w') = selectWord (words' 0 line)
           case maybe_cmd of

@@ -1307,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'
             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
        | otherwise     -> do
                --printf "complete %s, start = %d, end = %d\n" w start end
                wrapCompleter completeIdentifier w

@@ -1322,9 +1367,6 @@ completeWord w start end = do
               | offset+length x >= start = (start-offset,take (end-offset) x)
               | otherwise = selectWord xs
 
               | 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
 
 completeCmd w = do
   cmds <- readIORef commands

@@ -1498,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
        -- 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()).
        --
        --
        -- 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
        setConsoleCP 28591       -- ISO Latin-1
        setConsoleOutputCP 28591 -- ISO Latin-1
 #endif

@@ -1523,21 +1568,55 @@ pprintCommand bind force str = do
   io $ pprintClosureCommand session bind force str
 
 stepCmd :: String -> GHCi ()
   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 ()
 
 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 :: String -> GHCi ()

-traceCmd []         = doContinue GHC.RunAndLogSteps
+traceCmd []         = doContinue (const True) GHC.RunAndLogSteps

 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
 
 continueCmd :: String -> GHCi ()
 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
   session <- getSession
   runResult <- io $ GHC.resume session step

-  afterRunStmt runResult
+  afterRunStmt pred runResult

   return ()
 
 abandonCmd :: String -> GHCi ()
   return ()
 
 abandonCmd :: String -> GHCi ()

@@ -1579,10 +1658,18 @@ historyCmd arg
         let hist = GHC.resumeHistory r
             (took,rest) = splitAt num hist
         spans <- mapM (io . GHC.getHistorySpan s) took
         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 "<end of history>" else "..."
 
         io $ putStrLn $ if null rest then "<end of history>" else "..."
 

+bold c | do_bold   = text start_bold <> c <> text end_bold
+       | otherwise = c
+

 backCmd :: String -> GHCi ()
 backCmd = noArgs $ do
   s <- getSession
 backCmd :: String -> GHCi ()
 backCmd = noArgs $ do
   s <- getSession

@@ -1642,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
 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)
 
 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 [<mod>] <line> [<column>]")

 
 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
 findBreakAndSet mod lookupTickTree = do 
 
 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
 findBreakAndSet mod lookupTickTree = do 

@@ -1688,9 +1778,9 @@ findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
 findBreakByLine line arr
   | not (inRange (bounds arr) line) = Nothing
   | otherwise =
 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
 
   where 
         ticks = arr ! line
 

@@ -1705,8 +1795,8 @@ findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
 findBreakByCoord mb_file (line, col) arr
   | not (inRange (bounds arr) line) = Nothing
   | otherwise =
 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
 
   where 
         ticks = arr ! line
 

@@ -1722,30 +1812,20 @@ findBreakByCoord mb_file (line, col) arr
                               GHC.srcSpanStartLine span == line,
                               GHC.srcSpanStartCol span >= col ]
 
                               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
 
 listCmd :: String -> GHCi ()
 listCmd "" = do

@@ -1811,10 +1891,10 @@ listAround span do_highlight = do
           line_nos = [ fst_line .. ]
 
           highlighted | do_highlight = zipWith highlight line_nos these_lines
           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 ]
 
           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
       --
       BS.putStrLn (BS.join (BS.pack "\n") prefixed)
   where

@@ -1831,32 +1911,33 @@ listAround span do_highlight = do
         highlight | do_bold   = highlight_bold
                   | otherwise = highlight_carets
 
         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
           | 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
           | 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
           | 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
           | 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.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
           | 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
          where

-           indent = BS.pack "   "
+           indent = BS.pack ("  " ++ replicate (length (show no)) ' ')

            nl = BS.singleton '\n'
 
 -- --------------------------------------------------------------------------
            nl = BS.singleton '\n'
 
 -- --------------------------------------------------------------------------