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