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