compiler/ghci/InteractiveUI.hs

   1 {-# OPTIONS -#include "Linker.h" #-}
   2 -----------------------------------------------------------------------------
   3 --
   4 -- GHC Interactive User Interface
   5 --
   6 -- (c) The GHC Team 2005-2006
   7 --
   8 -----------------------------------------------------------------------------
   9 module InteractiveUI (
  10         interactiveUI,
  11         ghciWelcomeMsg
  12    ) where
  13
  14 #include "HsVersions.h"
  15
  16 import GhciMonad
  17 import GhciTags
  18 import Debugger
  19
  20 -- The GHC interface
  21 import qualified GHC
  22 import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
  23                           Type, Module, ModuleName, TyThing(..), Phase,
  24                           BreakIndex, Name, SrcSpan, Resume, SingleStep )
  25 import DynFlags
  26 import Packages
  27 import PackageConfig
  28 import UniqFM
  29 import PprTyThing
  30 import Outputable       hiding (printForUser)
  31 import Module           -- for ModuleEnv
  32
  33 -- Other random utilities
  34 import Digraph
  35 import BasicTypes hiding (isTopLevel)
  36 import Panic      hiding (showException)
  37 import Config
  38 import StaticFlags
  39 import Linker
  40 import Util
  41 import FastString
  42
  43 #ifndef mingw32_HOST_OS
  44 import System.Posix
  45 #if __GLASGOW_HASKELL__ > 504
  46         hiding (getEnv)
  47 #endif
  48 #else
  49 import GHC.ConsoleHandler ( flushConsole )
  50 import System.Win32       ( setConsoleCP, setConsoleOutputCP )
  51 import qualified System.Win32
  52 #endif
  53
  54 #ifdef USE_READLINE
  55 import Control.Concurrent       ( yield )       -- Used in readline loop
  56 import System.Console.Readline as Readline
  57 #endif
  58
  59 --import SystemExts
  60
  61 import Control.Exception as Exception
  62 -- import Control.Concurrent
  63
  64 import qualified Data.ByteString.Char8 as BS
  65 import Data.List
  66 import Data.Maybe
  67 import System.Cmd
  68 import System.Environment
  69 import System.Exit      ( exitWith, ExitCode(..) )
  70 import System.Directory
  71 import System.IO
  72 import System.IO.Error as IO
  73 import Data.Char
  74 import Data.Dynamic
  75 import Data.Array
  76 import Control.Monad as Monad
  77 import Text.Printf
  78
  79 import Foreign.StablePtr        ( newStablePtr )
  80 import GHC.Exts         ( unsafeCoerce# )
  81 import GHC.IOBase       ( IOErrorType(InvalidArgument) )
  82
  83 import Data.IORef       ( IORef, readIORef, writeIORef )
  84
  85 import System.Posix.Internals ( setNonBlockingFD )
  86
  87 -----------------------------------------------------------------------------
  88
  89 ghciWelcomeMsg =
  90  "   ___         ___ _\n"++
  91  "  / _ \\ /\\  /\\/ __(_)\n"++
  92  " / /_\\// /_/ / /  | |    GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
  93  "/ /_\\\\/ __  / /___| |    http://www.haskell.org/ghc/\n"++
  94  "\\____/\\/ /_/\\____/|_|    Type :? for help.\n"
  95
  96 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
  97 cmdName (n,_,_,_) = n
  98
  99 GLOBAL_VAR(commands, builtin_commands, [Command])
 100
 101 builtin_commands :: [Command]
 102 builtin_commands = [
 103         -- Hugs users are accustomed to :e, so make sure it doesn't overlap
 104   ("?",         keepGoing help,                 False, completeNone),
 105   ("add",       keepGoingPaths addModule,       False, completeFilename),
 106   ("abandon",   keepGoing abandonCmd,           False, completeNone),
 107   ("break",     keepGoing breakCmd,             False, completeIdentifier),
 108   ("back",      keepGoing backCmd,              False, completeNone),
 109   ("browse",    keepGoing browseCmd,            False, completeModule),
 110   ("cd",        keepGoing changeDirectory,      False, completeFilename),
 111   ("check",     keepGoing checkModule,          False, completeHomeModule),
 112   ("continue",  keepGoing continueCmd,          False, completeNone),
 113   ("ctags",     keepGoing createCTagsFileCmd,   False, completeFilename),
 114   ("def",       keepGoing defineMacro,          False, completeIdentifier),
 115   ("delete",    keepGoing deleteCmd,            False, completeNone),
 116   ("e",         keepGoing editFile,             False, completeFilename),
 117   ("edit",      keepGoing editFile,             False, completeFilename),
 118   ("etags",     keepGoing createETagsFileCmd,   False, completeFilename),
 119   ("force",     keepGoing forceCmd,             False, completeIdentifier),
 120   ("forward",   keepGoing forwardCmd,           False, completeNone),
 121   ("help",      keepGoing help,                 False, completeNone),
 122   ("history",   keepGoing historyCmd,           False, completeNone),
 123   ("info",      keepGoing info,                 False, completeIdentifier),
 124   ("kind",      keepGoing kindOfType,           False, completeIdentifier),
 125   ("load",      keepGoingPaths loadModule_,     False, completeHomeModuleOrFile),
 126   ("list",      keepGoing listCmd,              False, completeNone),
 127   ("module",    keepGoing setContext,           False, completeModule),
 128   ("main",      keepGoing runMain,              False, completeIdentifier),
 129   ("print",     keepGoing printCmd,             False, completeIdentifier),
 130   ("quit",      quit,                           False, completeNone),
 131   ("reload",    keepGoing reloadModule,         False, completeNone),
 132   ("set",       keepGoing setCmd,               True,  completeSetOptions),
 133   ("show",      keepGoing showCmd,              False, completeNone),
 134   ("sprint",    keepGoing sprintCmd,            False, completeIdentifier),
 135   ("step",      keepGoing stepCmd,              False, completeIdentifier),
 136   ("type",      keepGoing typeOfExpr,           False, completeIdentifier),
 137   ("trace",     keepGoing traceCmd,             False, completeIdentifier),
 138   ("undef",     keepGoing undefineMacro,        False, completeMacro),
 139   ("unset",     keepGoing unsetOptions,         True,  completeSetOptions)
 140   ]
 141
 142 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 143 keepGoing a str = a str >> return False
 144
 145 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
 146 keepGoingPaths a str = a (toArgs str) >> return False
 147
 148 shortHelpText = "use :? for help.\n"
 149
 150 helpText =
 151  " Commands available from the prompt:\n" ++
 152  "\n" ++
 153  "   <statement>                 evaluate/run <statement>\n" ++
 154  "   :add <filename> ...         add module(s) to the current target set\n" ++
 155  "   :browse [*]<module>         display the names defined by <module>\n" ++
 156  "   :cd <dir>                   change directory to <dir>\n" ++
 157  "   :ctags [<file>]             create tags file for Vi (default: \"tags\")\n" ++
 158  "   :def <cmd> <expr>           define a command :<cmd>\n" ++
 159  "   :edit <file>                edit file\n" ++
 160  "   :edit                       edit last module\n" ++
 161  "   :etags [<file>]             create tags file for Emacs (default: \"TAGS\")\n" ++
 162  "   :help, :?                   display this list of commands\n" ++
 163  "   :info [<name> ...]          display information about the given names\n" ++
 164  "   :kind <type>                show the kind of <type>\n" ++
 165  "   :load <filename> ...        load module(s) and their dependents\n" ++
 166  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
 167  "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
 168  "   :quit                       exit GHCi\n" ++
 169  "   :reload                     reload the current module set\n" ++
 170  "   :type <expr>                show the type of <expr>\n" ++
 171  "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
 172  "   :!<command>                 run the shell command <command>\n" ++
 173  "\n" ++
 174  " -- Commands for debugging:\n" ++
 175  "\n" ++
 176  "   :abandon                    at a breakpoint, abandon current computation\n" ++
 177  "   :back                       go back in the history (after :trace)\n" ++
 178  "   :break [<mod>] <l> [<col>]  set a breakpoint at the specified location\n" ++
 179  "   :break <name>               set a breakpoint on the specified function\n" ++
 180  "   :continue                   resume after a breakpoint\n" ++
 181  "   :delete <number>            delete the specified breakpoint\n" ++
 182  "   :delete *                   delete all breakpoints\n" ++
 183  "   :force <expr>               print <expr>, forcing unevaluated parts\n" ++
 184  "   :forward                    go forward in the history (after :back)\n" ++
 185  "   :history [<n>]              show the last <n> items in the history (after :trace)\n" ++
 186  "   :print [<name> ...]         prints a value without forcing its computation\n" ++
 187  "   :step                       single-step after stopping at a breakpoint\n"++
 188  "   :step <expr>                single-step into <expr>\n"++
 189  "   :trace                      trace after stopping at a breakpoint\n"++
 190  "   :trace <expr>               trace into <expr> (remembers breakpoints for :history)\n"++
 191  "   :sprint [<name> ...]        simplifed version of :print\n" ++
 192
 193  "\n" ++
 194  " -- Commands for changing settings:\n" ++
 195  "\n" ++
 196  "   :set <option> ...           set options\n" ++
 197  "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
 198  "   :set prog <progname>        set the value returned by System.getProgName\n" ++
 199  "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
 200  "   :set editor <cmd>           set the command used for :edit\n" ++
 201  "   :set stop <cmd>             set the command to run when a breakpoint is hit\n" ++
 202  "   :unset <option> ...         unset options\n" ++
 203  "\n" ++
 204  "  Options for ':set' and ':unset':\n" ++
 205  "\n" ++
 206  "    +r            revert top-level expressions after each evaluation\n" ++
 207  "    +s            print timing/memory stats after each evaluation\n" ++
 208  "    +t            print type after evaluation\n" ++
 209  "    -<flags>      most GHC command line flags can also be set here\n" ++
 210  "                         (eg. -v2, -fglasgow-exts, etc.)\n" ++
 211  "\n" ++
 212  " -- Commands for displaying information:\n" ++
 213  "\n" ++
 214  "   :show bindings              show the current bindings made at the prompt\n" ++
 215  "   :show breaks                show the active breakpoints\n" ++
 216  "   :show context               show the breakpoint context\n" ++
 217  "   :show modules               show the currently loaded modules\n" ++
 218  "   :show <setting>             show anything that can be set with :set (e.g. args)\n" ++
 219  "\n"
 220
 221 findEditor = do
 222   getEnv "EDITOR"
 223     `IO.catch` \_ -> do
 224 #if mingw32_HOST_OS
 225         win <- System.Win32.getWindowsDirectory
 226         return (win `joinFileName` "notepad.exe")
 227 #else
 228         return ""
 229 #endif
 230
 231 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
 232 interactiveUI session srcs maybe_expr = do
 233    -- HACK! If we happen to get into an infinite loop (eg the user
 234    -- types 'let x=x in x' at the prompt), then the thread will block
 235    -- on a blackhole, and become unreachable during GC.  The GC will
 236    -- detect that it is unreachable and send it the NonTermination
 237    -- exception.  However, since the thread is unreachable, everything
 238    -- it refers to might be finalized, including the standard Handles.
 239    -- This sounds like a bug, but we don't have a good solution right
 240    -- now.
 241    newStablePtr stdin
 242    newStablePtr stdout
 243    newStablePtr stderr
 244
 245         -- Initialise buffering for the *interpreted* I/O system
 246    initInterpBuffering session
 247
 248    when (isNothing maybe_expr) $ do
 249         -- Only for GHCi (not runghc and ghc -e):
 250         -- Turn buffering off for the compiled program's stdout/stderr
 251         turnOffBuffering
 252         -- Turn buffering off for GHCi's stdout
 253         hFlush stdout
 254         hSetBuffering stdout NoBuffering
 255         -- We don't want the cmd line to buffer any input that might be
 256         -- intended for the program, so unbuffer stdin.
 257         hSetBuffering stdin NoBuffering
 258
 259         -- initial context is just the Prelude
 260    prel_mod <- GHC.findModule session prel_name (Just basePackageId)
 261    GHC.setContext session [] [prel_mod]
 262
 263 #ifdef USE_READLINE
 264    Readline.initialize
 265    Readline.setAttemptedCompletionFunction (Just completeWord)
 266    --Readline.parseAndBind "set show-all-if-ambiguous 1"
 267
 268    let symbols = "!#$%&*+/<=>?@\\^|-~"
 269        specials = "(),;[]`{}"
 270        spaces = " \t\n"
 271        word_break_chars = spaces ++ specials ++ symbols
 272
 273    Readline.setBasicWordBreakCharacters word_break_chars
 274    Readline.setCompleterWordBreakCharacters word_break_chars
 275 #endif
 276
 277    default_editor <- findEditor
 278
 279    startGHCi (runGHCi srcs maybe_expr)
 280         GHCiState{ progname = "<interactive>",
 281                    args = [],
 282                    prompt = "%s> ",
 283                    stop = "",
 284                    editor = default_editor,
 285                    session = session,
 286                    options = [],
 287                    prelude = prel_mod,
 288                    break_ctr = 0,
 289                    breaks = [],
 290                    tickarrays = emptyModuleEnv
 291                  }
 292
 293 #ifdef USE_READLINE
 294    Readline.resetTerminal Nothing
 295 #endif
 296
 297    return ()
 298
 299 prel_name = GHC.mkModuleName "Prelude"
 300
 301 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
 302 runGHCi paths maybe_expr = do
 303   let read_dot_files = not opt_IgnoreDotGhci
 304
 305   when (read_dot_files) $ do
 306     -- Read in ./.ghci.
 307     let file = "./.ghci"
 308     exists <- io (doesFileExist file)
 309     when exists $ do
 310        dir_ok  <- io (checkPerms ".")
 311        file_ok <- io (checkPerms file)
 312        when (dir_ok && file_ok) $ do
 313           either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
 314           case either_hdl of
 315              Left e    -> return ()
 316              Right hdl -> fileLoop hdl False
 317
 318   when (read_dot_files) $ do
 319     -- Read in $HOME/.ghci
 320     either_dir <- io (IO.try (getEnv "HOME"))
 321     case either_dir of
 322        Left e -> return ()
 323        Right dir -> do
 324           cwd <- io (getCurrentDirectory)
 325           when (dir /= cwd) $ do
 326              let file = dir ++ "/.ghci"
 327              ok <- io (checkPerms file)
 328              when ok $ do
 329                either_hdl <- io (IO.try (openFile file ReadMode))
 330                case either_hdl of
 331                   Left e    -> return ()
 332                   Right hdl -> fileLoop hdl False
 333
 334   -- Perform a :load for files given on the GHCi command line
 335   -- When in -e mode, if the load fails then we want to stop
 336   -- immediately rather than going on to evaluate the expression.
 337   when (not (null paths)) $ do
 338      ok <- ghciHandle (\e -> do showException e; return Failed) $
 339                 loadModule paths
 340      when (isJust maybe_expr && failed ok) $
 341         io (exitWith (ExitFailure 1))
 342
 343   -- if verbosity is greater than 0, or we are connected to a
 344   -- terminal, display the prompt in the interactive loop.
 345   is_tty <- io (hIsTerminalDevice stdin)
 346   dflags <- getDynFlags
 347   let show_prompt = verbosity dflags > 0 || is_tty
 348
 349   case maybe_expr of
 350         Nothing ->
 351           do
 352 #if defined(mingw32_HOST_OS)
 353             -- The win32 Console API mutates the first character of
 354             -- type-ahead when reading from it in a non-buffered manner. Work
 355             -- around this by flushing the input buffer of type-ahead characters,
 356             -- but only if stdin is available.
 357             flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
 358             case flushed of
 359              Left err | isDoesNotExistError err -> return ()
 360                       | otherwise -> io (ioError err)
 361              Right () -> return ()
 362 #endif
 363             -- initialise the console if necessary
 364             io setUpConsole
 365
 366             -- enter the interactive loop
 367             interactiveLoop is_tty show_prompt
 368         Just expr -> do
 369             -- just evaluate the expression we were given
 370             runCommandEval expr
 371             return ()
 372
 373   -- and finally, exit
 374   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
 375
 376
 377 interactiveLoop is_tty show_prompt =
 378   -- Ignore ^C exceptions caught here
 379   ghciHandleDyn (\e -> case e of
 380                         Interrupted -> do
 381 #if defined(mingw32_HOST_OS)
 382                                 io (putStrLn "")
 383 #endif
 384                                 interactiveLoop is_tty show_prompt
 385                         _other      -> return ()) $
 386
 387   ghciUnblock $ do -- unblock necessary if we recursed from the
 388                    -- exception handler above.
 389
 390   -- read commands from stdin
 391 #ifdef USE_READLINE
 392   if (is_tty)
 393         then readlineLoop
 394         else fileLoop stdin show_prompt
 395 #else
 396   fileLoop stdin show_prompt
 397 #endif
 398
 399
 400 -- NOTE: We only read .ghci files if they are owned by the current user,
 401 -- and aren't world writable.  Otherwise, we could be accidentally
 402 -- running code planted by a malicious third party.
 403
 404 -- Furthermore, We only read ./.ghci if . is owned by the current user
 405 -- and isn't writable by anyone else.  I think this is sufficient: we
 406 -- don't need to check .. and ../.. etc. because "."  always refers to
 407 -- the same directory while a process is running.
 408
 409 checkPerms :: String -> IO Bool
 410 checkPerms name =
 411 #ifdef mingw32_HOST_OS
 412   return True
 413 #else
 414   Util.handle (\_ -> return False) $ do
 415      st <- getFileStatus name
 416      me <- getRealUserID
 417      if fileOwner st /= me then do
 418         putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
 419         return False
 420       else do
 421         let mode =  fileMode st
 422         if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
 423            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
 424            then do
 425                putStrLn $ "*** WARNING: " ++ name ++
 426                           " is writable by someone else, IGNORING!"
 427                return False
 428           else return True
 429 #endif
 430
 431 fileLoop :: Handle -> Bool -> GHCi ()
 432 fileLoop hdl show_prompt = do
 433    when show_prompt $ do
 434         prompt <- mkPrompt
 435         (io (putStr prompt))
 436    l <- io (IO.try (hGetLine hdl))
 437    case l of
 438         Left e | isEOFError e              -> return ()
 439                | InvalidArgument <- etype  -> return ()
 440                | otherwise                 -> io (ioError e)
 441                 where etype = ioeGetErrorType e
 442                 -- treat InvalidArgument in the same way as EOF:
 443                 -- this can happen if the user closed stdin, or
 444                 -- perhaps did getContents which closes stdin at
 445                 -- EOF.
 446         Right l ->
 447           case removeSpaces l of
 448             "" -> fileLoop hdl show_prompt
 449             l  -> do quit <- runCommand l
 450                      if quit then return () else fileLoop hdl show_prompt
 451
 452 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
 453 stringLoop [] = return False
 454 stringLoop (s:ss) = do
 455    case removeSpaces s of
 456         "" -> stringLoop ss
 457         l  -> do quit <- runCommand l
 458                  if quit then return True else stringLoop ss
 459
 460 mkPrompt = do
 461   session <- getSession
 462   (toplevs,exports) <- io (GHC.getContext session)
 463   resumes <- io $ GHC.getResumeContext session
 464
 465   context_bit <-
 466         case resumes of
 467             [] -> return empty
 468             r:rs -> do
 469                 let ix = GHC.resumeHistoryIx r
 470                 if ix == 0
 471                    then return (brackets (ppr (GHC.resumeSpan r)) <> space)
 472                    else do
 473                         let hist = GHC.resumeHistory r !! (ix-1)
 474                         span <- io $ GHC.getHistorySpan session hist
 475                         return (brackets (ppr (negate ix) <> char ':'
 476                                           <+> ppr span) <> space)
 477   let
 478         dots | r:rs <- resumes, not (null rs) = text "... "
 479              | otherwise = empty
 480
 481         modules_bit =
 482              hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
 483              hsep (map (ppr . GHC.moduleName) exports)
 484
 485         deflt_prompt = dots <> context_bit <> modules_bit
 486
 487         f ('%':'s':xs) = deflt_prompt <> f xs
 488         f ('%':'%':xs) = char '%' <> f xs
 489         f (x:xs) = char x <> f xs
 490         f [] = empty
 491    --
 492   st <- getGHCiState
 493   return (showSDoc (f (prompt st)))
 494
 495
 496 #ifdef USE_READLINE
 497 readlineLoop :: GHCi ()
 498 readlineLoop = do
 499    session <- getSession
 500    (mod,imports) <- io (GHC.getContext session)
 501    io yield
 502    saveSession -- for use by completion
 503    st <- getGHCiState
 504    mb_span <- getCurrentBreakSpan
 505    prompt <- mkPrompt
 506    l <- io (readline prompt `finally` setNonBlockingFD 0)
 507                 -- readline sometimes puts stdin into blocking mode,
 508                 -- so we need to put it back for the IO library
 509    splatSavedSession
 510    case l of
 511         Nothing -> return ()
 512         Just l  ->
 513           case removeSpaces l of
 514             "" -> readlineLoop
 515             l  -> do
 516                   io (addHistory l)
 517                   quit <- runCommand l
 518                   if quit then return () else readlineLoop
 519 #endif
 520
 521 runCommand :: String -> GHCi Bool
 522 runCommand c = ghciHandle handler (doCommand c)
 523   where
 524     doCommand (':' : command) = specialCommand command
 525     doCommand stmt
 526        = do timeIt $ runStmt stmt GHC.RunToCompletion
 527             return False
 528
 529 -- This version is for the GHC command-line option -e.  The only difference
 530 -- from runCommand is that it catches the ExitException exception and
 531 -- exits, rather than printing out the exception.
 532 runCommandEval c = ghciHandle handleEval (doCommand c)
 533   where
 534     handleEval (ExitException code) = io (exitWith code)
 535     handleEval e                    = do handler e
 536                                          io (exitWith (ExitFailure 1))
 537
 538     doCommand (':' : command) = specialCommand command
 539     doCommand stmt
 540        = do r <- runStmt stmt GHC.RunToCompletion
 541             case r of
 542                 False -> io (exitWith (ExitFailure 1))
 543                   -- failure to run the command causes exit(1) for ghc -e.
 544                 _       -> return True
 545
 546 runStmt :: String -> SingleStep -> GHCi Bool
 547 runStmt stmt step
 548  | null (filter (not.isSpace) stmt) = return False
 549  | otherwise
 550  = do st <- getGHCiState
 551       session <- getSession
 552       result <- io $ withProgName (progname st) $ withArgs (args st) $
 553                      GHC.runStmt session stmt step
 554       afterRunStmt result
 555
 556
 557 afterRunStmt :: GHC.RunResult -> GHCi Bool
 558                                  -- False <=> the statement failed to compile
 559 afterRunStmt (GHC.RunException e) = throw e
 560 afterRunStmt run_result = do
 561   session <- getSession
 562   case run_result of
 563      GHC.RunOk names -> do
 564         show_types <- isOptionSet ShowType
 565         when show_types $ mapM_ (showTypeOfName session) names
 566      GHC.RunBreak _ names _ -> do
 567         resumes <- io $ GHC.getResumeContext session
 568         printForUser $ ptext SLIT("Stopped at") <+>
 569                        ppr (GHC.resumeSpan (head resumes))
 570         mapM_ (showTypeOfName session) names
 571         -- run the command set with ":set stop <cmd>"
 572         st <- getGHCiState
 573         runCommand (stop st)
 574         return ()
 575      _ -> return ()
 576
 577   flushInterpBuffers
 578   io installSignalHandlers
 579   b <- isOptionSet RevertCAFs
 580   io (when b revertCAFs)
 581
 582   return (case run_result of GHC.RunOk _ -> True; _ -> False)
 583
 584
 585 showTypeOfName :: Session -> Name -> GHCi ()
 586 showTypeOfName session n
 587    = do maybe_tything <- io (GHC.lookupName session n)
 588         case maybe_tything of
 589           Nothing    -> return ()
 590           Just thing -> showTyThing thing
 591
 592 specialCommand :: String -> GHCi Bool
 593 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 594 specialCommand str = do
 595   let (cmd,rest) = break isSpace str
 596   maybe_cmd <- io (lookupCommand cmd)
 597   case maybe_cmd of
 598     Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
 599                                     ++ shortHelpText) >> return False)
 600     Just (_,f,_,_) -> f (dropWhile isSpace rest)
 601
 602 lookupCommand :: String -> IO (Maybe Command)
 603 lookupCommand str = do
 604   cmds <- readIORef commands
 605   -- look for exact match first, then the first prefix match
 606   case [ c | c <- cmds, str == cmdName c ] of
 607      c:_ -> return (Just c)
 608      [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
 609                 [] -> return Nothing
 610                 c:_ -> return (Just c)
 611
 612
 613 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
 614 getCurrentBreakSpan = do
 615   session <- getSession
 616   resumes <- io $ GHC.getResumeContext session
 617   case resumes of
 618     [] -> return Nothing
 619     (r:rs) -> do
 620         let ix = GHC.resumeHistoryIx r
 621         if ix == 0
 622            then return (Just (GHC.resumeSpan r))
 623            else do
 624                 let hist = GHC.resumeHistory r !! (ix-1)
 625                 span <- io $ GHC.getHistorySpan session hist
 626                 return (Just span)
 627
 628 -----------------------------------------------------------------------------
 629 -- Commands
 630
 631 noArgs :: GHCi () -> String -> GHCi ()
 632 noArgs m "" = m
 633 noArgs m _ = io $ putStrLn "This command takes no arguments"
 634
 635 help :: String -> GHCi ()
 636 help _ = io (putStr helpText)
 637
 638 info :: String -> GHCi ()
 639 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
 640 info s  = do { let names = words s
 641              ; session <- getSession
 642              ; dflags <- getDynFlags
 643              ; let exts = dopt Opt_GlasgowExts dflags
 644              ; mapM_ (infoThing exts session) names }
 645   where
 646     infoThing exts session str = io $ do
 647         names <- GHC.parseName session str
 648         let filtered = filterOutChildren names
 649         mb_stuffs <- mapM (GHC.getInfo session) filtered
 650         unqual <- GHC.getPrintUnqual session
 651         putStrLn (showSDocForUser unqual $
 652                    vcat (intersperse (text "") $
 653                    [ pprInfo exts stuff | Just stuff <-  mb_stuffs ]))
 654
 655   -- Filter out names whose parent is also there Good
 656   -- example is '[]', which is both a type and data
 657   -- constructor in the same type
 658 filterOutChildren :: [Name] -> [Name]
 659 filterOutChildren names = filter (not . parent_is_there) names
 660  where parent_is_there n
 661 --       | Just p <- GHC.nameParent_maybe n = p `elem` names
 662 -- ToDo!!
 663          | otherwise                       = False
 664
 665 pprInfo exts (thing, fixity, insts)
 666   =  pprTyThingInContextLoc exts thing
 667   $$ show_fixity fixity
 668   $$ vcat (map GHC.pprInstance insts)
 669   where
 670     show_fixity fix
 671         | fix == GHC.defaultFixity = empty
 672         | otherwise                = ppr fix <+> ppr (GHC.getName thing)
 673
 674 runMain :: String -> GHCi ()
 675 runMain args = do
 676   let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
 677   runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
 678   return ()
 679
 680 addModule :: [FilePath] -> GHCi ()
 681 addModule files = do
 682   io (revertCAFs)                       -- always revert CAFs on load/add.
 683   files <- mapM expandPath files
 684   targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
 685   session <- getSession
 686   io (mapM_ (GHC.addTarget session) targets)
 687   ok <- io (GHC.load session LoadAllTargets)
 688   afterLoad ok session
 689
 690 changeDirectory :: String -> GHCi ()
 691 changeDirectory dir = do
 692   session <- getSession
 693   graph <- io (GHC.getModuleGraph session)
 694   when (not (null graph)) $
 695         io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
 696   io (GHC.setTargets session [])
 697   io (GHC.load session LoadAllTargets)
 698   setContextAfterLoad session []
 699   io (GHC.workingDirectoryChanged session)
 700   dir <- expandPath dir
 701   io (setCurrentDirectory dir)
 702
 703 editFile :: String -> GHCi ()
 704 editFile str
 705   | null str  = do
 706         -- find the name of the "topmost" file loaded
 707      session <- getSession
 708      graph0 <- io (GHC.getModuleGraph session)
 709      graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
 710      let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
 711      case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
 712         Just file -> do_edit file
 713         Nothing   -> throwDyn (CmdLineError "unknown file name")
 714   | otherwise = do_edit str
 715   where
 716         do_edit file = do
 717            st <- getGHCiState
 718            let cmd = editor st
 719            when (null cmd) $
 720                 throwDyn (CmdLineError "editor not set, use :set editor")
 721            io $ system (cmd ++ ' ':file)
 722            return ()
 723
 724 defineMacro :: String -> GHCi ()
 725 defineMacro s = do
 726   let (macro_name, definition) = break isSpace s
 727   cmds <- io (readIORef commands)
 728   if (null macro_name)
 729         then throwDyn (CmdLineError "invalid macro name")
 730         else do
 731   if (macro_name `elem` map cmdName cmds)
 732         then throwDyn (CmdLineError
 733                 ("command '" ++ macro_name ++ "' is already defined"))
 734         else do
 735
 736   -- give the expression a type signature, so we can be sure we're getting
 737   -- something of the right type.
 738   let new_expr = '(' : definition ++ ") :: String -> IO String"
 739
 740   -- compile the expression
 741   cms <- getSession
 742   maybe_hv <- io (GHC.compileExpr cms new_expr)
 743   case maybe_hv of
 744      Nothing -> return ()
 745      Just hv -> io (writeIORef commands --
 746                     (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
 747
 748 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
 749 runMacro fun s = do
 750   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 751   stringLoop (lines str)
 752
 753 undefineMacro :: String -> GHCi ()
 754 undefineMacro macro_name = do
 755   cmds <- io (readIORef commands)
 756   if (macro_name `elem` map cmdName builtin_commands)
 757         then throwDyn (CmdLineError
 758                 ("command '" ++ macro_name ++ "' cannot be undefined"))
 759         else do
 760   if (macro_name `notElem` map cmdName cmds)
 761         then throwDyn (CmdLineError
 762                 ("command '" ++ macro_name ++ "' not defined"))
 763         else do
 764   io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
 765
 766
 767 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 768 loadModule fs = timeIt (loadModule' fs)
 769
 770 loadModule_ :: [FilePath] -> GHCi ()
 771 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
 772
 773 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 774 loadModule' files = do
 775   session <- getSession
 776
 777   -- unload first
 778   discardActiveBreakPoints
 779   io (GHC.setTargets session [])
 780   io (GHC.load session LoadAllTargets)
 781
 782   -- expand tildes
 783   let (filenames, phases) = unzip files
 784   exp_filenames <- mapM expandPath filenames
 785   let files' = zip exp_filenames phases
 786   targets <- io (mapM (uncurry GHC.guessTarget) files')
 787
 788   -- NOTE: we used to do the dependency anal first, so that if it
 789   -- fails we didn't throw away the current set of modules.  This would
 790   -- require some re-working of the GHC interface, so we'll leave it
 791   -- as a ToDo for now.
 792
 793   io (GHC.setTargets session targets)
 794   doLoad session LoadAllTargets
 795
 796 checkModule :: String -> GHCi ()
 797 checkModule m = do
 798   let modl = GHC.mkModuleName m
 799   session <- getSession
 800   result <- io (GHC.checkModule session modl)
 801   case result of
 802     Nothing -> io $ putStrLn "Nothing"
 803     Just r  -> io $ putStrLn (showSDoc (
 804         case GHC.checkedModuleInfo r of
 805            Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
 806                 let
 807                     (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
 808                 in
 809                         (text "global names: " <+> ppr global) $$
 810                         (text "local  names: " <+> ppr local)
 811            _ -> empty))
 812   afterLoad (successIf (isJust result)) session
 813
 814 reloadModule :: String -> GHCi ()
 815 reloadModule "" = do
 816   io (revertCAFs)               -- always revert CAFs on reload.
 817   discardActiveBreakPoints
 818   session <- getSession
 819   doLoad session LoadAllTargets
 820   return ()
 821 reloadModule m = do
 822   io (revertCAFs)               -- always revert CAFs on reload.
 823   discardActiveBreakPoints
 824   session <- getSession
 825   doLoad session (LoadUpTo (GHC.mkModuleName m))
 826   return ()
 827
 828 doLoad session howmuch = do
 829   -- turn off breakpoints before we load: we can't turn them off later, because
 830   -- the ModBreaks will have gone away.
 831   discardActiveBreakPoints
 832   ok <- io (GHC.load session howmuch)
 833   afterLoad ok session
 834   return ok
 835
 836 afterLoad ok session = do
 837   io (revertCAFs)  -- always revert CAFs on load.
 838   discardTickArrays
 839   graph <- io (GHC.getModuleGraph session)
 840   graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
 841   setContextAfterLoad session graph'
 842   modulesLoadedMsg ok (map GHC.ms_mod_name graph')
 843
 844 setContextAfterLoad session [] = do
 845   prel_mod <- getPrelude
 846   io (GHC.setContext session [] [prel_mod])
 847 setContextAfterLoad session ms = do
 848   -- load a target if one is available, otherwise load the topmost module.
 849   targets <- io (GHC.getTargets session)
 850   case [ m | Just m <- map (findTarget ms) targets ] of
 851         []    ->
 852           let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
 853           load_this (last graph')
 854         (m:_) ->
 855           load_this m
 856  where
 857    findTarget ms t
 858     = case filter (`matches` t) ms of
 859         []    -> Nothing
 860         (m:_) -> Just m
 861
 862    summary `matches` Target (TargetModule m) _
 863         = GHC.ms_mod_name summary == m
 864    summary `matches` Target (TargetFile f _) _
 865         | Just f' <- GHC.ml_hs_file (GHC.ms_location summary)   = f == f'
 866    summary `matches` target
 867         = False
 868
 869    load_this summary | m <- GHC.ms_mod summary = do
 870         b <- io (GHC.moduleIsInterpreted session m)
 871         if b then io (GHC.setContext session [m] [])
 872              else do
 873                    prel_mod <- getPrelude
 874                    io (GHC.setContext session []  [prel_mod,m])
 875
 876
 877 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
 878 modulesLoadedMsg ok mods = do
 879   dflags <- getDynFlags
 880   when (verbosity dflags > 0) $ do
 881    let mod_commas
 882         | null mods = text "none."
 883         | otherwise = hsep (
 884             punctuate comma (map ppr mods)) <> text "."
 885    case ok of
 886     Failed ->
 887        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 888     Succeeded  ->
 889        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 890
 891
 892 typeOfExpr :: String -> GHCi ()
 893 typeOfExpr str
 894   = do cms <- getSession
 895        maybe_ty <- io (GHC.exprType cms str)
 896        case maybe_ty of
 897           Nothing -> return ()
 898           Just ty -> do ty' <- cleanType ty
 899                         printForUser $ text str <> text " :: " <> ppr ty'
 900
 901 kindOfType :: String -> GHCi ()
 902 kindOfType str
 903   = do cms <- getSession
 904        maybe_ty <- io (GHC.typeKind cms str)
 905        case maybe_ty of
 906           Nothing    -> return ()
 907           Just ty    -> printForUser $ text str <> text " :: " <> ppr ty
 908
 909 quit :: String -> GHCi Bool
 910 quit _ = return True
 911
 912 shellEscape :: String -> GHCi Bool
 913 shellEscape str = io (system str >> return False)
 914
 915 -----------------------------------------------------------------------------
 916 -- Browsing a module's contents
 917
 918 browseCmd :: String -> GHCi ()
 919 browseCmd m =
 920   case words m of
 921     ['*':m] | looksLikeModuleName m -> browseModule m False
 922     [m]     | looksLikeModuleName m -> browseModule m True
 923     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 924
 925 browseModule m exports_only = do
 926   s <- getSession
 927   modl <- if exports_only then lookupModule m
 928                           else wantInterpretedModule m
 929
 930   -- Temporarily set the context to the module we're interested in,
 931   -- just so we can get an appropriate PrintUnqualified
 932   (as,bs) <- io (GHC.getContext s)
 933   prel_mod <- getPrelude
 934   io (if exports_only then GHC.setContext s [] [prel_mod,modl]
 935                       else GHC.setContext s [modl] [])
 936   unqual <- io (GHC.getPrintUnqual s)
 937   io (GHC.setContext s as bs)
 938
 939   mb_mod_info <- io $ GHC.getModuleInfo s modl
 940   case mb_mod_info of
 941     Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
 942     Just mod_info -> do
 943         let names
 944                | exports_only = GHC.modInfoExports mod_info
 945                | otherwise    = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
 946
 947             filtered = filterOutChildren names
 948
 949         things <- io $ mapM (GHC.lookupName s) filtered
 950
 951         dflags <- getDynFlags
 952         let exts = dopt Opt_GlasgowExts dflags
 953         io (putStrLn (showSDocForUser unqual (
 954                 vcat (map (pprTyThingInContext exts) (catMaybes things))
 955            )))
 956         -- ToDo: modInfoInstances currently throws an exception for
 957         -- package modules.  When it works, we can do this:
 958         --      $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
 959
 960 -----------------------------------------------------------------------------
 961 -- Setting the module context
 962
 963 setContext str
 964   | all sensible mods = fn mods
 965   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
 966   where
 967     (fn, mods) = case str of
 968                         '+':stuff -> (addToContext,      words stuff)
 969                         '-':stuff -> (removeFromContext, words stuff)
 970                         stuff     -> (newContext,        words stuff)
 971
 972     sensible ('*':m) = looksLikeModuleName m
 973     sensible m       = looksLikeModuleName m
 974
 975 separate :: Session -> [String] -> [Module] -> [Module]
 976         -> GHCi ([Module],[Module])
 977 separate session []           as bs = return (as,bs)
 978 separate session (('*':str):ms) as bs = do
 979    m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
 980    b <- io $ GHC.moduleIsInterpreted session m
 981    if b then separate session ms (m:as) bs
 982         else throwDyn (CmdLineError ("module '"
 983                         ++ GHC.moduleNameString (GHC.moduleName m)
 984                         ++ "' is not interpreted"))
 985 separate session (str:ms) as bs = do
 986   m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
 987   separate session ms as (m:bs)
 988
 989 newContext :: [String] -> GHCi ()
 990 newContext strs = do
 991   s <- getSession
 992   (as,bs) <- separate s strs [] []
 993   prel_mod <- getPrelude
 994   let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
 995   io $ GHC.setContext s as bs'
 996
 997
 998 addToContext :: [String] -> GHCi ()
 999 addToContext strs = do
1000   s <- getSession
1001   (as,bs) <- io $ GHC.getContext s
1002
1003   (new_as,new_bs) <- separate s strs [] []
1004
1005   let as_to_add = new_as \\ (as ++ bs)
1006       bs_to_add = new_bs \\ (as ++ bs)
1007
1008   io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1009
1010
1011 removeFromContext :: [String] -> GHCi ()
1012 removeFromContext strs = do
1013   s <- getSession
1014   (as,bs) <- io $ GHC.getContext s
1015
1016   (as_to_remove,bs_to_remove) <- separate s strs [] []
1017
1018   let as' = as \\ (as_to_remove ++ bs_to_remove)
1019       bs' = bs \\ (as_to_remove ++ bs_to_remove)
1020
1021   io $ GHC.setContext s as' bs'
1022
1023 ----------------------------------------------------------------------------
1024 -- Code for `:set'
1025
1026 -- set options in the interpreter.  Syntax is exactly the same as the
1027 -- ghc command line, except that certain options aren't available (-C,
1028 -- -E etc.)
1029 --
1030 -- This is pretty fragile: most options won't work as expected.  ToDo:
1031 -- figure out which ones & disallow them.
1032
1033 setCmd :: String -> GHCi ()
1034 setCmd ""
1035   = do st <- getGHCiState
1036        let opts = options st
1037        io $ putStrLn (showSDoc (
1038               text "options currently set: " <>
1039               if null opts
1040                    then text "none."
1041                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1042            ))
1043 setCmd str
1044   = case toArgs str of
1045         ("args":args) -> setArgs args
1046         ("prog":prog) -> setProg prog
1047         ("prompt":prompt) -> setPrompt (after 6)
1048         ("editor":cmd) -> setEditor (after 6)
1049         ("stop":cmd) -> setStop (after 4)
1050         wds -> setOptions wds
1051    where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1052
1053 setArgs args = do
1054   st <- getGHCiState
1055   setGHCiState st{ args = args }
1056
1057 setProg [prog] = do
1058   st <- getGHCiState
1059   setGHCiState st{ progname = prog }
1060 setProg _ = do
1061   io (hPutStrLn stderr "syntax: :set prog <progname>")
1062
1063 setEditor cmd = do
1064   st <- getGHCiState
1065   setGHCiState st{ editor = cmd }
1066
1067 setStop cmd = do
1068   st <- getGHCiState
1069   setGHCiState st{ stop = cmd }
1070
1071 setPrompt value = do
1072   st <- getGHCiState
1073   if null value
1074       then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1075       else setGHCiState st{ prompt = remQuotes value }
1076   where
1077      remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1078      remQuotes x = x
1079
1080 setOptions wds =
1081    do -- first, deal with the GHCi opts (+s, +t, etc.)
1082       let (plus_opts, minus_opts)  = partition isPlus wds
1083       mapM_ setOpt plus_opts
1084       -- then, dynamic flags
1085       newDynFlags minus_opts
1086
1087 newDynFlags minus_opts = do
1088       dflags <- getDynFlags
1089       let pkg_flags = packageFlags dflags
1090       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1091
1092       if (not (null leftovers))
1093                 then throwDyn (CmdLineError ("unrecognised flags: " ++
1094                                                 unwords leftovers))
1095                 else return ()
1096
1097       new_pkgs <- setDynFlags dflags'
1098
1099       -- if the package flags changed, we should reset the context
1100       -- and link the new packages.
1101       dflags <- getDynFlags
1102       when (packageFlags dflags /= pkg_flags) $ do
1103         io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1104         session <- getSession
1105         io (GHC.setTargets session [])
1106         io (GHC.load session LoadAllTargets)
1107         io (linkPackages dflags new_pkgs)
1108         setContextAfterLoad session []
1109       return ()
1110
1111
1112 unsetOptions :: String -> GHCi ()
1113 unsetOptions str
1114   = do -- first, deal with the GHCi opts (+s, +t, etc.)
1115        let opts = words str
1116            (minus_opts, rest1) = partition isMinus opts
1117            (plus_opts, rest2)  = partition isPlus rest1
1118
1119        if (not (null rest2))
1120           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1121           else do
1122
1123        mapM_ unsetOpt plus_opts
1124
1125        let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1126            no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1127
1128        no_flags <- mapM no_flag minus_opts
1129        newDynFlags no_flags
1130
1131 isMinus ('-':s) = True
1132 isMinus _ = False
1133
1134 isPlus ('+':s) = True
1135 isPlus _ = False
1136
1137 setOpt ('+':str)
1138   = case strToGHCiOpt str of
1139         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1140         Just o  -> setOption o
1141
1142 unsetOpt ('+':str)
1143   = case strToGHCiOpt str of
1144         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1145         Just o  -> unsetOption o
1146
1147 strToGHCiOpt :: String -> (Maybe GHCiOption)
1148 strToGHCiOpt "s" = Just ShowTiming
1149 strToGHCiOpt "t" = Just ShowType
1150 strToGHCiOpt "r" = Just RevertCAFs
1151 strToGHCiOpt _   = Nothing
1152
1153 optToStr :: GHCiOption -> String
1154 optToStr ShowTiming = "s"
1155 optToStr ShowType   = "t"
1156 optToStr RevertCAFs = "r"
1157
1158 -- ---------------------------------------------------------------------------
1159 -- code for `:show'
1160
1161 showCmd str = do
1162   st <- getGHCiState
1163   case words str of
1164         ["args"]     -> io $ putStrLn (show (args st))
1165         ["prog"]     -> io $ putStrLn (show (progname st))
1166         ["prompt"]   -> io $ putStrLn (show (prompt st))
1167         ["editor"]   -> io $ putStrLn (show (editor st))
1168         ["stop"]     -> io $ putStrLn (show (stop st))
1169         ["modules" ] -> showModules
1170         ["bindings"] -> showBindings
1171         ["linker"]   -> io showLinkerState
1172         ["breaks"]   -> showBkptTable
1173         ["context"]  -> showContext
1174         _ -> throwDyn (CmdLineError "syntax:  :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1175
1176 showModules = do
1177   session <- getSession
1178   let show_one ms = do m <- io (GHC.showModule session ms)
1179                        io (putStrLn m)
1180   graph <- io (GHC.getModuleGraph session)
1181   mapM_ show_one graph
1182
1183 showBindings = do
1184   s <- getSession
1185   unqual <- io (GHC.getPrintUnqual s)
1186   bindings <- io (GHC.getBindings s)
1187   mapM_ showTyThing bindings
1188   return ()
1189
1190 showTyThing (AnId id) = do
1191   ty' <- cleanType (GHC.idType id)
1192   printForUser $ ppr id <> text " :: " <> ppr ty'
1193 showTyThing _  = return ()
1194
1195 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1196 cleanType :: Type -> GHCi Type
1197 cleanType ty = do
1198   dflags <- getDynFlags
1199   if dopt Opt_GlasgowExts dflags
1200         then return ty
1201         else return $! GHC.dropForAlls ty
1202
1203 showBkptTable :: GHCi ()
1204 showBkptTable = do
1205   st <- getGHCiState
1206   printForUser $ prettyLocations (breaks st)
1207
1208 showContext :: GHCi ()
1209 showContext = do
1210    session <- getSession
1211    resumes <- io $ GHC.getResumeContext session
1212    printForUser $ vcat (map pp_resume (reverse resumes))
1213   where
1214    pp_resume resume =
1215         ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1216         $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1217
1218
1219 -- -----------------------------------------------------------------------------
1220 -- Completion
1221
1222 completeNone :: String -> IO [String]
1223 completeNone w = return []
1224
1225 #ifdef USE_READLINE
1226 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1227 completeWord w start end = do
1228   line <- Readline.getLineBuffer
1229   case w of
1230      ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1231      _other
1232         | Just c <- is_cmd line -> do
1233            maybe_cmd <- lookupCommand c
1234            let (n,w') = selectWord (words' 0 line)
1235            case maybe_cmd of
1236              Nothing -> return Nothing
1237              Just (_,_,False,complete) -> wrapCompleter complete w
1238              Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1239                                                               return (map (drop n) rets)
1240                                          in wrapCompleter complete' w'
1241         | otherwise     -> do
1242                 --printf "complete %s, start = %d, end = %d\n" w start end
1243                 wrapCompleter completeIdentifier w
1244     where words' _ [] = []
1245           words' n str = let (w,r) = break isSpace str
1246                              (s,r') = span isSpace r
1247                          in (n,w):words' (n+length w+length s) r'
1248           -- In a Haskell expression we want to parse 'a-b' as three words
1249           -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1250           -- only be a single word.
1251           selectWord [] = (0,w)
1252           selectWord ((offset,x):xs)
1253               | offset+length x >= start = (start-offset,take (end-offset) x)
1254               | otherwise = selectWord xs
1255
1256 is_cmd line
1257  | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1258  | otherwise = Nothing
1259
1260 completeCmd w = do
1261   cmds <- readIORef commands
1262   return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1263
1264 completeMacro w = do
1265   cmds <- readIORef commands
1266   let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1267   return (filter (w `isPrefixOf`) cmds')
1268
1269 completeIdentifier w = do
1270   s <- restoreSession
1271   rdrs <- GHC.getRdrNamesInScope s
1272   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1273
1274 completeModule w = do
1275   s <- restoreSession
1276   dflags <- GHC.getSessionDynFlags s
1277   let pkg_mods = allExposedModules dflags
1278   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1279
1280 completeHomeModule w = do
1281   s <- restoreSession
1282   g <- GHC.getModuleGraph s
1283   let home_mods = map GHC.ms_mod_name g
1284   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1285
1286 completeSetOptions w = do
1287   return (filter (w `isPrefixOf`) options)
1288     where options = "args":"prog":allFlags
1289
1290 completeFilename = Readline.filenameCompletionFunction
1291
1292 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1293
1294 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1295 unionComplete f1 f2 w = do
1296   s1 <- f1 w
1297   s2 <- f2 w
1298   return (s1 ++ s2)
1299
1300 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1301 wrapCompleter fun w =  do
1302   strs <- fun w
1303   case strs of
1304     []  -> return Nothing
1305     [x] -> return (Just (x,[]))
1306     xs  -> case getCommonPrefix xs of
1307                 ""   -> return (Just ("",xs))
1308                 pref -> return (Just (pref,xs))
1309
1310 getCommonPrefix :: [String] -> String
1311 getCommonPrefix [] = ""
1312 getCommonPrefix (s:ss) = foldl common s ss
1313   where common s "" = ""
1314         common "" s = ""
1315         common (c:cs) (d:ds)
1316            | c == d = c : common cs ds
1317            | otherwise = ""
1318
1319 allExposedModules :: DynFlags -> [ModuleName]
1320 allExposedModules dflags
1321  = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1322  where
1323   pkg_db = pkgIdMap (pkgState dflags)
1324 #else
1325 completeCmd        = completeNone
1326 completeMacro      = completeNone
1327 completeIdentifier = completeNone
1328 completeModule     = completeNone
1329 completeHomeModule = completeNone
1330 completeSetOptions = completeNone
1331 completeFilename   = completeNone
1332 completeHomeModuleOrFile=completeNone
1333 completeBkpt       = completeNone
1334 #endif
1335
1336 -- ---------------------------------------------------------------------------
1337 -- User code exception handling
1338
1339 -- This is the exception handler for exceptions generated by the
1340 -- user's code and exceptions coming from children sessions;
1341 -- it normally just prints out the exception.  The
1342 -- handler must be recursive, in case showing the exception causes
1343 -- more exceptions to be raised.
1344 --
1345 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1346 -- raising another exception.  We therefore don't put the recursive
1347 -- handler arond the flushing operation, so if stderr is closed
1348 -- GHCi will just die gracefully rather than going into an infinite loop.
1349 handler :: Exception -> GHCi Bool
1350
1351 handler exception = do
1352   flushInterpBuffers
1353   io installSignalHandlers
1354   ghciHandle handler (showException exception >> return False)
1355
1356 showException (DynException dyn) =
1357   case fromDynamic dyn of
1358     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
1359     Just Interrupted      -> io (putStrLn "Interrupted.")
1360     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
1361     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1362     Just other_ghc_ex     -> io (print other_ghc_ex)
1363
1364 showException other_exception
1365   = io (putStrLn ("*** Exception: " ++ show other_exception))
1366
1367 -----------------------------------------------------------------------------
1368 -- recursive exception handlers
1369
1370 -- Don't forget to unblock async exceptions in the handler, or if we're
1371 -- in an exception loop (eg. let a = error a in a) the ^C exception
1372 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1373
1374 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1375 ghciHandle h (GHCi m) = GHCi $ \s ->
1376    Exception.catch (m s)
1377         (\e -> unGHCi (ghciUnblock (h e)) s)
1378
1379 ghciUnblock :: GHCi a -> GHCi a
1380 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1381
1382
1383 -- ----------------------------------------------------------------------------
1384 -- Utils
1385
1386 expandPath :: String -> GHCi String
1387 expandPath path =
1388   case dropWhile isSpace path of
1389    ('~':d) -> do
1390         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1391         return (tilde ++ '/':d)
1392    other ->
1393         return other
1394
1395 wantInterpretedModule :: String -> GHCi Module
1396 wantInterpretedModule str = do
1397    session <- getSession
1398    modl <- lookupModule str
1399    is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1400    when (not is_interpreted) $
1401        throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1402    return modl
1403
1404 wantNameFromInterpretedModule noCanDo str and_then = do
1405    session <- getSession
1406    names <- io $ GHC.parseName session str
1407    case names of
1408       []    -> return ()
1409       (n:_) -> do
1410             let modl = GHC.nameModule n
1411             is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1412             if not is_interpreted
1413                then noCanDo n $ text "module " <> ppr modl <>
1414                                 text " is not interpreted"
1415                else and_then n
1416
1417 -- ----------------------------------------------------------------------------
1418 -- Windows console setup
1419
1420 setUpConsole :: IO ()
1421 setUpConsole = do
1422 #ifdef mingw32_HOST_OS
1423         -- On Windows we need to set a known code page, otherwise the characters
1424         -- we read from the console will be be in some strange encoding, and
1425         -- similarly for characters we write to the console.
1426         --
1427         -- At the moment, GHCi pretends all input is Latin-1.  In the
1428         -- future we should support UTF-8, but for now we set the code pages
1429         -- to Latin-1.
1430         --
1431         -- It seems you have to set the font in the console window to
1432         -- a Unicode font in order for output to work properly,
1433         -- otherwise non-ASCII characters are mapped wrongly.  sigh.
1434         -- (see MSDN for SetConsoleOutputCP()).
1435         --
1436         setConsoleCP 28591       -- ISO Latin-1
1437         setConsoleOutputCP 28591 -- ISO Latin-1
1438 #endif
1439         return ()
1440
1441 -- -----------------------------------------------------------------------------
1442 -- commands for debugger
1443
1444 sprintCmd = pprintCommand False False
1445 printCmd  = pprintCommand True False
1446 forceCmd  = pprintCommand False True
1447
1448 pprintCommand bind force str = do
1449   session <- getSession
1450   io $ pprintClosureCommand session bind force str
1451
1452 stepCmd :: String -> GHCi ()
1453 stepCmd []         = doContinue GHC.SingleStep
1454 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1455
1456 traceCmd :: String -> GHCi ()
1457 traceCmd []         = doContinue GHC.RunAndLogSteps
1458 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1459
1460 continueCmd :: String -> GHCi ()
1461 continueCmd = noArgs $ doContinue GHC.RunToCompletion
1462
1463 doContinue :: SingleStep -> GHCi ()
1464 doContinue step = do
1465   session <- getSession
1466   runResult <- io $ GHC.resume session step
1467   afterRunStmt runResult
1468   return ()
1469
1470 abandonCmd :: String -> GHCi ()
1471 abandonCmd = noArgs $ do
1472   s <- getSession
1473   b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1474   when (not b) $ io $ putStrLn "There is no computation running."
1475   return ()
1476
1477 deleteCmd :: String -> GHCi ()
1478 deleteCmd argLine = do
1479    deleteSwitch $ words argLine
1480    where
1481    deleteSwitch :: [String] -> GHCi ()
1482    deleteSwitch [] =
1483       io $ putStrLn "The delete command requires at least one argument."
1484    -- delete all break points
1485    deleteSwitch ("*":_rest) = discardActiveBreakPoints
1486    deleteSwitch idents = do
1487       mapM_ deleteOneBreak idents
1488       where
1489       deleteOneBreak :: String -> GHCi ()
1490       deleteOneBreak str
1491          | all isDigit str = deleteBreak (read str)
1492          | otherwise = return ()
1493
1494 historyCmd :: String -> GHCi ()
1495 historyCmd arg
1496   | null arg        = history 20
1497   | all isDigit arg = history (read arg)
1498   | otherwise       = io $ putStrLn "Syntax:  :history [num]"
1499   where
1500   history num = do
1501     s <- getSession
1502     resumes <- io $ GHC.getResumeContext s
1503     case resumes of
1504       [] -> io $ putStrLn "Not stopped at a breakpoint"
1505       (r:rs) -> do
1506         let hist = GHC.resumeHistory r
1507             (took,rest) = splitAt num hist
1508         spans <- mapM (io . GHC.getHistorySpan s) took
1509         let nums = map (printf "-%-3d:") [(1::Int)..]
1510         printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans)))
1511         io $ putStrLn $ if null rest then "<end of history>" else "..."
1512
1513 backCmd :: String -> GHCi ()
1514 backCmd = noArgs $ do
1515   s <- getSession
1516   (names, ix, span) <- io $ GHC.back s
1517   printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1518   mapM_ (showTypeOfName s) names
1519    -- run the command set with ":set stop <cmd>"
1520   st <- getGHCiState
1521   runCommand (stop st)
1522   return ()
1523
1524 forwardCmd :: String -> GHCi ()
1525 forwardCmd = noArgs $ do
1526   s <- getSession
1527   (names, ix, span) <- io $ GHC.forward s
1528   printForUser $ (if (ix == 0)
1529                     then ptext SLIT("Stopped at")
1530                     else ptext SLIT("Logged breakpoint at")) <+> ppr span
1531   mapM_ (showTypeOfName s) names
1532    -- run the command set with ":set stop <cmd>"
1533   st <- getGHCiState
1534   runCommand (stop st)
1535   return ()
1536
1537 -- handle the "break" command
1538 breakCmd :: String -> GHCi ()
1539 breakCmd argLine = do
1540    session <- getSession
1541    breakSwitch session $ words argLine
1542
1543 breakSwitch :: Session -> [String] -> GHCi ()
1544 breakSwitch _session [] = do
1545    io $ putStrLn "The break command requires at least one argument."
1546 breakSwitch session args@(arg1:rest)
1547    | looksLikeModuleName arg1 = do
1548         mod <- wantInterpretedModule arg1
1549         breakByModule session mod rest
1550    | all isDigit arg1 = do
1551         (toplevel, _) <- io $ GHC.getContext session
1552         case toplevel of
1553            (mod : _) -> breakByModuleLine mod (read arg1) rest
1554            [] -> do
1555               io $ putStrLn "Cannot find default module for breakpoint."
1556               io $ putStrLn "Perhaps no modules are loaded for debugging?"
1557    | otherwise = do -- try parsing it as an identifier
1558         wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1559         let loc = GHC.nameSrcLoc name
1560         if GHC.isGoodSrcLoc loc
1561                then findBreakAndSet (GHC.nameModule name) $
1562                          findBreakByCoord (Just (GHC.srcLocFile loc))
1563                                           (GHC.srcLocLine loc,
1564                                            GHC.srcLocCol loc)
1565                else noCanDo name $ text "can't find its location: " <> ppr loc
1566        where
1567           noCanDo n why = printForUser $
1568                 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1569
1570 breakByModule :: Session -> Module -> [String] -> GHCi ()
1571 breakByModule session mod args@(arg1:rest)
1572    | all isDigit arg1 = do  -- looks like a line number
1573         breakByModuleLine mod (read arg1) rest
1574    | otherwise = io $ putStrLn "Invalid arguments to :break"
1575
1576 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1577 breakByModuleLine mod line args
1578    | [] <- args = findBreakAndSet mod $ findBreakByLine line
1579    | [col] <- args, all isDigit col =
1580         findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1581    | otherwise = io $ putStrLn "Invalid arguments to :break"
1582
1583 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1584 findBreakAndSet mod lookupTickTree = do
1585    tickArray <- getTickArray mod
1586    (breakArray, _) <- getModBreak mod
1587    case lookupTickTree tickArray of
1588       Nothing  -> io $ putStrLn $ "No breakpoints found at that location."
1589       Just (tick, span) -> do
1590          success <- io $ setBreakFlag True breakArray tick
1591          session <- getSession
1592          if success
1593             then do
1594                (alreadySet, nm) <-
1595                      recordBreak $ BreakLocation
1596                              { breakModule = mod
1597                              , breakLoc = span
1598                              , breakTick = tick
1599                              }
1600                printForUser $
1601                   text "Breakpoint " <> ppr nm <>
1602                   if alreadySet
1603                      then text " was already set at " <> ppr span
1604                      else text " activated at " <> ppr span
1605             else do
1606             printForUser $ text "Breakpoint could not be activated at"
1607                                  <+> ppr span
1608
1609 -- When a line number is specified, the current policy for choosing
1610 -- the best breakpoint is this:
1611 --    - the leftmost complete subexpression on the specified line, or
1612 --    - the leftmost subexpression starting on the specified line, or
1613 --    - the rightmost subexpression enclosing the specified line
1614 --
1615 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1616 findBreakByLine line arr
1617   | not (inRange (bounds arr) line) = Nothing
1618   | otherwise =
1619     listToMaybe (sortBy leftmost_largest  complete)   `mplus`
1620     listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1621     listToMaybe (sortBy rightmost ticks)
1622   where
1623         ticks = arr ! line
1624
1625         starts_here = [ tick | tick@(nm,span) <- ticks,
1626                                GHC.srcSpanStartLine span == line ]
1627
1628         (complete,incomplete) = partition ends_here starts_here
1629             where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1630
1631 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1632                  -> Maybe (BreakIndex,SrcSpan)
1633 findBreakByCoord mb_file (line, col) arr
1634   | not (inRange (bounds arr) line) = Nothing
1635   | otherwise =
1636     listToMaybe (sortBy rightmost contains)
1637   where
1638         ticks = arr ! line
1639
1640         -- the ticks that span this coordinate
1641         contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1642                             is_correct_file span ]
1643
1644         is_correct_file span
1645                  | Just f <- mb_file = GHC.srcSpanFile span == f
1646                  | otherwise         = True
1647
1648
1649 leftmost_smallest  (_,a) (_,b) = a `compare` b
1650 leftmost_largest   (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1651                                 `thenCmp`
1652                                  (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1653 rightmost (_,a) (_,b) = b `compare` a
1654
1655 spans :: SrcSpan -> (Int,Int) -> Bool
1656 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1657    where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1658
1659 start_bold = BS.pack "\ESC[1m"
1660 end_bold   = BS.pack "\ESC[0m"
1661
1662 listCmd :: String -> GHCi ()
1663 listCmd "" = do
1664    mb_span <- getCurrentBreakSpan
1665    case mb_span of
1666       Nothing  -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1667       Just span -> io $ listAround span True
1668 listCmd str = list2 (words str)
1669
1670 list2 [arg] | all isDigit arg = do
1671     session <- getSession
1672     (toplevel, _) <- io $ GHC.getContext session
1673     case toplevel of
1674         [] -> io $ putStrLn "No module to list"
1675         (mod : _) -> listModuleLine mod (read arg)
1676 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1677         mod <- wantInterpretedModule arg1
1678         listModuleLine mod (read arg2)
1679 list2 [arg] = do
1680         wantNameFromInterpretedModule noCanDo arg $ \name -> do
1681         let loc = GHC.nameSrcLoc name
1682         if GHC.isGoodSrcLoc loc
1683                then do
1684                   tickArray <- getTickArray (GHC.nameModule name)
1685                   let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1686                                         (GHC.srcLocLine loc, GHC.srcLocCol loc)
1687                                         tickArray
1688                   case mb_span of
1689                     Nothing       -> io $ listAround (GHC.srcLocSpan loc) False
1690                     Just (_,span) -> io $ listAround span False
1691                else
1692                   noCanDo name $ text "can't find its location: " <>
1693                                  ppr loc
1694     where
1695         noCanDo n why = printForUser $
1696             text "cannot list source code for " <> ppr n <> text ": " <> why
1697 list2  _other =
1698         io $ putStrLn "syntax:  :list [<line> | <module> <line> | <identifier>]"
1699
1700 listModuleLine :: Module -> Int -> GHCi ()
1701 listModuleLine modl line = do
1702    session <- getSession
1703    graph <- io (GHC.getModuleGraph session)
1704    let this = filter ((== modl) . GHC.ms_mod) graph
1705    case this of
1706      [] -> panic "listModuleLine"
1707      summ:_ -> do
1708            let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1709                loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1710            io $ listAround (GHC.srcLocSpan loc) False
1711
1712 -- | list a section of a source file around a particular SrcSpan.
1713 -- If the highlight flag is True, also highlight the span using
1714 -- start_bold/end_bold.
1715 listAround span do_highlight = do
1716       contents <- BS.readFile (unpackFS file)
1717       let
1718           lines = BS.split '\n' contents
1719           these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1720                         drop (line1 - 1 - pad_before) $ lines
1721           fst_line = max 1 (line1 - pad_before)
1722           line_nos = [ fst_line .. ]
1723
1724           highlighted | do_highlight = zipWith highlight line_nos these_lines
1725                       | otherwise   = these_lines
1726
1727           bs_line_nos = [ BS.pack (show l ++ "  ") | l <- line_nos ]
1728           prefixed = zipWith BS.append bs_line_nos highlighted
1729       --
1730       BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1731   where
1732         file  = GHC.srcSpanFile span
1733         line1 = GHC.srcSpanStartLine span
1734         col1  = GHC.srcSpanStartCol span
1735         line2 = GHC.srcSpanEndLine span
1736         col2  = GHC.srcSpanEndCol span
1737
1738         pad_before | line1 == 1 = 0
1739                    | otherwise  = 1
1740         pad_after = 1
1741
1742         highlight no line
1743           | no == line1 && no == line2
1744           = let (a,r) = BS.splitAt col1 line
1745                 (b,c) = BS.splitAt (col2-col1) r
1746             in
1747             BS.concat [a,start_bold,b,end_bold,c]
1748           | no == line1
1749           = let (a,b) = BS.splitAt col1 line in
1750             BS.concat [a, start_bold, b]
1751           | no == line2
1752           = let (a,b) = BS.splitAt col2 line in
1753             BS.concat [a, end_bold, b]
1754           | otherwise   = line
1755
1756 -- --------------------------------------------------------------------------
1757 -- Tick arrays
1758
1759 getTickArray :: Module -> GHCi TickArray
1760 getTickArray modl = do
1761    st <- getGHCiState
1762    let arrmap = tickarrays st
1763    case lookupModuleEnv arrmap modl of
1764       Just arr -> return arr
1765       Nothing  -> do
1766         (breakArray, ticks) <- getModBreak modl
1767         let arr = mkTickArray (assocs ticks)
1768         setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1769         return arr
1770
1771 discardTickArrays :: GHCi ()
1772 discardTickArrays = do
1773    st <- getGHCiState
1774    setGHCiState st{tickarrays = emptyModuleEnv}
1775
1776 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1777 mkTickArray ticks
1778   = accumArray (flip (:)) [] (1, max_line)
1779         [ (line, (nm,span)) | (nm,span) <- ticks,
1780                               line <- srcSpanLines span ]
1781     where
1782         max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1783         srcSpanLines span = [ GHC.srcSpanStartLine span ..
1784                               GHC.srcSpanEndLine span ]
1785
1786 lookupModule :: String -> GHCi Module
1787 lookupModule modName
1788    = do session <- getSession
1789         io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1790
1791 -- don't reset the counter back to zero?
1792 discardActiveBreakPoints :: GHCi ()
1793 discardActiveBreakPoints = do
1794    st <- getGHCiState
1795    mapM (turnOffBreak.snd) (breaks st)
1796    setGHCiState $ st { breaks = [] }
1797
1798 deleteBreak :: Int -> GHCi ()
1799 deleteBreak identity = do
1800    st <- getGHCiState
1801    let oldLocations    = breaks st
1802        (this,rest)     = partition (\loc -> fst loc == identity) oldLocations
1803    if null this
1804       then printForUser (text "Breakpoint" <+> ppr identity <+>
1805                          text "does not exist")
1806       else do
1807            mapM (turnOffBreak.snd) this
1808            setGHCiState $ st { breaks = rest }
1809
1810 turnOffBreak loc = do
1811   (arr, _) <- getModBreak (breakModule loc)
1812   io $ setBreakFlag False arr (breakTick loc)
1813
1814 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1815 getModBreak mod = do
1816    session <- getSession
1817    Just mod_info <- io $ GHC.getModuleInfo session mod
1818    let modBreaks  = GHC.modInfoModBreaks mod_info
1819    let array      = GHC.modBreaks_flags modBreaks
1820    let ticks      = GHC.modBreaks_locs  modBreaks
1821    return (array, ticks)
1822
1823 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1824 setBreakFlag toggle array index
1825    | toggle    = GHC.setBreakOn array index
1826    | otherwise = GHC.setBreakOff array index
1827