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
  10 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
  11
  12 #include "HsVersions.h"
  13
  14 import GhciMonad
  15 import GhciTags
  16 import Debugger
  17
  18 -- The GHC interface
  19 import qualified GHC
  20 import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
  21                           Module, ModuleName, TyThing(..), Phase,
  22                           BreakIndex, SrcSpan, Resume, SingleStep )
  23 import PprTyThing
  24 import DynFlags
  25
  26 import Packages
  27 #ifdef USE_READLINE
  28 import PackageConfig
  29 import UniqFM
  30 #endif
  31
  32 import HscTypes         ( implicitTyThings )
  33 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
  34 import Outputable       hiding (printForUser, printForUserPartWay)
  35 import Module           -- for ModuleEnv
  36 import Name
  37 import SrcLoc
  38
  39 -- Other random utilities
  40 import Digraph
  41 import BasicTypes hiding (isTopLevel)
  42 import Panic      hiding (showException)
  43 import Config
  44 import StaticFlags
  45 import Linker
  46 import Util
  47 import NameSet
  48 import Maybes           ( orElse )
  49 import FastString
  50 import Encoding
  51
  52 #ifndef mingw32_HOST_OS
  53 import System.Posix hiding (getEnv)
  54 #else
  55 import GHC.ConsoleHandler ( flushConsole )
  56 import qualified System.Win32
  57 #endif
  58
  59 #ifdef USE_READLINE
  60 import Control.Concurrent       ( yield )       -- Used in readline loop
  61 import System.Console.Readline as Readline
  62 #endif
  63
  64 --import SystemExts
  65
  66 import Control.Exception as Exception
  67 -- import Control.Concurrent
  68
  69 import qualified Data.ByteString.Char8 as BS
  70 import Data.List
  71 import Data.Maybe
  72 import System.Cmd
  73 import System.Environment
  74 import System.Exit      ( exitWith, ExitCode(..) )
  75 import System.Directory
  76 import System.IO
  77 import System.IO.Error as IO
  78 import Data.Char
  79 import Data.Dynamic
  80 import Data.Array
  81 import Control.Monad as Monad
  82 import Text.Printf
  83 import Foreign
  84 import Foreign.C        ( withCStringLen )
  85 import GHC.Exts         ( unsafeCoerce# )
  86 import GHC.IOBase       ( IOErrorType(InvalidArgument) )
  87
  88 import Data.IORef       ( IORef, readIORef, writeIORef )
  89
  90 #ifdef USE_READLINE
  91 import System.Posix.Internals ( setNonBlockingFD )
  92 #endif
  93
  94 -----------------------------------------------------------------------------
  95
  96 ghciWelcomeMsg :: String
  97 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
  98                  ": http://www.haskell.org/ghc/  :? for help"
  99
 100 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
 101
 102 cmdName :: Command -> String
 103 cmdName (n,_,_,_) = n
 104
 105 macros_ref :: IORef [Command]
 106 GLOBAL_VAR(macros_ref, [], [Command])
 107
 108 builtin_commands :: [Command]
 109 builtin_commands = [
 110         -- Hugs users are accustomed to :e, so make sure it doesn't overlap
 111   ("?",         keepGoing help,                 False, completeNone),
 112   ("add",       keepGoingPaths addModule,       False, completeFilename),
 113   ("abandon",   keepGoing abandonCmd,           False, completeNone),
 114   ("break",     keepGoing breakCmd,             False, completeIdentifier),
 115   ("back",      keepGoing backCmd,              False, completeNone),
 116   ("browse",    keepGoing (browseCmd False),    False, completeModule),
 117   ("browse!",   keepGoing (browseCmd True),     False, completeModule),
 118   ("cd",        keepGoing changeDirectory,      False, completeFilename),
 119   ("check",     keepGoing checkModule,          False, completeHomeModule),
 120   ("continue",  keepGoing continueCmd,          False, completeNone),
 121   ("cmd",       keepGoing cmdCmd,               False, completeIdentifier),
 122   ("ctags",     keepGoing createCTagsFileCmd,   False, completeFilename),
 123   ("def",       keepGoing (defineMacro False),  False, completeIdentifier),
 124   ("def!",      keepGoing (defineMacro True),   False, completeIdentifier),
 125   ("delete",    keepGoing deleteCmd,            False, completeNone),
 126   ("e",         keepGoing editFile,             False, completeFilename),
 127   ("edit",      keepGoing editFile,             False, completeFilename),
 128   ("etags",     keepGoing createETagsFileCmd,   False, completeFilename),
 129   ("force",     keepGoing forceCmd,             False, completeIdentifier),
 130   ("forward",   keepGoing forwardCmd,           False, completeNone),
 131   ("help",      keepGoing help,                 False, completeNone),
 132   ("history",   keepGoing historyCmd,           False, completeNone),
 133   ("info",      keepGoing info,                 False, completeIdentifier),
 134   ("kind",      keepGoing kindOfType,           False, completeIdentifier),
 135   ("load",      keepGoingPaths loadModule_,     False, completeHomeModuleOrFile),
 136   ("list",      keepGoing listCmd,              False, completeNone),
 137   ("module",    keepGoing setContext,           False, completeModule),
 138   ("main",      keepGoing runMain,              False, completeIdentifier),
 139   ("print",     keepGoing printCmd,             False, completeIdentifier),
 140   ("quit",      quit,                           False, completeNone),
 141   ("reload",    keepGoing reloadModule,         False, completeNone),
 142   ("set",       keepGoing setCmd,               True,  completeSetOptions),
 143   ("show",      keepGoing showCmd,              False, completeNone),
 144   ("sprint",    keepGoing sprintCmd,            False, completeIdentifier),
 145   ("step",      keepGoing stepCmd,              False, completeIdentifier),
 146   ("steplocal", keepGoing stepLocalCmd,         False, completeIdentifier),
 147   ("stepmodule",keepGoing stepModuleCmd,        False, completeIdentifier),
 148   ("type",      keepGoing typeOfExpr,           False, completeIdentifier),
 149   ("trace",     keepGoing traceCmd,             False, completeIdentifier),
 150   ("undef",     keepGoing undefineMacro,        False, completeMacro),
 151   ("unset",     keepGoing unsetOptions,         True,  completeSetOptions)
 152   ]
 153
 154 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 155 keepGoing a str = a str >> return False
 156
 157 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
 158 keepGoingPaths a str = a (toArgs str) >> return False
 159
 160 shortHelpText :: String
 161 shortHelpText = "use :? for help.\n"
 162
 163 helpText :: String
 164 helpText =
 165  " Commands available from the prompt:\n" ++
 166  "\n" ++
 167  "   <statement>                 evaluate/run <statement>\n" ++
 168  "   :{\\n ..lines.. \\n:}\\n       multiline command\n" ++
 169  "   :add <filename> ...         add module(s) to the current target set\n" ++
 170  "   :browse[!] [[*]<mod>]       display the names defined by module <mod>\n" ++
 171  "                               (!: more details; *: all top-level names)\n" ++
 172  "   :cd <dir>                   change directory to <dir>\n" ++
 173  "   :cmd <expr>                 run the commands returned by <expr>::IO String\n" ++
 174  "   :ctags [<file>]             create tags file for Vi (default: \"tags\")\n" ++
 175  "   :def <cmd> <expr>           define a command :<cmd>\n" ++
 176  "   :edit <file>                edit file\n" ++
 177  "   :edit                       edit last module\n" ++
 178  "   :etags [<file>]             create tags file for Emacs (default: \"TAGS\")\n" ++
 179  "   :help, :?                   display this list of commands\n" ++
 180  "   :info [<name> ...]          display information about the given names\n" ++
 181  "   :kind <type>                show the kind of <type>\n" ++
 182  "   :load <filename> ...        load module(s) and their dependents\n" ++
 183  "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
 184  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
 185  "   :quit                       exit GHCi\n" ++
 186  "   :reload                     reload the current module set\n" ++
 187  "   :type <expr>                show the type of <expr>\n" ++
 188  "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
 189  "   :!<command>                 run the shell command <command>\n" ++
 190  "\n" ++
 191  " -- Commands for debugging:\n" ++
 192  "\n" ++
 193  "   :abandon                    at a breakpoint, abandon current computation\n" ++
 194  "   :back                       go back in the history (after :trace)\n" ++
 195  "   :break [<mod>] <l> [<col>]  set a breakpoint at the specified location\n" ++
 196  "   :break <name>               set a breakpoint on the specified function\n" ++
 197  "   :continue                   resume after a breakpoint\n" ++
 198  "   :delete <number>            delete the specified breakpoint\n" ++
 199  "   :delete *                   delete all breakpoints\n" ++
 200  "   :force <expr>               print <expr>, forcing unevaluated parts\n" ++
 201  "   :forward                    go forward in the history (after :back)\n" ++
 202  "   :history [<n>]              show the last <n> items in the history (after :trace)\n" ++
 203  "   :print [<name> ...]         prints a value without forcing its computation\n" ++
 204  "   :sprint [<name> ...]        simplifed version of :print\n" ++
 205  "   :step                       single-step after stopping at a breakpoint\n"++
 206  "   :step <expr>                single-step into <expr>\n"++
 207  "   :steplocal                  single-step restricted to the current top level decl.\n"++
 208  "   :stepmodule                 single-step restricted to the current module\n"++
 209  "   :trace                      trace after stopping at a breakpoint\n"++
 210  "   :trace <expr>               trace into <expr> (remembers breakpoints for :history)\n"++
 211
 212  "\n" ++
 213  " -- Commands for changing settings:\n" ++
 214  "\n" ++
 215  "   :set <option> ...           set options\n" ++
 216  "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
 217  "   :set prog <progname>        set the value returned by System.getProgName\n" ++
 218  "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
 219  "   :set editor <cmd>           set the command used for :edit\n" ++
 220  "   :set stop <cmd>             set the command to run when a breakpoint is hit\n" ++
 221  "   :unset <option> ...         unset options\n" ++
 222  "\n" ++
 223  "  Options for ':set' and ':unset':\n" ++
 224  "\n" ++
 225  "    +r            revert top-level expressions after each evaluation\n" ++
 226  "    +s            print timing/memory stats after each evaluation\n" ++
 227  "    +t            print type after evaluation\n" ++
 228  "    -<flags>      most GHC command line flags can also be set here\n" ++
 229  "                         (eg. -v2, -fglasgow-exts, etc.)\n" ++
 230  "                    for GHCi-specific flags, see User's Guide,\n"++
 231  "                    Flag reference, Interactive-mode options\n" ++
 232  "\n" ++
 233  " -- Commands for displaying information:\n" ++
 234  "\n" ++
 235  "   :show bindings              show the current bindings made at the prompt\n" ++
 236  "   :show breaks                show the active breakpoints\n" ++
 237  "   :show context               show the breakpoint context\n" ++
 238  "   :show modules               show the currently loaded modules\n" ++
 239  "   :show packages              show the currently active package flags\n" ++
 240  "   :show languages             show the currently active language flags\n" ++
 241  "   :show <setting>             show anything that can be set with :set (e.g. args)\n" ++
 242  "\n"
 243
 244 findEditor :: IO String
 245 findEditor = do
 246   getEnv "EDITOR"
 247     `IO.catch` \_ -> do
 248 #if mingw32_HOST_OS
 249         win <- System.Win32.getWindowsDirectory
 250         return (win `joinFileName` "notepad.exe")
 251 #else
 252         return ""
 253 #endif
 254
 255 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
 256 interactiveUI session srcs maybe_expr = do
 257    -- HACK! If we happen to get into an infinite loop (eg the user
 258    -- types 'let x=x in x' at the prompt), then the thread will block
 259    -- on a blackhole, and become unreachable during GC.  The GC will
 260    -- detect that it is unreachable and send it the NonTermination
 261    -- exception.  However, since the thread is unreachable, everything
 262    -- it refers to might be finalized, including the standard Handles.
 263    -- This sounds like a bug, but we don't have a good solution right
 264    -- now.
 265    newStablePtr stdin
 266    newStablePtr stdout
 267    newStablePtr stderr
 268
 269     -- Initialise buffering for the *interpreted* I/O system
 270    initInterpBuffering session
 271
 272    when (isNothing maybe_expr) $ do
 273         -- Only for GHCi (not runghc and ghc -e):
 274
 275         -- Turn buffering off for the compiled program's stdout/stderr
 276         turnOffBuffering
 277         -- Turn buffering off for GHCi's stdout
 278         hFlush stdout
 279         hSetBuffering stdout NoBuffering
 280         -- We don't want the cmd line to buffer any input that might be
 281         -- intended for the program, so unbuffer stdin.
 282         hSetBuffering stdin NoBuffering
 283
 284         -- initial context is just the Prelude
 285    prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude")
 286                                       (Just basePackageId)
 287    GHC.setContext session [] [prel_mod]
 288
 289 #ifdef USE_READLINE
 290    Readline.initialize
 291    Readline.setAttemptedCompletionFunction (Just completeWord)
 292    --Readline.parseAndBind "set show-all-if-ambiguous 1"
 293
 294    let symbols = "!#$%&*+/<=>?@\\^|-~"
 295        specials = "(),;[]`{}"
 296        spaces = " \t\n"
 297        word_break_chars = spaces ++ specials ++ symbols
 298
 299    Readline.setBasicWordBreakCharacters word_break_chars
 300    Readline.setCompleterWordBreakCharacters word_break_chars
 301 #endif
 302
 303    default_editor <- findEditor
 304
 305    startGHCi (runGHCi srcs maybe_expr)
 306         GHCiState{ progname = "<interactive>",
 307                    args = [],
 308                    prompt = "%s> ",
 309                    stop = "",
 310                    editor = default_editor,
 311                    session = session,
 312                    options = [],
 313                    prelude = prel_mod,
 314                    break_ctr = 0,
 315                    breaks = [],
 316                    tickarrays = emptyModuleEnv,
 317                    cmdqueue = [],
 318                    remembered_ctx = Nothing
 319                  }
 320
 321 #ifdef USE_READLINE
 322    Readline.resetTerminal Nothing
 323 #endif
 324
 325    return ()
 326
 327 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
 328 runGHCi paths maybe_expr = do
 329   let read_dot_files = not opt_IgnoreDotGhci
 330
 331   when (read_dot_files) $ do
 332     -- Read in ./.ghci.
 333     let file = "./.ghci"
 334     exists <- io (doesFileExist file)
 335     when exists $ do
 336        dir_ok  <- io (checkPerms ".")
 337        file_ok <- io (checkPerms file)
 338        when (dir_ok && file_ok) $ do
 339           either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
 340           case either_hdl of
 341              Left _e   -> return ()
 342              Right hdl -> runCommands (fileLoop hdl False False)
 343
 344   when (read_dot_files) $ do
 345     -- Read in $HOME/.ghci
 346     either_dir <- io (IO.try getHomeDirectory)
 347     case either_dir of
 348        Left _e -> return ()
 349        Right dir -> do
 350           cwd <- io (getCurrentDirectory)
 351           when (dir /= cwd) $ do
 352              let file = dir ++ "/.ghci"
 353              ok <- io (checkPerms file)
 354              when ok $ do
 355                either_hdl <- io (IO.try (openFile file ReadMode))
 356                case either_hdl of
 357                   Left _e   -> return ()
 358                   Right hdl -> runCommands (fileLoop hdl False False)
 359
 360   -- Perform a :load for files given on the GHCi command line
 361   -- When in -e mode, if the load fails then we want to stop
 362   -- immediately rather than going on to evaluate the expression.
 363   when (not (null paths)) $ do
 364      ok <- ghciHandle (\e -> do showException e; return Failed) $
 365                 loadModule paths
 366      when (isJust maybe_expr && failed ok) $
 367         io (exitWith (ExitFailure 1))
 368
 369   -- if verbosity is greater than 0, or we are connected to a
 370   -- terminal, display the prompt in the interactive loop.
 371   is_tty <- io (hIsTerminalDevice stdin)
 372   dflags <- getDynFlags
 373   let show_prompt = verbosity dflags > 0 || is_tty
 374
 375   case maybe_expr of
 376         Nothing ->
 377           do
 378 #if defined(mingw32_HOST_OS)
 379             -- The win32 Console API mutates the first character of
 380             -- type-ahead when reading from it in a non-buffered manner. Work
 381             -- around this by flushing the input buffer of type-ahead characters,
 382             -- but only if stdin is available.
 383             flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
 384             case flushed of
 385              Left err | isDoesNotExistError err -> return ()
 386                       | otherwise -> io (ioError err)
 387              Right () -> return ()
 388 #endif
 389             -- enter the interactive loop
 390             interactiveLoop is_tty show_prompt
 391         Just expr -> do
 392             -- just evaluate the expression we were given
 393             runCommandEval expr
 394             return ()
 395
 396   -- and finally, exit
 397   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
 398
 399
 400 interactiveLoop :: Bool -> Bool -> GHCi ()
 401 interactiveLoop is_tty show_prompt =
 402   -- Ignore ^C exceptions caught here
 403   ghciHandleDyn (\e -> case e of
 404                         Interrupted -> do
 405 #if defined(mingw32_HOST_OS)
 406                                 io (putStrLn "")
 407 #endif
 408                                 interactiveLoop is_tty show_prompt
 409                         _other      -> return ()) $
 410
 411   ghciUnblock $ do -- unblock necessary if we recursed from the
 412                    -- exception handler above.
 413
 414   -- read commands from stdin
 415 #ifdef USE_READLINE
 416   if (is_tty)
 417         then runCommands readlineLoop
 418         else runCommands (fileLoop stdin show_prompt is_tty)
 419 #else
 420   runCommands (fileLoop stdin show_prompt is_tty)
 421 #endif
 422
 423
 424 -- NOTE: We only read .ghci files if they are owned by the current user,
 425 -- and aren't world writable.  Otherwise, we could be accidentally
 426 -- running code planted by a malicious third party.
 427
 428 -- Furthermore, We only read ./.ghci if . is owned by the current user
 429 -- and isn't writable by anyone else.  I think this is sufficient: we
 430 -- don't need to check .. and ../.. etc. because "."  always refers to
 431 -- the same directory while a process is running.
 432
 433 checkPerms :: String -> IO Bool
 434 #ifdef mingw32_HOST_OS
 435 checkPerms _ =
 436   return True
 437 #else
 438 checkPerms name =
 439   Util.handle (\_ -> return False) $ do
 440      st <- getFileStatus name
 441      me <- getRealUserID
 442      if fileOwner st /= me then do
 443         putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
 444         return False
 445       else do
 446         let mode =  fileMode st
 447         if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
 448            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
 449            then do
 450                putStrLn $ "*** WARNING: " ++ name ++
 451                           " is writable by someone else, IGNORING!"
 452                return False
 453           else return True
 454 #endif
 455
 456 fileLoop :: Handle -> Bool -> Bool -> GHCi (Maybe String)
 457 fileLoop hdl show_prompt is_tty = do
 458    when show_prompt $ do
 459         prompt <- mkPrompt
 460         (io (putStr prompt))
 461    l <- io (IO.try (hGetLine hdl))
 462    case l of
 463         Left e | isEOFError e              -> return Nothing
 464                | InvalidArgument <- etype  -> return Nothing
 465                | otherwise                 -> io (ioError e)
 466                 where etype = ioeGetErrorType e
 467                 -- treat InvalidArgument in the same way as EOF:
 468                 -- this can happen if the user closed stdin, or
 469                 -- perhaps did getContents which closes stdin at
 470                 -- EOF.
 471         Right l -> do
 472                    str <- io $ consoleInputToUnicode is_tty l
 473                    return (Just str)
 474
 475 #ifdef mingw32_HOST_OS
 476 -- Convert the console input into Unicode according to the current code page.
 477 -- The Windows console stores Unicode characters directly, so this is a
 478 -- rather roundabout way of doing things... oh well.
 479 -- See #782, #1483, #1649
 480 consoleInputToUnicode :: Bool -> String -> IO String
 481 consoleInputToUnicode is_tty str
 482   | is_tty = do
 483     cp <- System.Win32.getConsoleCP
 484     System.Win32.stringToUnicode cp str
 485   | otherwise =
 486     decodeStringAsUTF8 str
 487 #else
 488 -- for Unix, assume the input is in UTF-8 and decode it to a Unicode String.
 489 -- See #782.
 490 consoleInputToUnicode :: Bool -> String -> IO String
 491 consoleInputToUnicode _is_tty str = decodeStringAsUTF8 str
 492 #endif
 493
 494 decodeStringAsUTF8 :: String -> IO String
 495 decodeStringAsUTF8 str =
 496   withCStringLen str $ \(cstr,len) ->
 497     utf8DecodeString (castPtr cstr :: Ptr Word8) len
 498
 499 mkPrompt :: GHCi String
 500 mkPrompt = do
 501   session <- getSession
 502   (toplevs,exports) <- io (GHC.getContext session)
 503   resumes <- io $ GHC.getResumeContext session
 504   -- st <- getGHCiState
 505
 506   context_bit <-
 507         case resumes of
 508             [] -> return empty
 509             r:_ -> do
 510                 let ix = GHC.resumeHistoryIx r
 511                 if ix == 0
 512                    then return (brackets (ppr (GHC.resumeSpan r)) <> space)
 513                    else do
 514                         let hist = GHC.resumeHistory r !! (ix-1)
 515                         span <- io$ GHC.getHistorySpan session hist
 516                         return (brackets (ppr (negate ix) <> char ':'
 517                                           <+> ppr span) <> space)
 518   let
 519         dots | _:rs <- resumes, not (null rs) = text "... "
 520              | otherwise = empty
 521
 522
 523
 524         modules_bit =
 525        -- ToDo: maybe...
 526        --  let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
 527        --  hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
 528        --  hsep (map (\m -> char '!'  <> ppr (GHC.moduleName m)) bexports) <+>
 529              hsep (map (\m -> char '*'  <> ppr (GHC.moduleName m)) toplevs) <+>
 530              hsep (map (ppr . GHC.moduleName) exports)
 531
 532         deflt_prompt = dots <> context_bit <> modules_bit
 533
 534         f ('%':'s':xs) = deflt_prompt <> f xs
 535         f ('%':'%':xs) = char '%' <> f xs
 536         f (x:xs) = char x <> f xs
 537         f [] = empty
 538    --
 539   st <- getGHCiState
 540   return (showSDoc (f (prompt st)))
 541
 542
 543 #ifdef USE_READLINE
 544 readlineLoop :: GHCi (Maybe String)
 545 readlineLoop = do
 546    io yield
 547    saveSession -- for use by completion
 548    prompt <- mkPrompt
 549    l <- io (readline prompt `finally` setNonBlockingFD 0)
 550                 -- readline sometimes puts stdin into blocking mode,
 551                 -- so we need to put it back for the IO library
 552    splatSavedSession
 553    case l of
 554         Nothing -> return Nothing
 555         Just l  -> do
 556                    io (addHistory l)
 557                    str <- io $ consoleInputToUnicode True l
 558                    return (Just str)
 559 #endif
 560
 561 queryQueue :: GHCi (Maybe String)
 562 queryQueue = do
 563   st <- getGHCiState
 564   case cmdqueue st of
 565     []   -> return Nothing
 566     c:cs -> do setGHCiState st{ cmdqueue = cs }
 567                return (Just c)
 568
 569 runCommands :: GHCi (Maybe String) -> GHCi ()
 570 runCommands getCmd = do
 571   mb_cmd <- noSpace queryQueue
 572   mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
 573   case mb_cmd of
 574     Nothing -> return ()
 575     Just c  -> do
 576       b <- ghciHandle handler (doCommand c)
 577       if b then return () else runCommands getCmd
 578   where
 579     noSpace q = q >>= maybe (return Nothing)
 580                             (\c->case removeSpaces c of
 581                                    ""   -> noSpace q
 582                                    ":{" -> multiLineCmd q
 583                                    c    -> return (Just c) )
 584     multiLineCmd q = do
 585       st <- getGHCiState
 586       let p = prompt st
 587       setGHCiState st{ prompt = "%s| " }
 588       mb_cmd <- collectCommand q ""
 589       getGHCiState >>= \st->setGHCiState st{ prompt = p }
 590       return mb_cmd
 591     -- we can't use removeSpaces for the sublines here, so
 592     -- multiline commands are somewhat more brittle against
 593     -- fileformat errors (such as \r in dos input on unix),
 594     -- we get rid of any extra spaces for the ":}" test;
 595     -- we also avoid silent failure if ":}" is not found;
 596     -- and since there is no (?) valid occurrence of \r (as
 597     -- opposed to its String representation, "\r") inside a
 598     -- ghci command, we replace any such with ' ' (argh:-(
 599     collectCommand q c = q >>=
 600       maybe (io (ioError collectError))
 601             (\l->if removeSpaces l == ":}"
 602                  then return (Just $ removeSpaces c)
 603                  else collectCommand q (c++map normSpace l))
 604       where normSpace '\r' = ' '
 605             normSpace   c  = c
 606     -- QUESTION: is userError the one to use here?
 607     collectError = userError "unterminated multiline command :{ .. :}"
 608     doCommand (':' : cmd) = specialCommand cmd
 609     doCommand stmt        = do timeIt $ runStmt stmt GHC.RunToCompletion
 610                                return False
 611
 612 enqueueCommands :: [String] -> GHCi ()
 613 enqueueCommands cmds = do
 614   st <- getGHCiState
 615   setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
 616
 617
 618 -- This version is for the GHC command-line option -e.  The only difference
 619 -- from runCommand is that it catches the ExitException exception and
 620 -- exits, rather than printing out the exception.
 621 runCommandEval :: String -> GHCi Bool
 622 runCommandEval c = ghciHandle handleEval (doCommand c)
 623   where
 624     handleEval (ExitException code) = io (exitWith code)
 625     handleEval e                    = do handler e
 626                                          io (exitWith (ExitFailure 1))
 627
 628     doCommand (':' : command) = specialCommand command
 629     doCommand stmt
 630        = do r <- runStmt stmt GHC.RunToCompletion
 631             case r of
 632                 False -> io (exitWith (ExitFailure 1))
 633                   -- failure to run the command causes exit(1) for ghc -e.
 634                 _       -> return True
 635
 636 runStmt :: String -> SingleStep -> GHCi Bool
 637 runStmt stmt step
 638  | null (filter (not.isSpace) stmt) = return False
 639  | ["import", mod] <- words stmt    = keepGoing setContext ('+':mod)
 640  | otherwise
 641  = do st <- getGHCiState
 642       session <- getSession
 643       result <- io $ withProgName (progname st) $ withArgs (args st) $
 644                      GHC.runStmt session stmt step
 645       afterRunStmt (const True) result
 646
 647
 648 --afterRunStmt :: GHC.RunResult -> GHCi Bool
 649                                  -- False <=> the statement failed to compile
 650 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
 651 afterRunStmt _ (GHC.RunException e) = throw e
 652 afterRunStmt step_here run_result = do
 653   session     <- getSession
 654   resumes <- io $ GHC.getResumeContext session
 655   case run_result of
 656      GHC.RunOk names -> do
 657         show_types <- isOptionSet ShowType
 658         when show_types $ printTypeOfNames session names
 659      GHC.RunBreak _ names mb_info
 660          | isNothing  mb_info ||
 661            step_here (GHC.resumeSpan $ head resumes) -> do
 662                printForUser $ ptext SLIT("Stopped at") <+>
 663                        ppr (GHC.resumeSpan $ head resumes)
 664 --               printTypeOfNames session names
 665                let namesSorted = sortBy compareNames names
 666                tythings <- catMaybes `liftM`
 667                               io (mapM (GHC.lookupName session) namesSorted)
 668                docs <- io$ pprTypeAndContents session [id | AnId id <- tythings]
 669                printForUserPartWay docs
 670                maybe (return ()) runBreakCmd mb_info
 671                -- run the command set with ":set stop <cmd>"
 672                st <- getGHCiState
 673                enqueueCommands [stop st]
 674                return ()
 675          | otherwise -> io(GHC.resume session GHC.SingleStep) >>=
 676                         afterRunStmt step_here >> return ()
 677      _ -> return ()
 678
 679   flushInterpBuffers
 680   io installSignalHandlers
 681   b <- isOptionSet RevertCAFs
 682   io (when b revertCAFs)
 683
 684   return (case run_result of GHC.RunOk _ -> True; _ -> False)
 685
 686 runBreakCmd :: GHC.BreakInfo -> GHCi ()
 687 runBreakCmd info = do
 688   let mod = GHC.breakInfo_module info
 689       nm  = GHC.breakInfo_number info
 690   st <- getGHCiState
 691   case  [ loc | (_,loc) <- breaks st,
 692                 breakModule loc == mod, breakTick loc == nm ] of
 693         []  -> return ()
 694         loc:_ | null cmd  -> return ()
 695               | otherwise -> do enqueueCommands [cmd]; return ()
 696               where cmd = onBreakCmd loc
 697
 698 printTypeOfNames :: Session -> [Name] -> GHCi ()
 699 printTypeOfNames session names
 700  = mapM_ (printTypeOfName session) $ sortBy compareNames names
 701
 702 compareNames :: Name -> Name -> Ordering
 703 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
 704     where compareWith n = (getOccString n, getSrcSpan n)
 705
 706 printTypeOfName :: Session -> Name -> GHCi ()
 707 printTypeOfName session n
 708    = do maybe_tything <- io (GHC.lookupName session n)
 709         case maybe_tything of
 710             Nothing    -> return ()
 711             Just thing -> printTyThing thing
 712
 713
 714
 715
 716 specialCommand :: String -> GHCi Bool
 717 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 718 specialCommand str = do
 719   let (cmd,rest) = break isSpace str
 720   maybe_cmd <- io (lookupCommand cmd)
 721   case maybe_cmd of
 722     Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
 723                                     ++ shortHelpText) >> return False)
 724     Just (_,f,_,_) -> f (dropWhile isSpace rest)
 725
 726 lookupCommand :: String -> IO (Maybe Command)
 727 lookupCommand str = do
 728   macros <- readIORef macros_ref
 729   let cmds = builtin_commands ++ macros
 730   -- look for exact match first, then the first prefix match
 731   case [ c | c <- cmds, str == cmdName c ] of
 732      c:_ -> return (Just c)
 733      [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
 734                 [] -> return Nothing
 735                 c:_ -> return (Just c)
 736
 737
 738 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
 739 getCurrentBreakSpan = do
 740   session <- getSession
 741   resumes <- io $ GHC.getResumeContext session
 742   case resumes of
 743     [] -> return Nothing
 744     (r:_) -> do
 745         let ix = GHC.resumeHistoryIx r
 746         if ix == 0
 747            then return (Just (GHC.resumeSpan r))
 748            else do
 749                 let hist = GHC.resumeHistory r !! (ix-1)
 750                 span <- io $ GHC.getHistorySpan session hist
 751                 return (Just span)
 752
 753 getCurrentBreakModule :: GHCi (Maybe Module)
 754 getCurrentBreakModule = do
 755   session <- getSession
 756   resumes <- io $ GHC.getResumeContext session
 757   case resumes of
 758     [] -> return Nothing
 759     (r:_) -> do
 760         let ix = GHC.resumeHistoryIx r
 761         if ix == 0
 762            then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
 763            else do
 764                 let hist = GHC.resumeHistory r !! (ix-1)
 765                 return $ Just $ GHC.getHistoryModule  hist
 766
 767 -----------------------------------------------------------------------------
 768 -- Commands
 769
 770 noArgs :: GHCi () -> String -> GHCi ()
 771 noArgs m "" = m
 772 noArgs _ _  = io $ putStrLn "This command takes no arguments"
 773
 774 help :: String -> GHCi ()
 775 help _ = io (putStr helpText)
 776
 777 info :: String -> GHCi ()
 778 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
 779 info s  = do { let names = words s
 780              ; session <- getSession
 781              ; dflags <- getDynFlags
 782              ; let pefas = dopt Opt_PrintExplicitForalls dflags
 783              ; mapM_ (infoThing pefas session) names }
 784   where
 785     infoThing pefas session str = io $ do
 786         names     <- GHC.parseName session str
 787         mb_stuffs <- mapM (GHC.getInfo session) names
 788         let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
 789         unqual <- GHC.getPrintUnqual session
 790         putStrLn (showSDocForUser unqual $
 791                    vcat (intersperse (text "") $
 792                          map (pprInfo pefas) filtered))
 793
 794   -- Filter out names whose parent is also there Good
 795   -- example is '[]', which is both a type and data
 796   -- constructor in the same type
 797 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
 798 filterOutChildren get_thing xs
 799   = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
 800   where
 801     implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
 802
 803 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
 804 pprInfo pefas (thing, fixity, insts)
 805   =  pprTyThingInContextLoc pefas thing
 806   $$ show_fixity fixity
 807   $$ vcat (map GHC.pprInstance insts)
 808   where
 809     show_fixity fix
 810         | fix == GHC.defaultFixity = empty
 811         | otherwise                = ppr fix <+> ppr (GHC.getName thing)
 812
 813 runMain :: String -> GHCi ()
 814 runMain args = do
 815   let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
 816   enqueueCommands  ['[': ss ++ "] `System.Environment.withArgs` main"]
 817
 818 addModule :: [FilePath] -> GHCi ()
 819 addModule files = do
 820   io (revertCAFs)                       -- always revert CAFs on load/add.
 821   files <- mapM expandPath files
 822   targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
 823   session <- getSession
 824   io (mapM_ (GHC.addTarget session) targets)
 825   prev_context <- io $ GHC.getContext session
 826   ok <- io (GHC.load session LoadAllTargets)
 827   afterLoad ok session False prev_context
 828
 829 changeDirectory :: String -> GHCi ()
 830 changeDirectory dir = do
 831   session <- getSession
 832   graph <- io (GHC.getModuleGraph session)
 833   when (not (null graph)) $
 834         io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
 835   prev_context <- io $ GHC.getContext session
 836   io (GHC.setTargets session [])
 837   io (GHC.load session LoadAllTargets)
 838   setContextAfterLoad session prev_context []
 839   io (GHC.workingDirectoryChanged session)
 840   dir <- expandPath dir
 841   io (setCurrentDirectory dir)
 842
 843 editFile :: String -> GHCi ()
 844 editFile str =
 845   do file <- if null str then chooseEditFile else return str
 846      st <- getGHCiState
 847      let cmd = editor st
 848      when (null cmd)
 849        $ throwDyn (CmdLineError "editor not set, use :set editor")
 850      io $ system (cmd ++ ' ':file)
 851      return ()
 852
 853 -- The user didn't specify a file so we pick one for them.
 854 -- Our strategy is to pick the first module that failed to load,
 855 -- or otherwise the first target.
 856 --
 857 -- XXX: Can we figure out what happened if the depndecy analysis fails
 858 --      (e.g., because the porgrammeer mistyped the name of a module)?
 859 -- XXX: Can we figure out the location of an error to pass to the editor?
 860 -- XXX: if we could figure out the list of errors that occured during the
 861 -- last load/reaload, then we could start the editor focused on the first
 862 -- of those.
 863 chooseEditFile :: GHCi String
 864 chooseEditFile =
 865   do session <- getSession
 866      let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
 867
 868      graph <- io (GHC.getModuleGraph session)
 869      failed_graph <- filterM hasFailed graph
 870      let order g  = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
 871          pick xs  = case xs of
 872                       x : _ -> GHC.ml_hs_file (GHC.ms_location x)
 873                       _     -> Nothing
 874
 875      case pick (order failed_graph) of
 876        Just file -> return file
 877        Nothing   ->
 878          do targets <- io (GHC.getTargets session)
 879             case msum (map fromTarget targets) of
 880               Just file -> return file
 881               Nothing   -> throwDyn (CmdLineError "No files to edit.")
 882
 883   where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
 884         fromTarget _ = Nothing -- when would we get a module target?
 885
 886 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
 887 defineMacro overwrite s = do
 888   let (macro_name, definition) = break isSpace s
 889   macros <- io (readIORef macros_ref)
 890   let defined = map cmdName macros
 891   if (null macro_name)
 892         then if null defined
 893                 then io $ putStrLn "no macros defined"
 894                 else io $ putStr ("the following macros are defined:\n" ++
 895                                   unlines defined)
 896         else do
 897   if (not overwrite && macro_name `elem` defined)
 898         then throwDyn (CmdLineError
 899                 ("macro '" ++ macro_name ++ "' is already defined"))
 900         else do
 901
 902   let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
 903
 904   -- give the expression a type signature, so we can be sure we're getting
 905   -- something of the right type.
 906   let new_expr = '(' : definition ++ ") :: String -> IO String"
 907
 908   -- compile the expression
 909   cms <- getSession
 910   maybe_hv <- io (GHC.compileExpr cms new_expr)
 911   case maybe_hv of
 912      Nothing -> return ()
 913      Just hv -> io (writeIORef macros_ref --
 914                     (filtered ++ [(macro_name, runMacro hv, False, completeNone)]))
 915
 916 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
 917 runMacro fun s = do
 918   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 919   enqueueCommands (lines str)
 920   return False
 921
 922 undefineMacro :: String -> GHCi ()
 923 undefineMacro str = mapM_ undef (words str)
 924  where undef macro_name = do
 925         cmds <- io (readIORef macros_ref)
 926         if (macro_name `notElem` map cmdName cmds)
 927            then throwDyn (CmdLineError
 928                 ("macro '" ++ macro_name ++ "' is not defined"))
 929            else do
 930             io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
 931
 932 cmdCmd :: String -> GHCi ()
 933 cmdCmd str = do
 934   let expr = '(' : str ++ ") :: IO String"
 935   session <- getSession
 936   maybe_hv <- io (GHC.compileExpr session expr)
 937   case maybe_hv of
 938     Nothing -> return ()
 939     Just hv -> do
 940         cmds <- io $ (unsafeCoerce# hv :: IO String)
 941         enqueueCommands (lines cmds)
 942         return ()
 943
 944 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 945 loadModule fs = timeIt (loadModule' fs)
 946
 947 loadModule_ :: [FilePath] -> GHCi ()
 948 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
 949
 950 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 951 loadModule' files = do
 952   session <- getSession
 953   prev_context <- io $ GHC.getContext session
 954
 955   -- unload first
 956   discardActiveBreakPoints
 957   io (GHC.setTargets session [])
 958   io (GHC.load session LoadAllTargets)
 959
 960   -- expand tildes
 961   let (filenames, phases) = unzip files
 962   exp_filenames <- mapM expandPath filenames
 963   let files' = zip exp_filenames phases
 964   targets <- io (mapM (uncurry GHC.guessTarget) files')
 965
 966   -- NOTE: we used to do the dependency anal first, so that if it
 967   -- fails we didn't throw away the current set of modules.  This would
 968   -- require some re-working of the GHC interface, so we'll leave it
 969   -- as a ToDo for now.
 970
 971   io (GHC.setTargets session targets)
 972   doLoad session False prev_context LoadAllTargets
 973
 974 checkModule :: String -> GHCi ()
 975 checkModule m = do
 976   let modl = GHC.mkModuleName m
 977   session <- getSession
 978   prev_context <- io $ GHC.getContext session
 979   result <- io (GHC.checkModule session modl False)
 980   case result of
 981     Nothing -> io $ putStrLn "Nothing"
 982     Just r  -> io $ putStrLn (showSDoc (
 983         case GHC.checkedModuleInfo r of
 984            Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
 985                 let
 986                     (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
 987                 in
 988                         (text "global names: " <+> ppr global) $$
 989                         (text "local  names: " <+> ppr local)
 990            _ -> empty))
 991   afterLoad (successIf (isJust result)) session False prev_context
 992
 993 reloadModule :: String -> GHCi ()
 994 reloadModule m = do
 995   session <- getSession
 996   prev_context <- io $ GHC.getContext session
 997   doLoad session True prev_context $
 998         if null m then LoadAllTargets
 999                   else LoadUpTo (GHC.mkModuleName m)
1000   return ()
1001
1002 doLoad :: Session -> Bool -> ([Module],[Module]) -> LoadHowMuch -> GHCi SuccessFlag
1003 doLoad session retain_context prev_context howmuch = do
1004   -- turn off breakpoints before we load: we can't turn them off later, because
1005   -- the ModBreaks will have gone away.
1006   discardActiveBreakPoints
1007   ok <- io (GHC.load session howmuch)
1008   afterLoad ok session retain_context prev_context
1009   return ok
1010
1011 afterLoad :: SuccessFlag -> Session -> Bool -> ([Module],[Module]) -> GHCi ()
1012 afterLoad ok session retain_context prev_context = do
1013   io (revertCAFs)  -- always revert CAFs on load.
1014   discardTickArrays
1015   loaded_mod_summaries <- getLoadedModules session
1016   let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1017       loaded_mod_names = map GHC.moduleName loaded_mods
1018   modulesLoadedMsg ok loaded_mod_names
1019
1020   st <- getGHCiState
1021   if not retain_context
1022     then do
1023         setGHCiState st{ remembered_ctx = Nothing }
1024         setContextAfterLoad session prev_context loaded_mod_summaries
1025     else do
1026         -- figure out which modules we can keep in the context, which we
1027         -- have to put back, and which we have to remember because they
1028         -- are (temporarily) unavailable.  See ghci.prog009, #1873, #1360
1029         let (as,bs) = prev_context
1030             as1 = filter isHomeModule as -- package modules are kept anyway
1031             bs1 = filter isHomeModule bs
1032             (as_ok, as_bad) = partition (`elem` loaded_mods) as1
1033             (bs_ok, bs_bad) = partition (`elem` loaded_mods) bs1
1034             (rem_as, rem_bs) = fromMaybe ([],[]) (remembered_ctx st)
1035             (rem_as_ok, rem_as_bad) = partition (`elem` loaded_mods) rem_as
1036             (rem_bs_ok, rem_bs_bad) = partition (`elem` loaded_mods) rem_bs
1037             as' = nub (as_ok++rem_as_ok)
1038             bs' = nub (bs_ok++rem_bs_ok)
1039             rem_as' = nub (rem_as_bad ++ as_bad)
1040             rem_bs' = nub (rem_bs_bad ++ bs_bad)
1041
1042          -- Put back into the context any modules that we previously had
1043          -- to drop because they weren't available (rem_as_ok, rem_bs_ok).
1044         setContextKeepingPackageModules session prev_context (as',bs')
1045
1046          -- If compilation failed, remember any modules that we are unable
1047          -- to load, so that we can put them back in the context in the future.
1048         case ok of
1049          Succeeded -> setGHCiState st{ remembered_ctx = Nothing }
1050          Failed    -> setGHCiState st{ remembered_ctx = Just (rem_as',rem_bs') }
1051
1052
1053
1054 setContextAfterLoad :: Session -> ([Module],[Module]) -> [GHC.ModSummary] -> GHCi ()
1055 setContextAfterLoad session prev [] = do
1056   prel_mod <- getPrelude
1057   setContextKeepingPackageModules session prev ([], [prel_mod])
1058 setContextAfterLoad session prev ms = do
1059   -- load a target if one is available, otherwise load the topmost module.
1060   targets <- io (GHC.getTargets session)
1061   case [ m | Just m <- map (findTarget ms) targets ] of
1062         []    ->
1063           let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1064           load_this (last graph')
1065         (m:_) ->
1066           load_this m
1067  where
1068    findTarget ms t
1069     = case filter (`matches` t) ms of
1070         []    -> Nothing
1071         (m:_) -> Just m
1072
1073    summary `matches` Target (TargetModule m) _
1074         = GHC.ms_mod_name summary == m
1075    summary `matches` Target (TargetFile f _) _
1076         | Just f' <- GHC.ml_hs_file (GHC.ms_location summary)   = f == f'
1077    _ `matches` _
1078         = False
1079
1080    load_this summary | m <- GHC.ms_mod summary = do
1081         b <- io (GHC.moduleIsInterpreted session m)
1082         if b then setContextKeepingPackageModules session prev ([m], [])
1083              else do
1084                 prel_mod <- getPrelude
1085                 setContextKeepingPackageModules session prev ([],[prel_mod,m])
1086
1087 -- | Keep any package modules (except Prelude) when changing the context.
1088 setContextKeepingPackageModules
1089         :: Session
1090         -> ([Module],[Module])          -- previous context
1091         -> ([Module],[Module])          -- new context
1092         -> GHCi ()
1093 setContextKeepingPackageModules session prev_context (as,bs) = do
1094   let (_,bs0) = prev_context
1095   prel_mod <- getPrelude
1096   let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1097   let bs1 = if null as then nub (prel_mod : bs) else bs
1098   io $ GHC.setContext session as (nub (bs1 ++ pkg_modules))
1099
1100 isHomeModule :: Module -> Bool
1101 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1102
1103 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
1104 modulesLoadedMsg ok mods = do
1105   dflags <- getDynFlags
1106   when (verbosity dflags > 0) $ do
1107    let mod_commas
1108         | null mods = text "none."
1109         | otherwise = hsep (
1110             punctuate comma (map ppr mods)) <> text "."
1111    case ok of
1112     Failed ->
1113        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
1114     Succeeded  ->
1115        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
1116
1117
1118 typeOfExpr :: String -> GHCi ()
1119 typeOfExpr str
1120   = do cms <- getSession
1121        maybe_ty <- io (GHC.exprType cms str)
1122        case maybe_ty of
1123           Nothing -> return ()
1124           Just ty -> do dflags <- getDynFlags
1125                         let pefas = dopt Opt_PrintExplicitForalls dflags
1126                         printForUser $ text str <+> dcolon
1127                                         <+> pprTypeForUser pefas ty
1128
1129 kindOfType :: String -> GHCi ()
1130 kindOfType str
1131   = do cms <- getSession
1132        maybe_ty <- io (GHC.typeKind cms str)
1133        case maybe_ty of
1134           Nothing    -> return ()
1135           Just ty    -> printForUser $ text str <+> dcolon <+> ppr ty
1136
1137 quit :: String -> GHCi Bool
1138 quit _ = return True
1139
1140 shellEscape :: String -> GHCi Bool
1141 shellEscape str = io (system str >> return False)
1142
1143 -----------------------------------------------------------------------------
1144 -- Browsing a module's contents
1145
1146 browseCmd :: Bool -> String -> GHCi ()
1147 browseCmd bang m =
1148   case words m of
1149     ['*':s] | looksLikeModuleName s -> do
1150         m <-  wantInterpretedModule s
1151         browseModule bang m False
1152     [s] | looksLikeModuleName s -> do
1153         m <- lookupModule s
1154         browseModule bang m True
1155     [] -> do
1156         s <- getSession
1157         (as,bs) <- io $ GHC.getContext s
1158                 -- Guess which module the user wants to browse.  Pick
1159                 -- modules that are interpreted first.  The most
1160                 -- recently-added module occurs last, it seems.
1161         case (as,bs) of
1162           (as@(_:_), _)   -> browseModule bang (last as) True
1163           ([],  bs@(_:_)) -> browseModule bang (last bs) True
1164           ([],  [])  -> throwDyn (CmdLineError ":browse: no current module")
1165     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
1166
1167 -- without bang, show items in context of their parents and omit children
1168 -- with bang, show class methods and data constructors separately, and
1169 --            indicate import modules, to aid qualifying unqualified names
1170 -- with sorted, sort items alphabetically
1171 browseModule :: Bool -> Module -> Bool -> GHCi ()
1172 browseModule bang modl exports_only = do
1173   s <- getSession
1174   -- :browse! reports qualifiers wrt current context
1175   current_unqual <- io (GHC.getPrintUnqual s)
1176   -- Temporarily set the context to the module we're interested in,
1177   -- just so we can get an appropriate PrintUnqualified
1178   (as,bs) <- io (GHC.getContext s)
1179   prel_mod <- getPrelude
1180   io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1181                       else GHC.setContext s [modl] [])
1182   target_unqual <- io (GHC.getPrintUnqual s)
1183   io (GHC.setContext s as bs)
1184
1185   let unqual = if bang then current_unqual else target_unqual
1186
1187   mb_mod_info <- io $ GHC.getModuleInfo s modl
1188   case mb_mod_info of
1189     Nothing -> throwDyn (CmdLineError ("unknown module: " ++
1190                                 GHC.moduleNameString (GHC.moduleName modl)))
1191     Just mod_info -> do
1192         dflags <- getDynFlags
1193         let names
1194                | exports_only = GHC.modInfoExports mod_info
1195                | otherwise    = GHC.modInfoTopLevelScope mod_info
1196                                 `orElse` []
1197
1198                 -- sort alphabetically name, but putting
1199                 -- locally-defined identifiers first.
1200                 -- We would like to improve this; see #1799.
1201             sorted_names = loc_sort local ++ occ_sort external
1202                 where
1203                 (local,external) = partition ((==modl) . nameModule) names
1204                 occ_sort = sortBy (compare `on` nameOccName)
1205                 -- try to sort by src location.  If the first name in
1206                 -- our list has a good source location, then they all should.
1207                 loc_sort names
1208                       | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1209                       = sortBy (compare `on` nameSrcSpan) names
1210                       | otherwise
1211                       = occ_sort names
1212
1213         mb_things <- io $ mapM (GHC.lookupName s) sorted_names
1214         let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1215
1216         rdr_env <- io $ GHC.getGRE s
1217
1218         let pefas              = dopt Opt_PrintExplicitForalls dflags
1219             things | bang      = catMaybes mb_things
1220                    | otherwise = filtered_things
1221             pretty | bang      = pprTyThing
1222                    | otherwise = pprTyThingInContext
1223
1224             labels  [] = text "-- not currently imported"
1225             labels  l  = text $ intercalate "\n" $ map qualifier l
1226             qualifier  = maybe "-- defined locally"
1227                              (("-- imported via "++) . intercalate ", "
1228                                . map GHC.moduleNameString)
1229             importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1230             modNames   = map (importInfo . GHC.getName) things
1231
1232             -- annotate groups of imports with their import modules
1233             -- the default ordering is somewhat arbitrary, so we group
1234             -- by header and sort groups; the names themselves should
1235             -- really come in order of source appearance.. (trac #1799)
1236             annotate mts = concatMap (\(m,ts)->labels m:ts)
1237                          $ sortBy cmpQualifiers $ group mts
1238               where cmpQualifiers =
1239                       compare `on` (map (fmap (map moduleNameFS)) . fst)
1240             group []            = []
1241             group mts@((m,_):_) = (m,map snd g) : group ng
1242               where (g,ng) = partition ((==m).fst) mts
1243
1244         let prettyThings = map (pretty pefas) things
1245             prettyThings' | bang      = annotate $ zip modNames prettyThings
1246                           | otherwise = prettyThings
1247         io (putStrLn $ showSDocForUser unqual (vcat prettyThings'))
1248         -- ToDo: modInfoInstances currently throws an exception for
1249         -- package modules.  When it works, we can do this:
1250         --        $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1251
1252 -----------------------------------------------------------------------------
1253 -- Setting the module context
1254
1255 setContext :: String -> GHCi ()
1256 setContext str
1257   | all sensible mods = fn mods
1258   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
1259   where
1260     (fn, mods) = case str of
1261                         '+':stuff -> (addToContext,      words stuff)
1262                         '-':stuff -> (removeFromContext, words stuff)
1263                         stuff     -> (newContext,        words stuff)
1264
1265     sensible ('*':m) = looksLikeModuleName m
1266     sensible m       = looksLikeModuleName m
1267
1268 separate :: Session -> [String] -> [Module] -> [Module]
1269         -> GHCi ([Module],[Module])
1270 separate _       []             as bs = return (as,bs)
1271 separate session (('*':str):ms) as bs = do
1272   m <- wantInterpretedModule str
1273   separate session ms (m:as) bs
1274 separate session (str:ms) as bs = do
1275   m <- lookupModule str
1276   separate session ms as (m:bs)
1277
1278 newContext :: [String] -> GHCi ()
1279 newContext strs = do
1280   s <- getSession
1281   (as,bs) <- separate s strs [] []
1282   prel_mod <- getPrelude
1283   let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1284   io $ GHC.setContext s as bs'
1285
1286
1287 addToContext :: [String] -> GHCi ()
1288 addToContext strs = do
1289   s <- getSession
1290   (as,bs) <- io $ GHC.getContext s
1291
1292   (new_as,new_bs) <- separate s strs [] []
1293
1294   let as_to_add = new_as \\ (as ++ bs)
1295       bs_to_add = new_bs \\ (as ++ bs)
1296
1297   io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1298
1299
1300 removeFromContext :: [String] -> GHCi ()
1301 removeFromContext strs = do
1302   s <- getSession
1303   (as,bs) <- io $ GHC.getContext s
1304
1305   (as_to_remove,bs_to_remove) <- separate s strs [] []
1306
1307   let as' = as \\ (as_to_remove ++ bs_to_remove)
1308       bs' = bs \\ (as_to_remove ++ bs_to_remove)
1309
1310   io $ GHC.setContext s as' bs'
1311
1312 ----------------------------------------------------------------------------
1313 -- Code for `:set'
1314
1315 -- set options in the interpreter.  Syntax is exactly the same as the
1316 -- ghc command line, except that certain options aren't available (-C,
1317 -- -E etc.)
1318 --
1319 -- This is pretty fragile: most options won't work as expected.  ToDo:
1320 -- figure out which ones & disallow them.
1321
1322 setCmd :: String -> GHCi ()
1323 setCmd ""
1324   = do st <- getGHCiState
1325        let opts = options st
1326        io $ putStrLn (showSDoc (
1327               text "options currently set: " <>
1328               if null opts
1329                    then text "none."
1330                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1331            ))
1332        dflags <- getDynFlags
1333        io $ putStrLn (showSDoc (
1334           vcat (text "GHCi-specific dynamic flag settings:"
1335                :map (flagSetting dflags) ghciFlags)
1336           ))
1337        io $ putStrLn (showSDoc (
1338           vcat (text "other dynamic, non-language, flag settings:"
1339                :map (flagSetting dflags) nonLanguageDynFlags)
1340           ))
1341   where flagSetting dflags (str,f)
1342           | dopt f dflags = text "  " <> text "-f"    <> text str
1343           | otherwise     = text "  " <> text "-fno-" <> text str
1344         (ghciFlags,others)  = partition (\(_,f)->f `elem` flags)
1345                                         DynFlags.fFlags
1346         nonLanguageDynFlags = filter (\(_,f)->not $ f `elem` map snd xFlags)
1347                                      others
1348         flags = [Opt_PrintExplicitForalls
1349                 ,Opt_PrintBindResult
1350                 ,Opt_BreakOnException
1351                 ,Opt_BreakOnError
1352                 ,Opt_PrintEvldWithShow
1353                 ]
1354 setCmd str
1355   = case toArgs str of
1356         ("args":args) -> setArgs args
1357         ("prog":prog) -> setProg prog
1358         ("prompt":_)  -> setPrompt (after 6)
1359         ("editor":_)  -> setEditor (after 6)
1360         ("stop":_)    -> setStop (after 4)
1361         wds -> setOptions wds
1362    where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1363
1364 setArgs, setProg, setOptions :: [String] -> GHCi ()
1365 setEditor, setStop, setPrompt :: String -> GHCi ()
1366
1367 setArgs args = do
1368   st <- getGHCiState
1369   setGHCiState st{ args = args }
1370
1371 setProg [prog] = do
1372   st <- getGHCiState
1373   setGHCiState st{ progname = prog }
1374 setProg _ = do
1375   io (hPutStrLn stderr "syntax: :set prog <progname>")
1376
1377 setEditor cmd = do
1378   st <- getGHCiState
1379   setGHCiState st{ editor = cmd }
1380
1381 setStop str@(c:_) | isDigit c
1382   = do let (nm_str,rest) = break (not.isDigit) str
1383            nm = read nm_str
1384        st <- getGHCiState
1385        let old_breaks = breaks st
1386        if all ((/= nm) . fst) old_breaks
1387               then printForUser (text "Breakpoint" <+> ppr nm <+>
1388                                  text "does not exist")
1389               else do
1390        let new_breaks = map fn old_breaks
1391            fn (i,loc) | i == nm   = (i,loc { onBreakCmd = dropWhile isSpace rest })
1392                       | otherwise = (i,loc)
1393        setGHCiState st{ breaks = new_breaks }
1394 setStop cmd = do
1395   st <- getGHCiState
1396   setGHCiState st{ stop = cmd }
1397
1398 setPrompt value = do
1399   st <- getGHCiState
1400   if null value
1401       then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1402       else setGHCiState st{ prompt = remQuotes value }
1403   where
1404      remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1405      remQuotes x = x
1406
1407 setOptions wds =
1408    do -- first, deal with the GHCi opts (+s, +t, etc.)
1409       let (plus_opts, minus_opts)  = partitionWith isPlus wds
1410       mapM_ setOpt plus_opts
1411       -- then, dynamic flags
1412       newDynFlags minus_opts
1413
1414 newDynFlags :: [String] -> GHCi ()
1415 newDynFlags minus_opts = do
1416       dflags <- getDynFlags
1417       let pkg_flags = packageFlags dflags
1418       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1419
1420       if (not (null leftovers))
1421                 then throwDyn (CmdLineError ("unrecognised flags: " ++
1422                                                 unwords leftovers))
1423                 else return ()
1424
1425       new_pkgs <- setDynFlags dflags'
1426
1427       -- if the package flags changed, we should reset the context
1428       -- and link the new packages.
1429       dflags <- getDynFlags
1430       when (packageFlags dflags /= pkg_flags) $ do
1431         io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1432         session <- getSession
1433         io (GHC.setTargets session [])
1434         io (GHC.load session LoadAllTargets)
1435         io (linkPackages dflags new_pkgs)
1436         -- package flags changed, we can't re-use any of the old context
1437         setContextAfterLoad session ([],[]) []
1438       return ()
1439
1440
1441 unsetOptions :: String -> GHCi ()
1442 unsetOptions str
1443   = do -- first, deal with the GHCi opts (+s, +t, etc.)
1444        let opts = words str
1445            (minus_opts, rest1) = partition isMinus opts
1446            (plus_opts, rest2)  = partitionWith isPlus rest1
1447
1448        if (not (null rest2))
1449           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1450           else do
1451
1452        mapM_ unsetOpt plus_opts
1453
1454        let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1455            no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1456
1457        no_flags <- mapM no_flag minus_opts
1458        newDynFlags no_flags
1459
1460 isMinus :: String -> Bool
1461 isMinus ('-':_) = True
1462 isMinus _ = False
1463
1464 isPlus :: String -> Either String String
1465 isPlus ('+':opt) = Left opt
1466 isPlus other     = Right other
1467
1468 setOpt, unsetOpt :: String -> GHCi ()
1469
1470 setOpt str
1471   = case strToGHCiOpt str of
1472         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1473         Just o  -> setOption o
1474
1475 unsetOpt str
1476   = case strToGHCiOpt str of
1477         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1478         Just o  -> unsetOption o
1479
1480 strToGHCiOpt :: String -> (Maybe GHCiOption)
1481 strToGHCiOpt "s" = Just ShowTiming
1482 strToGHCiOpt "t" = Just ShowType
1483 strToGHCiOpt "r" = Just RevertCAFs
1484 strToGHCiOpt _   = Nothing
1485
1486 optToStr :: GHCiOption -> String
1487 optToStr ShowTiming = "s"
1488 optToStr ShowType   = "t"
1489 optToStr RevertCAFs = "r"
1490
1491 -- ---------------------------------------------------------------------------
1492 -- code for `:show'
1493
1494 showCmd :: String -> GHCi ()
1495 showCmd str = do
1496   st <- getGHCiState
1497   case words str of
1498         ["args"]     -> io $ putStrLn (show (args st))
1499         ["prog"]     -> io $ putStrLn (show (progname st))
1500         ["prompt"]   -> io $ putStrLn (show (prompt st))
1501         ["editor"]   -> io $ putStrLn (show (editor st))
1502         ["stop"]     -> io $ putStrLn (show (stop st))
1503         ["modules" ] -> showModules
1504         ["bindings"] -> showBindings
1505         ["linker"]   -> io showLinkerState
1506         ["breaks"]   -> showBkptTable
1507         ["context"]  -> showContext
1508         ["packages"]  -> showPackages
1509         ["languages"]  -> showLanguages
1510         _ -> throwDyn (CmdLineError "syntax:  :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1511
1512 showModules :: GHCi ()
1513 showModules = do
1514   session <- getSession
1515   loaded_mods <- getLoadedModules session
1516         -- we want *loaded* modules only, see #1734
1517   let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m)
1518   mapM_ show_one loaded_mods
1519
1520 getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary]
1521 getLoadedModules session = do
1522   graph <- io (GHC.getModuleGraph session)
1523   filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
1524
1525 showBindings :: GHCi ()
1526 showBindings = do
1527   s <- getSession
1528   bindings <- io (GHC.getBindings s)
1529   docs     <- io$ pprTypeAndContents s
1530                   [ id | AnId id <- sortBy compareTyThings bindings]
1531   printForUserPartWay docs
1532
1533 compareTyThings :: TyThing -> TyThing -> Ordering
1534 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1535
1536 printTyThing :: TyThing -> GHCi ()
1537 printTyThing tyth = do dflags <- getDynFlags
1538                        let pefas = dopt Opt_PrintExplicitForalls dflags
1539                        printForUser (pprTyThing pefas tyth)
1540
1541 showBkptTable :: GHCi ()
1542 showBkptTable = do
1543   st <- getGHCiState
1544   printForUser $ prettyLocations (breaks st)
1545
1546 showContext :: GHCi ()
1547 showContext = do
1548    session <- getSession
1549    resumes <- io $ GHC.getResumeContext session
1550    printForUser $ vcat (map pp_resume (reverse resumes))
1551   where
1552    pp_resume resume =
1553         ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1554         $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1555
1556 showPackages :: GHCi ()
1557 showPackages = do
1558   pkg_flags <- fmap packageFlags getDynFlags
1559   io $ putStrLn $ showSDoc $ vcat $
1560     text ("active package flags:"++if null pkg_flags then " none" else "")
1561     : map showFlag pkg_flags
1562   pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1563   io $ putStrLn $ showSDoc $ vcat $
1564     text "packages currently loaded:"
1565     : map (nest 2 . text . packageIdString) pkg_ids
1566   where showFlag (ExposePackage p) = text $ "  -package " ++ p
1567         showFlag (HidePackage p)   = text $ "  -hide-package " ++ p
1568         showFlag (IgnorePackage p) = text $ "  -ignore-package " ++ p
1569
1570 showLanguages :: GHCi ()
1571 showLanguages = do
1572    dflags <- getDynFlags
1573    io $ putStrLn $ showSDoc $ vcat $
1574       text "active language flags:" :
1575       [text ("  -X" ++ str) | (str,f) <- DynFlags.xFlags, dopt f dflags]
1576
1577 -- -----------------------------------------------------------------------------
1578 -- Completion
1579
1580 completeNone :: String -> IO [String]
1581 completeNone _w = return []
1582
1583 completeMacro, completeIdentifier, completeModule,
1584     completeHomeModule, completeSetOptions, completeFilename,
1585     completeHomeModuleOrFile
1586     :: String -> IO [String]
1587
1588 #ifdef USE_READLINE
1589 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1590 completeWord w start end = do
1591   line <- Readline.getLineBuffer
1592   let line_words = words (dropWhile isSpace line)
1593   case w of
1594      ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1595      _other
1596         | ((':':c) : _) <- line_words -> do
1597            maybe_cmd <- lookupCommand c
1598            let (n,w') = selectWord (words' 0 line)
1599            case maybe_cmd of
1600              Nothing -> return Nothing
1601              Just (_,_,False,complete) -> wrapCompleter complete w
1602              Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1603                                                               return (map (drop n) rets)
1604                                          in wrapCompleter complete' w'
1605         | ("import" : _) <- line_words ->
1606                 wrapCompleter completeModule w
1607         | otherwise     -> do
1608                 --printf "complete %s, start = %d, end = %d\n" w start end
1609                 wrapCompleter completeIdentifier w
1610     where words' _ [] = []
1611           words' n str = let (w,r) = break isSpace str
1612                              (s,r') = span isSpace r
1613                          in (n,w):words' (n+length w+length s) r'
1614           -- In a Haskell expression we want to parse 'a-b' as three words
1615           -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1616           -- only be a single word.
1617           selectWord [] = (0,w)
1618           selectWord ((offset,x):xs)
1619               | offset+length x >= start = (start-offset,take (end-offset) x)
1620               | otherwise = selectWord xs
1621
1622 completeCmd :: String -> IO [String]
1623 completeCmd w = do
1624   cmds <- readIORef macros_ref
1625   return (filter (w `isPrefixOf`) (map (':':)
1626              (map cmdName (builtin_commands ++ cmds))))
1627
1628 completeMacro w = do
1629   cmds <- readIORef macros_ref
1630   return (filter (w `isPrefixOf`) (map cmdName cmds))
1631
1632 completeIdentifier w = do
1633   s <- restoreSession
1634   rdrs <- GHC.getRdrNamesInScope s
1635   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1636
1637 completeModule w = do
1638   s <- restoreSession
1639   dflags <- GHC.getSessionDynFlags s
1640   let pkg_mods = allExposedModules dflags
1641   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1642
1643 completeHomeModule w = do
1644   s <- restoreSession
1645   g <- GHC.getModuleGraph s
1646   let home_mods = map GHC.ms_mod_name g
1647   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1648
1649 completeSetOptions w = do
1650   return (filter (w `isPrefixOf`) options)
1651     where options = "args":"prog":allFlags
1652
1653 completeFilename = Readline.filenameCompletionFunction
1654
1655 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1656
1657 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1658 unionComplete f1 f2 w = do
1659   s1 <- f1 w
1660   s2 <- f2 w
1661   return (s1 ++ s2)
1662
1663 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1664 wrapCompleter fun w =  do
1665   strs <- fun w
1666   case strs of
1667     []  -> return Nothing
1668     [x] -> return (Just (x,[]))
1669     xs  -> case getCommonPrefix xs of
1670                 ""   -> return (Just ("",xs))
1671                 pref -> return (Just (pref,xs))
1672
1673 getCommonPrefix :: [String] -> String
1674 getCommonPrefix [] = ""
1675 getCommonPrefix (s:ss) = foldl common s ss
1676   where common _s "" = ""
1677         common "" _s = ""
1678         common (c:cs) (d:ds)
1679            | c == d = c : common cs ds
1680            | otherwise = ""
1681
1682 allExposedModules :: DynFlags -> [ModuleName]
1683 allExposedModules dflags
1684  = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1685  where
1686   pkg_db = pkgIdMap (pkgState dflags)
1687 #else
1688 completeMacro      = completeNone
1689 completeIdentifier = completeNone
1690 completeModule     = completeNone
1691 completeHomeModule = completeNone
1692 completeSetOptions = completeNone
1693 completeFilename   = completeNone
1694 completeHomeModuleOrFile=completeNone
1695 #endif
1696
1697 -- ---------------------------------------------------------------------------
1698 -- User code exception handling
1699
1700 -- This is the exception handler for exceptions generated by the
1701 -- user's code and exceptions coming from children sessions;
1702 -- it normally just prints out the exception.  The
1703 -- handler must be recursive, in case showing the exception causes
1704 -- more exceptions to be raised.
1705 --
1706 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1707 -- raising another exception.  We therefore don't put the recursive
1708 -- handler arond the flushing operation, so if stderr is closed
1709 -- GHCi will just die gracefully rather than going into an infinite loop.
1710 handler :: Exception -> GHCi Bool
1711
1712 handler exception = do
1713   flushInterpBuffers
1714   io installSignalHandlers
1715   ghciHandle handler (showException exception >> return False)
1716
1717 showException :: Exception -> GHCi ()
1718 showException (DynException dyn) =
1719   case fromDynamic dyn of
1720     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
1721     Just Interrupted      -> io (putStrLn "Interrupted.")
1722     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
1723     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1724     Just other_ghc_ex     -> io (print other_ghc_ex)
1725
1726 showException other_exception
1727   = io (putStrLn ("*** Exception: " ++ show other_exception))
1728
1729 -----------------------------------------------------------------------------
1730 -- recursive exception handlers
1731
1732 -- Don't forget to unblock async exceptions in the handler, or if we're
1733 -- in an exception loop (eg. let a = error a in a) the ^C exception
1734 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1735
1736 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1737 ghciHandle h (GHCi m) = GHCi $ \s ->
1738    Exception.catch (m s)
1739         (\e -> unGHCi (ghciUnblock (h e)) s)
1740
1741 ghciUnblock :: GHCi a -> GHCi a
1742 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1743
1744
1745 -- ----------------------------------------------------------------------------
1746 -- Utils
1747
1748 expandPath :: String -> GHCi String
1749 expandPath path =
1750   case dropWhile isSpace path of
1751    ('~':d) -> do
1752         tilde <- io getHomeDirectory -- will fail if HOME not defined
1753         return (tilde ++ '/':d)
1754    other ->
1755         return other
1756
1757 wantInterpretedModule :: String -> GHCi Module
1758 wantInterpretedModule str = do
1759    session <- getSession
1760    modl <- lookupModule str
1761    is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1762    when (not is_interpreted) $
1763        throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1764    return modl
1765
1766 wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String
1767                               -> (Name -> GHCi ())
1768                               -> GHCi ()
1769 wantNameFromInterpretedModule noCanDo str and_then = do
1770    session <- getSession
1771    names <- io $ GHC.parseName session str
1772    case names of
1773       []    -> return ()
1774       (n:_) -> do
1775             let modl = GHC.nameModule n
1776             if not (GHC.isExternalName n)
1777                then noCanDo n $ ppr n <>
1778                                 text " is not defined in an interpreted module"
1779                else do
1780             is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1781             if not is_interpreted
1782                then noCanDo n $ text "module " <> ppr modl <>
1783                                 text " is not interpreted"
1784                else and_then n
1785
1786 -- -----------------------------------------------------------------------------
1787 -- commands for debugger
1788
1789 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1790 sprintCmd = pprintCommand False False
1791 printCmd  = pprintCommand True False
1792 forceCmd  = pprintCommand False True
1793
1794 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1795 pprintCommand bind force str = do
1796   session <- getSession
1797   io $ pprintClosureCommand session bind force str
1798
1799 stepCmd :: String -> GHCi ()
1800 stepCmd []         = doContinue (const True) GHC.SingleStep
1801 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1802
1803 stepLocalCmd :: String -> GHCi ()
1804 stepLocalCmd  [] = do
1805   mb_span <- getCurrentBreakSpan
1806   case mb_span of
1807     Nothing  -> stepCmd []
1808     Just loc -> do
1809        Just mod <- getCurrentBreakModule
1810        current_toplevel_decl <- enclosingTickSpan mod loc
1811        doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1812
1813 stepLocalCmd expression = stepCmd expression
1814
1815 stepModuleCmd :: String -> GHCi ()
1816 stepModuleCmd  [] = do
1817   mb_span <- getCurrentBreakSpan
1818   case mb_span of
1819     Nothing  -> stepCmd []
1820     Just _ -> do
1821        Just span <- getCurrentBreakSpan
1822        let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
1823        doContinue f GHC.SingleStep
1824
1825 stepModuleCmd expression = stepCmd expression
1826
1827 -- | Returns the span of the largest tick containing the srcspan given
1828 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1829 enclosingTickSpan mod src = do
1830   ticks <- getTickArray mod
1831   let line = srcSpanStartLine src
1832   ASSERT (inRange (bounds ticks) line) do
1833   let enclosing_spans = [ span | (_,span) <- ticks ! line
1834                                , srcSpanEnd span >= srcSpanEnd src]
1835   return . head . sortBy leftmost_largest $ enclosing_spans
1836
1837 traceCmd :: String -> GHCi ()
1838 traceCmd []         = doContinue (const True) GHC.RunAndLogSteps
1839 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1840
1841 continueCmd :: String -> GHCi ()
1842 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1843
1844 -- doContinue :: SingleStep -> GHCi ()
1845 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1846 doContinue pred step = do
1847   session <- getSession
1848   runResult <- io $ GHC.resume session step
1849   afterRunStmt pred runResult
1850   return ()
1851
1852 abandonCmd :: String -> GHCi ()
1853 abandonCmd = noArgs $ do
1854   s <- getSession
1855   b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1856   when (not b) $ io $ putStrLn "There is no computation running."
1857   return ()
1858
1859 deleteCmd :: String -> GHCi ()
1860 deleteCmd argLine = do
1861    deleteSwitch $ words argLine
1862    where
1863    deleteSwitch :: [String] -> GHCi ()
1864    deleteSwitch [] =
1865       io $ putStrLn "The delete command requires at least one argument."
1866    -- delete all break points
1867    deleteSwitch ("*":_rest) = discardActiveBreakPoints
1868    deleteSwitch idents = do
1869       mapM_ deleteOneBreak idents
1870       where
1871       deleteOneBreak :: String -> GHCi ()
1872       deleteOneBreak str
1873          | all isDigit str = deleteBreak (read str)
1874          | otherwise = return ()
1875
1876 historyCmd :: String -> GHCi ()
1877 historyCmd arg
1878   | null arg        = history 20
1879   | all isDigit arg = history (read arg)
1880   | otherwise       = io $ putStrLn "Syntax:  :history [num]"
1881   where
1882   history num = do
1883     s <- getSession
1884     resumes <- io $ GHC.getResumeContext s
1885     case resumes of
1886       [] -> io $ putStrLn "Not stopped at a breakpoint"
1887       (r:_) -> do
1888         let hist = GHC.resumeHistory r
1889             (took,rest) = splitAt num hist
1890         spans <- mapM (io . GHC.getHistorySpan s) took
1891         let nums  = map (printf "-%-3d:") [(1::Int)..]
1892         let names = map GHC.historyEnclosingDecl took
1893         printForUser (vcat(zipWith3
1894                              (\x y z -> x <+> y <+> z)
1895                              (map text nums)
1896                              (map (bold . ppr) names)
1897                              (map (parens . ppr) spans)))
1898         io $ putStrLn $ if null rest then "<end of history>" else "..."
1899
1900 bold :: SDoc -> SDoc
1901 bold c | do_bold   = text start_bold <> c <> text end_bold
1902        | otherwise = c
1903
1904 backCmd :: String -> GHCi ()
1905 backCmd = noArgs $ do
1906   s <- getSession
1907   (names, _, span) <- io $ GHC.back s
1908   printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1909   printTypeOfNames s names
1910    -- run the command set with ":set stop <cmd>"
1911   st <- getGHCiState
1912   enqueueCommands [stop st]
1913
1914 forwardCmd :: String -> GHCi ()
1915 forwardCmd = noArgs $ do
1916   s <- getSession
1917   (names, ix, span) <- io $ GHC.forward s
1918   printForUser $ (if (ix == 0)
1919                     then ptext SLIT("Stopped at")
1920                     else ptext SLIT("Logged breakpoint at")) <+> ppr span
1921   printTypeOfNames s names
1922    -- run the command set with ":set stop <cmd>"
1923   st <- getGHCiState
1924   enqueueCommands [stop st]
1925
1926 -- handle the "break" command
1927 breakCmd :: String -> GHCi ()
1928 breakCmd argLine = do
1929    session <- getSession
1930    breakSwitch session $ words argLine
1931
1932 breakSwitch :: Session -> [String] -> GHCi ()
1933 breakSwitch _session [] = do
1934    io $ putStrLn "The break command requires at least one argument."
1935 breakSwitch session (arg1:rest)
1936    | looksLikeModuleName arg1 = do
1937         mod <- wantInterpretedModule arg1
1938         breakByModule mod rest
1939    | all isDigit arg1 = do
1940         (toplevel, _) <- io $ GHC.getContext session
1941         case toplevel of
1942            (mod : _) -> breakByModuleLine mod (read arg1) rest
1943            [] -> do
1944               io $ putStrLn "Cannot find default module for breakpoint."
1945               io $ putStrLn "Perhaps no modules are loaded for debugging?"
1946    | otherwise = do -- try parsing it as an identifier
1947         wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1948         let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1949         if GHC.isGoodSrcLoc loc
1950                then findBreakAndSet (GHC.nameModule name) $
1951                          findBreakByCoord (Just (GHC.srcLocFile loc))
1952                                           (GHC.srcLocLine loc,
1953                                            GHC.srcLocCol loc)
1954                else noCanDo name $ text "can't find its location: " <> ppr loc
1955        where
1956           noCanDo n why = printForUser $
1957                 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1958
1959 breakByModule :: Module -> [String] -> GHCi ()
1960 breakByModule mod (arg1:rest)
1961    | all isDigit arg1 = do  -- looks like a line number
1962         breakByModuleLine mod (read arg1) rest
1963 breakByModule _ _
1964    = breakSyntax
1965
1966 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1967 breakByModuleLine mod line args
1968    | [] <- args = findBreakAndSet mod $ findBreakByLine line
1969    | [col] <- args, all isDigit col =
1970         findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1971    | otherwise = breakSyntax
1972
1973 breakSyntax :: a
1974 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1975
1976 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1977 findBreakAndSet mod lookupTickTree = do
1978    tickArray <- getTickArray mod
1979    (breakArray, _) <- getModBreak mod
1980    case lookupTickTree tickArray of
1981       Nothing  -> io $ putStrLn $ "No breakpoints found at that location."
1982       Just (tick, span) -> do
1983          success <- io $ setBreakFlag True breakArray tick
1984          if success
1985             then do
1986                (alreadySet, nm) <-
1987                      recordBreak $ BreakLocation
1988                              { breakModule = mod
1989                              , breakLoc = span
1990                              , breakTick = tick
1991                              , onBreakCmd = ""
1992                              }
1993                printForUser $
1994                   text "Breakpoint " <> ppr nm <>
1995                   if alreadySet
1996                      then text " was already set at " <> ppr span
1997                      else text " activated at " <> ppr span
1998             else do
1999             printForUser $ text "Breakpoint could not be activated at"
2000                                  <+> ppr span
2001
2002 -- When a line number is specified, the current policy for choosing
2003 -- the best breakpoint is this:
2004 --    - the leftmost complete subexpression on the specified line, or
2005 --    - the leftmost subexpression starting on the specified line, or
2006 --    - the rightmost subexpression enclosing the specified line
2007 --
2008 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2009 findBreakByLine line arr
2010   | not (inRange (bounds arr) line) = Nothing
2011   | otherwise =
2012     listToMaybe (sortBy (leftmost_largest `on` snd)  complete)   `mplus`
2013     listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2014     listToMaybe (sortBy (rightmost `on` snd) ticks)
2015   where
2016         ticks = arr ! line
2017
2018         starts_here = [ tick | tick@(_,span) <- ticks,
2019                                GHC.srcSpanStartLine span == line ]
2020
2021         (complete,incomplete) = partition ends_here starts_here
2022             where ends_here (_,span) = GHC.srcSpanEndLine span == line
2023
2024 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2025                  -> Maybe (BreakIndex,SrcSpan)
2026 findBreakByCoord mb_file (line, col) arr
2027   | not (inRange (bounds arr) line) = Nothing
2028   | otherwise =
2029     listToMaybe (sortBy (rightmost `on` snd) contains ++
2030                  sortBy (leftmost_smallest `on` snd) after_here)
2031   where
2032         ticks = arr ! line
2033
2034         -- the ticks that span this coordinate
2035         contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2036                             is_correct_file span ]
2037
2038         is_correct_file span
2039                  | Just f <- mb_file = GHC.srcSpanFile span == f
2040                  | otherwise         = True
2041
2042         after_here = [ tick | tick@(_,span) <- ticks,
2043                               GHC.srcSpanStartLine span == line,
2044                               GHC.srcSpanStartCol span >= col ]
2045
2046 -- For now, use ANSI bold on terminals that we know support it.
2047 -- Otherwise, we add a line of carets under the active expression instead.
2048 -- In particular, on Windows and when running the testsuite (which sets
2049 -- TERM to vt100 for other reasons) we get carets.
2050 -- We really ought to use a proper termcap/terminfo library.
2051 do_bold :: Bool
2052 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2053     where mTerm = System.Environment.getEnv "TERM"
2054                   `Exception.catch` \_ -> return "TERM not set"
2055
2056 start_bold :: String
2057 start_bold = "\ESC[1m"
2058 end_bold :: String
2059 end_bold   = "\ESC[0m"
2060
2061 listCmd :: String -> GHCi ()
2062 listCmd "" = do
2063    mb_span <- getCurrentBreakSpan
2064    case mb_span of
2065       Nothing  -> printForUser $ text "not stopped at a breakpoint; nothing to list"
2066       Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
2067                 | otherwise              -> printForUser $ text "unable to list source for" <+> ppr span
2068 listCmd str = list2 (words str)
2069
2070 list2 :: [String] -> GHCi ()
2071 list2 [arg] | all isDigit arg = do
2072     session <- getSession
2073     (toplevel, _) <- io $ GHC.getContext session
2074     case toplevel of
2075         [] -> io $ putStrLn "No module to list"
2076         (mod : _) -> listModuleLine mod (read arg)
2077 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2078         mod <- wantInterpretedModule arg1
2079         listModuleLine mod (read arg2)
2080 list2 [arg] = do
2081         wantNameFromInterpretedModule noCanDo arg $ \name -> do
2082         let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2083         if GHC.isGoodSrcLoc loc
2084                then do
2085                   tickArray <- getTickArray (GHC.nameModule name)
2086                   let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2087                                         (GHC.srcLocLine loc, GHC.srcLocCol loc)
2088                                         tickArray
2089                   case mb_span of
2090                     Nothing       -> io $ listAround (GHC.srcLocSpan loc) False
2091                     Just (_,span) -> io $ listAround span False
2092                else
2093                   noCanDo name $ text "can't find its location: " <>
2094                                  ppr loc
2095     where
2096         noCanDo n why = printForUser $
2097             text "cannot list source code for " <> ppr n <> text ": " <> why
2098 list2  _other =
2099         io $ putStrLn "syntax:  :list [<line> | <module> <line> | <identifier>]"
2100
2101 listModuleLine :: Module -> Int -> GHCi ()
2102 listModuleLine modl line = do
2103    session <- getSession
2104    graph <- io (GHC.getModuleGraph session)
2105    let this = filter ((== modl) . GHC.ms_mod) graph
2106    case this of
2107      [] -> panic "listModuleLine"
2108      summ:_ -> do
2109            let filename = fromJust (ml_hs_file (GHC.ms_location summ))
2110                loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2111            io $ listAround (GHC.srcLocSpan loc) False
2112
2113 -- | list a section of a source file around a particular SrcSpan.
2114 -- If the highlight flag is True, also highlight the span using
2115 -- start_bold/end_bold.
2116 listAround :: SrcSpan -> Bool -> IO ()
2117 listAround span do_highlight = do
2118       contents <- BS.readFile (unpackFS file)
2119       let
2120           lines = BS.split '\n' contents
2121           these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2122                         drop (line1 - 1 - pad_before) $ lines
2123           fst_line = max 1 (line1 - pad_before)
2124           line_nos = [ fst_line .. ]
2125
2126           highlighted | do_highlight = zipWith highlight line_nos these_lines
2127                       | otherwise    = [\p -> BS.concat[p,l] | l <- these_lines]
2128
2129           bs_line_nos = [ BS.pack (show l ++ "  ") | l <- line_nos ]
2130           prefixed = zipWith ($) highlighted bs_line_nos
2131       --
2132       BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed)
2133   where
2134         file  = GHC.srcSpanFile span
2135         line1 = GHC.srcSpanStartLine span
2136         col1  = GHC.srcSpanStartCol span
2137         line2 = GHC.srcSpanEndLine span
2138         col2  = GHC.srcSpanEndCol span
2139
2140         pad_before | line1 == 1 = 0
2141                    | otherwise  = 1
2142         pad_after = 1
2143
2144         highlight | do_bold   = highlight_bold
2145                   | otherwise = highlight_carets
2146
2147         highlight_bold no line prefix
2148           | no == line1 && no == line2
2149           = let (a,r) = BS.splitAt col1 line
2150                 (b,c) = BS.splitAt (col2-col1) r
2151             in
2152             BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2153           | no == line1
2154           = let (a,b) = BS.splitAt col1 line in
2155             BS.concat [prefix, a, BS.pack start_bold, b]
2156           | no == line2
2157           = let (a,b) = BS.splitAt col2 line in
2158             BS.concat [prefix, a, BS.pack end_bold, b]
2159           | otherwise   = BS.concat [prefix, line]
2160
2161         highlight_carets no line prefix
2162           | no == line1 && no == line2
2163           = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2164                                          BS.replicate (col2-col1) '^']
2165           | no == line1
2166           = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2167                                          prefix, line]
2168           | no == line2
2169           = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2170                                          BS.pack "^^"]
2171           | otherwise   = BS.concat [prefix, line]
2172          where
2173            indent = BS.pack ("  " ++ replicate (length (show no)) ' ')
2174            nl = BS.singleton '\n'
2175
2176 -- --------------------------------------------------------------------------
2177 -- Tick arrays
2178
2179 getTickArray :: Module -> GHCi TickArray
2180 getTickArray modl = do
2181    st <- getGHCiState
2182    let arrmap = tickarrays st
2183    case lookupModuleEnv arrmap modl of
2184       Just arr -> return arr
2185       Nothing  -> do
2186         (_breakArray, ticks) <- getModBreak modl
2187         let arr = mkTickArray (assocs ticks)
2188         setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2189         return arr
2190
2191 discardTickArrays :: GHCi ()
2192 discardTickArrays = do
2193    st <- getGHCiState
2194    setGHCiState st{tickarrays = emptyModuleEnv}
2195
2196 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2197 mkTickArray ticks
2198   = accumArray (flip (:)) [] (1, max_line)
2199         [ (line, (nm,span)) | (nm,span) <- ticks,
2200                               line <- srcSpanLines span ]
2201     where
2202         max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2203         srcSpanLines span = [ GHC.srcSpanStartLine span ..
2204                               GHC.srcSpanEndLine span ]
2205
2206 lookupModule :: String -> GHCi Module
2207 lookupModule modName
2208    = do session <- getSession
2209         io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
2210
2211 -- don't reset the counter back to zero?
2212 discardActiveBreakPoints :: GHCi ()
2213 discardActiveBreakPoints = do
2214    st <- getGHCiState
2215    mapM (turnOffBreak.snd) (breaks st)
2216    setGHCiState $ st { breaks = [] }
2217
2218 deleteBreak :: Int -> GHCi ()
2219 deleteBreak identity = do
2220    st <- getGHCiState
2221    let oldLocations    = breaks st
2222        (this,rest)     = partition (\loc -> fst loc == identity) oldLocations
2223    if null this
2224       then printForUser (text "Breakpoint" <+> ppr identity <+>
2225                          text "does not exist")
2226       else do
2227            mapM (turnOffBreak.snd) this
2228            setGHCiState $ st { breaks = rest }
2229
2230 turnOffBreak :: BreakLocation -> GHCi Bool
2231 turnOffBreak loc = do
2232   (arr, _) <- getModBreak (breakModule loc)
2233   io $ setBreakFlag False arr (breakTick loc)
2234
2235 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2236 getModBreak mod = do
2237    session <- getSession
2238    Just mod_info <- io $ GHC.getModuleInfo session mod
2239    let modBreaks  = GHC.modInfoModBreaks mod_info
2240    let array      = GHC.modBreaks_flags modBreaks
2241    let ticks      = GHC.modBreaks_locs  modBreaks
2242    return (array, ticks)
2243
2244 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2245 setBreakFlag toggle array index
2246    | toggle    = GHC.setBreakOn array index
2247    | otherwise = GHC.setBreakOff array index
2248