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