compiler/ghci/InteractiveUI.hs

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