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 cmdName :: Command -> String
 101 cmdName (n,_,_,_) = n
 102
 103 macros_ref :: IORef [Command]
 104 GLOBAL_VAR(macros_ref, [], [Command])
 105
 106 builtin_commands :: [Command]
 107 builtin_commands = [
 108         -- Hugs users are accustomed to :e, so make sure it doesn't overlap
 109   ("?",         keepGoing help,                 False, completeNone),
 110   ("add",       keepGoingPaths addModule,       False, completeFilename),
 111   ("abandon",   keepGoing abandonCmd,           False, completeNone),
 112   ("break",     keepGoing breakCmd,             False, completeIdentifier),
 113   ("back",      keepGoing backCmd,              False, completeNone),
 114   ("browse",    keepGoing (browseCmd False),    False, completeModule),
 115   ("browse!",   keepGoing (browseCmd True),     False, completeModule),
 116   ("cd",        keepGoing changeDirectory,      False, completeFilename),
 117   ("check",     keepGoing checkModule,          False, completeHomeModule),
 118   ("continue",  keepGoing continueCmd,          False, completeNone),
 119   ("cmd",       keepGoing cmdCmd,               False, completeIdentifier),
 120   ("ctags",     keepGoing createCTagsFileCmd,   False, completeFilename),
 121   ("def",       keepGoing (defineMacro False),  False, completeIdentifier),
 122   ("def!",      keepGoing (defineMacro True),   False, completeIdentifier),
 123   ("delete",    keepGoing deleteCmd,            False, completeNone),
 124   ("e",         keepGoing editFile,             False, completeFilename),
 125   ("edit",      keepGoing editFile,             False, completeFilename),
 126   ("etags",     keepGoing createETagsFileCmd,   False, completeFilename),
 127   ("force",     keepGoing forceCmd,             False, completeIdentifier),
 128   ("forward",   keepGoing forwardCmd,           False, completeNone),
 129   ("help",      keepGoing help,                 False, completeNone),
 130   ("history",   keepGoing historyCmd,           False, completeNone),
 131   ("info",      keepGoing info,                 False, completeIdentifier),
 132   ("kind",      keepGoing kindOfType,           False, completeIdentifier),
 133   ("load",      keepGoingPaths loadModule_,     False, completeHomeModuleOrFile),
 134   ("list",      keepGoing listCmd,              False, completeNone),
 135   ("module",    keepGoing setContext,           False, completeModule),
 136   ("main",      keepGoing runMain,              False, completeIdentifier),
 137   ("print",     keepGoing printCmd,             False, completeIdentifier),
 138   ("quit",      quit,                           False, completeNone),
 139   ("reload",    keepGoing reloadModule,         False, completeNone),
 140   ("set",       keepGoing setCmd,               True,  completeSetOptions),
 141   ("show",      keepGoing showCmd,              False, completeNone),
 142   ("sprint",    keepGoing sprintCmd,            False, completeIdentifier),
 143   ("step",      keepGoing stepCmd,              False, completeIdentifier),
 144   ("steplocal", keepGoing stepLocalCmd,         False, completeIdentifier),
 145   ("stepmodule",keepGoing stepModuleCmd,        False, completeIdentifier),
 146   ("type",      keepGoing typeOfExpr,           False, completeIdentifier),
 147   ("trace",     keepGoing traceCmd,             False, completeIdentifier),
 148   ("undef",     keepGoing undefineMacro,        False, completeMacro),
 149   ("unset",     keepGoing unsetOptions,         True,  completeSetOptions)
 150   ]
 151
 152 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 153 keepGoing a str = a str >> return False
 154
 155 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
 156 keepGoingPaths a str = a (toArgs str) >> return False
 157
 158 shortHelpText :: String
 159 shortHelpText = "use :? for help.\n"
 160
 161 helpText :: String
 162 helpText =
 163  " Commands available from the prompt:\n" ++
 164  "\n" ++
 165  "   <statement>                 evaluate/run <statement>\n" ++
 166  "   :                           repeat last command\n" ++
 167  "   :{\\n ..lines.. \\n:}\\n       multiline command\n" ++
 168  "   :add <filename> ...         add module(s) to the current target set\n" ++
 169  "   :browse[!] [[*]<mod>]       display the names defined by module <mod>\n" ++
 170  "                               (!: more details; *: all top-level names)\n" ++
 171  "   :cd <dir>                   change directory to <dir>\n" ++
 172  "   :cmd <expr>                 run the commands returned by <expr>::IO String\n" ++
 173  "   :ctags [<file>]             create tags file for Vi (default: \"tags\")\n" ++
 174  "   :def <cmd> <expr>           define a command :<cmd>\n" ++
 175  "   :edit <file>                edit file\n" ++
 176  "   :edit                       edit last module\n" ++
 177  "   :etags [<file>]             create tags file for Emacs (default: \"TAGS\")\n" ++
 178  "   :help, :?                   display this list of commands\n" ++
 179  "   :info [<name> ...]          display information about the given names\n" ++
 180  "   :kind <type>                show the kind of <type>\n" ++
 181  "   :load <filename> ...        load module(s) and their dependents\n" ++
 182  "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
 183  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
 184  "   :quit                       exit GHCi\n" ++
 185  "   :reload                     reload the current module set\n" ++
 186  "   :type <expr>                show the type of <expr>\n" ++
 187  "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
 188  "   :!<command>                 run the shell command <command>\n" ++
 189  "\n" ++
 190  " -- Commands for debugging:\n" ++
 191  "\n" ++
 192  "   :abandon                    at a breakpoint, abandon current computation\n" ++
 193  "   :back                       go back in the history (after :trace)\n" ++
 194  "   :break [<mod>] <l> [<col>]  set a breakpoint at the specified location\n" ++
 195  "   :break <name>               set a breakpoint on the specified function\n" ++
 196  "   :continue                   resume after a breakpoint\n" ++
 197  "   :delete <number>            delete the specified breakpoint\n" ++
 198  "   :delete *                   delete all breakpoints\n" ++
 199  "   :force <expr>               print <expr>, forcing unevaluated parts\n" ++
 200  "   :forward                    go forward in the history (after :back)\n" ++
 201  "   :history [<n>]              show the last <n> items in the history (after :trace)\n" ++
 202  "   :print [<name> ...]         prints a value without forcing its computation\n" ++
 203  "   :sprint [<name> ...]        simplifed version of :print\n" ++
 204  "   :step                       single-step after stopping at a breakpoint\n"++
 205  "   :step <expr>                single-step into <expr>\n"++
 206  "   :steplocal                  single-step restricted to the current top level decl.\n"++
 207  "   :stepmodule                 single-step restricted to the current module\n"++
 208  "   :trace                      trace after stopping at a breakpoint\n"++
 209  "   :trace <expr>               trace into <expr> (remembers breakpoints for :history)\n"++
 210
 211  "\n" ++
 212  " -- Commands for changing settings:\n" ++
 213  "\n" ++
 214  "   :set <option> ...           set options\n" ++
 215  "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
 216  "   :set prog <progname>        set the value returned by System.getProgName\n" ++
 217  "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
 218  "   :set editor <cmd>           set the command used for :edit\n" ++
 219  "   :set stop <cmd>             set the command to run when a breakpoint is hit\n" ++
 220  "   :unset <option> ...         unset options\n" ++
 221  "\n" ++
 222  "  Options for ':set' and ':unset':\n" ++
 223  "\n" ++
 224  "    +r            revert top-level expressions after each evaluation\n" ++
 225  "    +s            print timing/memory stats after each evaluation\n" ++
 226  "    +t            print type after evaluation\n" ++
 227  "    -<flags>      most GHC command line flags can also be set here\n" ++
 228  "                         (eg. -v2, -fglasgow-exts, etc.)\n" ++
 229  "                    for GHCi-specific flags, see User's Guide,\n"++
 230  "                    Flag reference, Interactive-mode options\n" ++
 231  "\n" ++
 232  " -- Commands for displaying information:\n" ++
 233  "\n" ++
 234  "   :show bindings              show the current bindings made at the prompt\n" ++
 235  "   :show breaks                show the active breakpoints\n" ++
 236  "   :show context               show the breakpoint context\n" ++
 237  "   :show modules               show the currently loaded modules\n" ++
 238  "   :show packages              show the currently active package flags\n" ++
 239  "   :show languages             show the currently active language flags\n" ++
 240  "   :show <setting>             show anything that can be set with :set (e.g. args)\n" ++
 241  "\n"
 242
 243 findEditor :: IO String
 244 findEditor = do
 245   getEnv "EDITOR"
 246     `IO.catch` \_ -> do
 247 #if mingw32_HOST_OS
 248         win <- System.Win32.getWindowsDirectory
 249         return (win `joinFileName` "notepad.exe")
 250 #else
 251         return ""
 252 #endif
 253
 254 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
 255 interactiveUI session srcs maybe_expr = do
 256    -- HACK! If we happen to get into an infinite loop (eg the user
 257    -- types 'let x=x in x' at the prompt), then the thread will block
 258    -- on a blackhole, and become unreachable during GC.  The GC will
 259    -- detect that it is unreachable and send it the NonTermination
 260    -- exception.  However, since the thread is unreachable, everything
 261    -- it refers to might be finalized, including the standard Handles.
 262    -- This sounds like a bug, but we don't have a good solution right
 263    -- now.
 264    newStablePtr stdin
 265    newStablePtr stdout
 266    newStablePtr stderr
 267
 268     -- Initialise buffering for the *interpreted* I/O system
 269    initInterpBuffering session
 270
 271    when (isNothing maybe_expr) $ do
 272         -- Only for GHCi (not runghc and ghc -e):
 273
 274         -- Turn buffering off for the compiled program's stdout/stderr
 275         turnOffBuffering
 276         -- Turn buffering off for GHCi's stdout
 277         hFlush stdout
 278         hSetBuffering stdout NoBuffering
 279         -- We don't want the cmd line to buffer any input that might be
 280         -- intended for the program, so unbuffer stdin.
 281         hSetBuffering stdin NoBuffering
 282
 283         -- initial context is just the Prelude
 284    prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude")
 285                                       (Just basePackageId)
 286    GHC.setContext session [] [prel_mod]
 287
 288 #ifdef USE_READLINE
 289    Readline.initialize
 290    Readline.setAttemptedCompletionFunction (Just completeWord)
 291    --Readline.parseAndBind "set show-all-if-ambiguous 1"
 292
 293    let symbols = "!#$%&*+/<=>?@\\^|-~"
 294        specials = "(),;[]`{}"
 295        spaces = " \t\n"
 296        word_break_chars = spaces ++ specials ++ symbols
 297
 298    Readline.setBasicWordBreakCharacters word_break_chars
 299    Readline.setCompleterWordBreakCharacters word_break_chars
 300 #endif
 301
 302    default_editor <- findEditor
 303
 304    startGHCi (runGHCi srcs maybe_expr)
 305         GHCiState{ progname = "<interactive>",
 306                    args = [],
 307                    prompt = "%s> ",
 308                    stop = "",
 309                    editor = default_editor,
 310                    session = session,
 311                    options = [],
 312                    prelude = prel_mod,
 313                    break_ctr = 0,
 314                    breaks = [],
 315                    tickarrays = emptyModuleEnv,
 316                    last_command = Nothing,
 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 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
 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 <- lookupCommand cmd
 721   case maybe_cmd of
 722     GotCommand (_,f,_,_) -> f (dropWhile isSpace rest)
 723     BadCommand ->
 724       do io $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
 725                            ++ shortHelpText)
 726          return False
 727     NoLastCommand ->
 728       do io $ hPutStr stdout ("there is no last command to perform\n"
 729                            ++ shortHelpText)
 730          return False
 731
 732 lookupCommand :: String -> GHCi (MaybeCommand)
 733 lookupCommand "" = do
 734   st <- getGHCiState
 735   case last_command st of
 736       Just c -> return $ GotCommand c
 737       Nothing -> return NoLastCommand
 738 lookupCommand str = do
 739   mc <- io $ lookupCommand' str
 740   st <- getGHCiState
 741   setGHCiState st{ last_command = mc }
 742   return $ case mc of
 743            Just c -> GotCommand c
 744            Nothing -> BadCommand
 745
 746 lookupCommand' :: String -> IO (Maybe Command)
 747 lookupCommand' str = do
 748   macros <- readIORef macros_ref
 749   let cmds = builtin_commands ++ macros
 750   -- look for exact match first, then the first prefix match
 751   return $ case [ c | c <- cmds, str == cmdName c ] of
 752            c:_ -> Just c
 753            [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
 754                  [] -> Nothing
 755                  c:_ -> Just c
 756
 757 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
 758 getCurrentBreakSpan = do
 759   session <- getSession
 760   resumes <- io $ GHC.getResumeContext session
 761   case resumes of
 762     [] -> return Nothing
 763     (r:_) -> do
 764         let ix = GHC.resumeHistoryIx r
 765         if ix == 0
 766            then return (Just (GHC.resumeSpan r))
 767            else do
 768                 let hist = GHC.resumeHistory r !! (ix-1)
 769                 span <- io $ GHC.getHistorySpan session hist
 770                 return (Just span)
 771
 772 getCurrentBreakModule :: GHCi (Maybe Module)
 773 getCurrentBreakModule = do
 774   session <- getSession
 775   resumes <- io $ GHC.getResumeContext session
 776   case resumes of
 777     [] -> return Nothing
 778     (r:_) -> do
 779         let ix = GHC.resumeHistoryIx r
 780         if ix == 0
 781            then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
 782            else do
 783                 let hist = GHC.resumeHistory r !! (ix-1)
 784                 return $ Just $ GHC.getHistoryModule  hist
 785
 786 -----------------------------------------------------------------------------
 787 -- Commands
 788
 789 noArgs :: GHCi () -> String -> GHCi ()
 790 noArgs m "" = m
 791 noArgs _ _  = io $ putStrLn "This command takes no arguments"
 792
 793 help :: String -> GHCi ()
 794 help _ = io (putStr helpText)
 795
 796 info :: String -> GHCi ()
 797 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
 798 info s  = do { let names = words s
 799              ; session <- getSession
 800              ; dflags <- getDynFlags
 801              ; let pefas = dopt Opt_PrintExplicitForalls dflags
 802              ; mapM_ (infoThing pefas session) names }
 803   where
 804     infoThing pefas session str = io $ do
 805         names     <- GHC.parseName session str
 806         mb_stuffs <- mapM (GHC.getInfo session) names
 807         let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
 808         unqual <- GHC.getPrintUnqual session
 809         putStrLn (showSDocForUser unqual $
 810                    vcat (intersperse (text "") $
 811                          map (pprInfo pefas) filtered))
 812
 813   -- Filter out names whose parent is also there Good
 814   -- example is '[]', which is both a type and data
 815   -- constructor in the same type
 816 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
 817 filterOutChildren get_thing xs
 818   = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
 819   where
 820     implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
 821
 822 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
 823 pprInfo pefas (thing, fixity, insts)
 824   =  pprTyThingInContextLoc pefas thing
 825   $$ show_fixity fixity
 826   $$ vcat (map GHC.pprInstance insts)
 827   where
 828     show_fixity fix
 829         | fix == GHC.defaultFixity = empty
 830         | otherwise                = ppr fix <+> ppr (GHC.getName thing)
 831
 832 runMain :: String -> GHCi ()
 833 runMain args = do
 834   let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
 835   enqueueCommands  ['[': ss ++ "] `System.Environment.withArgs` main"]
 836
 837 addModule :: [FilePath] -> GHCi ()
 838 addModule files = do
 839   io (revertCAFs)                       -- always revert CAFs on load/add.
 840   files <- mapM expandPath files
 841   targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
 842   session <- getSession
 843   io (mapM_ (GHC.addTarget session) targets)
 844   prev_context <- io $ GHC.getContext session
 845   ok <- io (GHC.load session LoadAllTargets)
 846   afterLoad ok session False prev_context
 847
 848 changeDirectory :: String -> GHCi ()
 849 changeDirectory dir = do
 850   session <- getSession
 851   graph <- io (GHC.getModuleGraph session)
 852   when (not (null graph)) $
 853         io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
 854   prev_context <- io $ GHC.getContext session
 855   io (GHC.setTargets session [])
 856   io (GHC.load session LoadAllTargets)
 857   setContextAfterLoad session prev_context []
 858   io (GHC.workingDirectoryChanged session)
 859   dir <- expandPath dir
 860   io (setCurrentDirectory dir)
 861
 862 editFile :: String -> GHCi ()
 863 editFile str =
 864   do file <- if null str then chooseEditFile else return str
 865      st <- getGHCiState
 866      let cmd = editor st
 867      when (null cmd)
 868        $ throwDyn (CmdLineError "editor not set, use :set editor")
 869      io $ system (cmd ++ ' ':file)
 870      return ()
 871
 872 -- The user didn't specify a file so we pick one for them.
 873 -- Our strategy is to pick the first module that failed to load,
 874 -- or otherwise the first target.
 875 --
 876 -- XXX: Can we figure out what happened if the depndecy analysis fails
 877 --      (e.g., because the porgrammeer mistyped the name of a module)?
 878 -- XXX: Can we figure out the location of an error to pass to the editor?
 879 -- XXX: if we could figure out the list of errors that occured during the
 880 -- last load/reaload, then we could start the editor focused on the first
 881 -- of those.
 882 chooseEditFile :: GHCi String
 883 chooseEditFile =
 884   do session <- getSession
 885      let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
 886
 887      graph <- io (GHC.getModuleGraph session)
 888      failed_graph <- filterM hasFailed graph
 889      let order g  = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
 890          pick xs  = case xs of
 891                       x : _ -> GHC.ml_hs_file (GHC.ms_location x)
 892                       _     -> Nothing
 893
 894      case pick (order failed_graph) of
 895        Just file -> return file
 896        Nothing   ->
 897          do targets <- io (GHC.getTargets session)
 898             case msum (map fromTarget targets) of
 899               Just file -> return file
 900               Nothing   -> throwDyn (CmdLineError "No files to edit.")
 901
 902   where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
 903         fromTarget _ = Nothing -- when would we get a module target?
 904
 905 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
 906 defineMacro overwrite s = do
 907   let (macro_name, definition) = break isSpace s
 908   macros <- io (readIORef macros_ref)
 909   let defined = map cmdName macros
 910   if (null macro_name)
 911         then if null defined
 912                 then io $ putStrLn "no macros defined"
 913                 else io $ putStr ("the following macros are defined:\n" ++
 914                                   unlines defined)
 915         else do
 916   if (not overwrite && macro_name `elem` defined)
 917         then throwDyn (CmdLineError
 918                 ("macro '" ++ macro_name ++ "' is already defined"))
 919         else do
 920
 921   let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
 922
 923   -- give the expression a type signature, so we can be sure we're getting
 924   -- something of the right type.
 925   let new_expr = '(' : definition ++ ") :: String -> IO String"
 926
 927   -- compile the expression
 928   cms <- getSession
 929   maybe_hv <- io (GHC.compileExpr cms new_expr)
 930   case maybe_hv of
 931      Nothing -> return ()
 932      Just hv -> io (writeIORef macros_ref --
 933                     (filtered ++ [(macro_name, runMacro hv, False, completeNone)]))
 934
 935 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
 936 runMacro fun s = do
 937   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 938   enqueueCommands (lines str)
 939   return False
 940
 941 undefineMacro :: String -> GHCi ()
 942 undefineMacro str = mapM_ undef (words str)
 943  where undef macro_name = do
 944         cmds <- io (readIORef macros_ref)
 945         if (macro_name `notElem` map cmdName cmds)
 946            then throwDyn (CmdLineError
 947                 ("macro '" ++ macro_name ++ "' is not defined"))
 948            else do
 949             io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
 950
 951 cmdCmd :: String -> GHCi ()
 952 cmdCmd str = do
 953   let expr = '(' : str ++ ") :: IO String"
 954   session <- getSession
 955   maybe_hv <- io (GHC.compileExpr session expr)
 956   case maybe_hv of
 957     Nothing -> return ()
 958     Just hv -> do
 959         cmds <- io $ (unsafeCoerce# hv :: IO String)
 960         enqueueCommands (lines cmds)
 961         return ()
 962
 963 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 964 loadModule fs = timeIt (loadModule' fs)
 965
 966 loadModule_ :: [FilePath] -> GHCi ()
 967 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
 968
 969 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 970 loadModule' files = do
 971   session <- getSession
 972   prev_context <- io $ GHC.getContext session
 973
 974   -- unload first
 975   discardActiveBreakPoints
 976   io (GHC.setTargets session [])
 977   io (GHC.load session LoadAllTargets)
 978
 979   -- expand tildes
 980   let (filenames, phases) = unzip files
 981   exp_filenames <- mapM expandPath filenames
 982   let files' = zip exp_filenames phases
 983   targets <- io (mapM (uncurry GHC.guessTarget) files')
 984
 985   -- NOTE: we used to do the dependency anal first, so that if it
 986   -- fails we didn't throw away the current set of modules.  This would
 987   -- require some re-working of the GHC interface, so we'll leave it
 988   -- as a ToDo for now.
 989
 990   io (GHC.setTargets session targets)
 991   doLoad session False prev_context LoadAllTargets
 992
 993 checkModule :: String -> GHCi ()
 994 checkModule m = do
 995   let modl = GHC.mkModuleName m
 996   session <- getSession
 997   prev_context <- io $ GHC.getContext session
 998   result <- io (GHC.checkModule session modl False)
 999   case result of
1000     Nothing -> io $ putStrLn "Nothing"
1001     Just r  -> io $ putStrLn (showSDoc (
1002         case GHC.checkedModuleInfo r of
1003            Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1004                 let
1005                     (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1006                 in
1007                         (text "global names: " <+> ppr global) $$
1008                         (text "local  names: " <+> ppr local)
1009            _ -> empty))
1010   afterLoad (successIf (isJust result)) session False prev_context
1011
1012 reloadModule :: String -> GHCi ()
1013 reloadModule m = do
1014   session <- getSession
1015   prev_context <- io $ GHC.getContext session
1016   doLoad session True prev_context $
1017         if null m then LoadAllTargets
1018                   else LoadUpTo (GHC.mkModuleName m)
1019   return ()
1020
1021 doLoad :: Session -> Bool -> ([Module],[Module]) -> LoadHowMuch -> GHCi SuccessFlag
1022 doLoad session retain_context prev_context howmuch = do
1023   -- turn off breakpoints before we load: we can't turn them off later, because
1024   -- the ModBreaks will have gone away.
1025   discardActiveBreakPoints
1026   ok <- io (GHC.load session howmuch)
1027   afterLoad ok session retain_context prev_context
1028   return ok
1029
1030 afterLoad :: SuccessFlag -> Session -> Bool -> ([Module],[Module]) -> GHCi ()
1031 afterLoad ok session retain_context prev_context = do
1032   io (revertCAFs)  -- always revert CAFs on load.
1033   discardTickArrays
1034   loaded_mod_summaries <- getLoadedModules session
1035   let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1036       loaded_mod_names = map GHC.moduleName loaded_mods
1037   modulesLoadedMsg ok loaded_mod_names
1038
1039   st <- getGHCiState
1040   if not retain_context
1041     then do
1042         setGHCiState st{ remembered_ctx = Nothing }
1043         setContextAfterLoad session prev_context loaded_mod_summaries
1044     else do
1045         -- figure out which modules we can keep in the context, which we
1046         -- have to put back, and which we have to remember because they
1047         -- are (temporarily) unavailable.  See ghci.prog009, #1873, #1360
1048         let (as,bs) = prev_context
1049             as1 = filter isHomeModule as -- package modules are kept anyway
1050             bs1 = filter isHomeModule bs
1051             (as_ok, as_bad) = partition (`elem` loaded_mods) as1
1052             (bs_ok, bs_bad) = partition (`elem` loaded_mods) bs1
1053             (rem_as, rem_bs) = fromMaybe ([],[]) (remembered_ctx st)
1054             (rem_as_ok, rem_as_bad) = partition (`elem` loaded_mods) rem_as
1055             (rem_bs_ok, rem_bs_bad) = partition (`elem` loaded_mods) rem_bs
1056             as' = nub (as_ok++rem_as_ok)
1057             bs' = nub (bs_ok++rem_bs_ok)
1058             rem_as' = nub (rem_as_bad ++ as_bad)
1059             rem_bs' = nub (rem_bs_bad ++ bs_bad)
1060
1061          -- Put back into the context any modules that we previously had
1062          -- to drop because they weren't available (rem_as_ok, rem_bs_ok).
1063         setContextKeepingPackageModules session prev_context (as',bs')
1064
1065          -- If compilation failed, remember any modules that we are unable
1066          -- to load, so that we can put them back in the context in the future.
1067         case ok of
1068          Succeeded -> setGHCiState st{ remembered_ctx = Nothing }
1069          Failed    -> setGHCiState st{ remembered_ctx = Just (rem_as',rem_bs') }
1070
1071
1072
1073 setContextAfterLoad :: Session -> ([Module],[Module]) -> [GHC.ModSummary] -> GHCi ()
1074 setContextAfterLoad session prev [] = do
1075   prel_mod <- getPrelude
1076   setContextKeepingPackageModules session prev ([], [prel_mod])
1077 setContextAfterLoad session prev ms = do
1078   -- load a target if one is available, otherwise load the topmost module.
1079   targets <- io (GHC.getTargets session)
1080   case [ m | Just m <- map (findTarget ms) targets ] of
1081         []    ->
1082           let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1083           load_this (last graph')
1084         (m:_) ->
1085           load_this m
1086  where
1087    findTarget ms t
1088     = case filter (`matches` t) ms of
1089         []    -> Nothing
1090         (m:_) -> Just m
1091
1092    summary `matches` Target (TargetModule m) _
1093         = GHC.ms_mod_name summary == m
1094    summary `matches` Target (TargetFile f _) _
1095         | Just f' <- GHC.ml_hs_file (GHC.ms_location summary)   = f == f'
1096    _ `matches` _
1097         = False
1098
1099    load_this summary | m <- GHC.ms_mod summary = do
1100         b <- io (GHC.moduleIsInterpreted session m)
1101         if b then setContextKeepingPackageModules session prev ([m], [])
1102              else do
1103                 prel_mod <- getPrelude
1104                 setContextKeepingPackageModules session prev ([],[prel_mod,m])
1105
1106 -- | Keep any package modules (except Prelude) when changing the context.
1107 setContextKeepingPackageModules
1108         :: Session
1109         -> ([Module],[Module])          -- previous context
1110         -> ([Module],[Module])          -- new context
1111         -> GHCi ()
1112 setContextKeepingPackageModules session prev_context (as,bs) = do
1113   let (_,bs0) = prev_context
1114   prel_mod <- getPrelude
1115   let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1116   let bs1 = if null as then nub (prel_mod : bs) else bs
1117   io $ GHC.setContext session as (nub (bs1 ++ pkg_modules))
1118
1119 isHomeModule :: Module -> Bool
1120 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1121
1122 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
1123 modulesLoadedMsg ok mods = do
1124   dflags <- getDynFlags
1125   when (verbosity dflags > 0) $ do
1126    let mod_commas
1127         | null mods = text "none."
1128         | otherwise = hsep (
1129             punctuate comma (map ppr mods)) <> text "."
1130    case ok of
1131     Failed ->
1132        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
1133     Succeeded  ->
1134        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
1135
1136
1137 typeOfExpr :: String -> GHCi ()
1138 typeOfExpr str
1139   = do cms <- getSession
1140        maybe_ty <- io (GHC.exprType cms str)
1141        case maybe_ty of
1142           Nothing -> return ()
1143           Just ty -> do dflags <- getDynFlags
1144                         let pefas = dopt Opt_PrintExplicitForalls dflags
1145                         printForUser $ text str <+> dcolon
1146                                         <+> pprTypeForUser pefas ty
1147
1148 kindOfType :: String -> GHCi ()
1149 kindOfType str
1150   = do cms <- getSession
1151        maybe_ty <- io (GHC.typeKind cms str)
1152        case maybe_ty of
1153           Nothing    -> return ()
1154           Just ty    -> printForUser $ text str <+> dcolon <+> ppr ty
1155
1156 quit :: String -> GHCi Bool
1157 quit _ = return True
1158
1159 shellEscape :: String -> GHCi Bool
1160 shellEscape str = io (system str >> return False)
1161
1162 -----------------------------------------------------------------------------
1163 -- Browsing a module's contents
1164
1165 browseCmd :: Bool -> String -> GHCi ()
1166 browseCmd bang m =
1167   case words m of
1168     ['*':s] | looksLikeModuleName s -> do
1169         m <-  wantInterpretedModule s
1170         browseModule bang m False
1171     [s] | looksLikeModuleName s -> do
1172         m <- lookupModule s
1173         browseModule bang m True
1174     [] -> do
1175         s <- getSession
1176         (as,bs) <- io $ GHC.getContext s
1177                 -- Guess which module the user wants to browse.  Pick
1178                 -- modules that are interpreted first.  The most
1179                 -- recently-added module occurs last, it seems.
1180         case (as,bs) of
1181           (as@(_:_), _)   -> browseModule bang (last as) True
1182           ([],  bs@(_:_)) -> browseModule bang (last bs) True
1183           ([],  [])  -> throwDyn (CmdLineError ":browse: no current module")
1184     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
1185
1186 -- without bang, show items in context of their parents and omit children
1187 -- with bang, show class methods and data constructors separately, and
1188 --            indicate import modules, to aid qualifying unqualified names
1189 -- with sorted, sort items alphabetically
1190 browseModule :: Bool -> Module -> Bool -> GHCi ()
1191 browseModule bang modl exports_only = do
1192   s <- getSession
1193   -- :browse! reports qualifiers wrt current context
1194   current_unqual <- io (GHC.getPrintUnqual s)
1195   -- Temporarily set the context to the module we're interested in,
1196   -- just so we can get an appropriate PrintUnqualified
1197   (as,bs) <- io (GHC.getContext s)
1198   prel_mod <- getPrelude
1199   io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1200                       else GHC.setContext s [modl] [])
1201   target_unqual <- io (GHC.getPrintUnqual s)
1202   io (GHC.setContext s as bs)
1203
1204   let unqual = if bang then current_unqual else target_unqual
1205
1206   mb_mod_info <- io $ GHC.getModuleInfo s modl
1207   case mb_mod_info of
1208     Nothing -> throwDyn (CmdLineError ("unknown module: " ++
1209                                 GHC.moduleNameString (GHC.moduleName modl)))
1210     Just mod_info -> do
1211         dflags <- getDynFlags
1212         let names
1213                | exports_only = GHC.modInfoExports mod_info
1214                | otherwise    = GHC.modInfoTopLevelScope mod_info
1215                                 `orElse` []
1216
1217                 -- sort alphabetically name, but putting
1218                 -- locally-defined identifiers first.
1219                 -- We would like to improve this; see #1799.
1220             sorted_names = loc_sort local ++ occ_sort external
1221                 where
1222                 (local,external) = partition ((==modl) . nameModule) names
1223                 occ_sort = sortBy (compare `on` nameOccName)
1224                 -- try to sort by src location.  If the first name in
1225                 -- our list has a good source location, then they all should.
1226                 loc_sort names
1227                       | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1228                       = sortBy (compare `on` nameSrcSpan) names
1229                       | otherwise
1230                       = occ_sort names
1231
1232         mb_things <- io $ mapM (GHC.lookupName s) sorted_names
1233         let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1234
1235         rdr_env <- io $ GHC.getGRE s
1236
1237         let pefas              = dopt Opt_PrintExplicitForalls dflags
1238             things | bang      = catMaybes mb_things
1239                    | otherwise = filtered_things
1240             pretty | bang      = pprTyThing
1241                    | otherwise = pprTyThingInContext
1242
1243             labels  [] = text "-- not currently imported"
1244             labels  l  = text $ intercalate "\n" $ map qualifier l
1245             qualifier  = maybe "-- defined locally"
1246                              (("-- imported via "++) . intercalate ", "
1247                                . map GHC.moduleNameString)
1248             importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1249             modNames   = map (importInfo . GHC.getName) things
1250
1251             -- annotate groups of imports with their import modules
1252             -- the default ordering is somewhat arbitrary, so we group
1253             -- by header and sort groups; the names themselves should
1254             -- really come in order of source appearance.. (trac #1799)
1255             annotate mts = concatMap (\(m,ts)->labels m:ts)
1256                          $ sortBy cmpQualifiers $ group mts
1257               where cmpQualifiers =
1258                       compare `on` (map (fmap (map moduleNameFS)) . fst)
1259             group []            = []
1260             group mts@((m,_):_) = (m,map snd g) : group ng
1261               where (g,ng) = partition ((==m).fst) mts
1262
1263         let prettyThings = map (pretty pefas) things
1264             prettyThings' | bang      = annotate $ zip modNames prettyThings
1265                           | otherwise = prettyThings
1266         io (putStrLn $ showSDocForUser unqual (vcat prettyThings'))
1267         -- ToDo: modInfoInstances currently throws an exception for
1268         -- package modules.  When it works, we can do this:
1269         --        $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1270
1271 -----------------------------------------------------------------------------
1272 -- Setting the module context
1273
1274 setContext :: String -> GHCi ()
1275 setContext str
1276   | all sensible mods = fn mods
1277   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
1278   where
1279     (fn, mods) = case str of
1280                         '+':stuff -> (addToContext,      words stuff)
1281                         '-':stuff -> (removeFromContext, words stuff)
1282                         stuff     -> (newContext,        words stuff)
1283
1284     sensible ('*':m) = looksLikeModuleName m
1285     sensible m       = looksLikeModuleName m
1286
1287 separate :: Session -> [String] -> [Module] -> [Module]
1288         -> GHCi ([Module],[Module])
1289 separate _       []             as bs = return (as,bs)
1290 separate session (('*':str):ms) as bs = do
1291   m <- wantInterpretedModule str
1292   separate session ms (m:as) bs
1293 separate session (str:ms) as bs = do
1294   m <- lookupModule str
1295   separate session ms as (m:bs)
1296
1297 newContext :: [String] -> GHCi ()
1298 newContext strs = do
1299   s <- getSession
1300   (as,bs) <- separate s strs [] []
1301   prel_mod <- getPrelude
1302   let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1303   io $ GHC.setContext s as bs'
1304
1305
1306 addToContext :: [String] -> GHCi ()
1307 addToContext strs = do
1308   s <- getSession
1309   (as,bs) <- io $ GHC.getContext s
1310
1311   (new_as,new_bs) <- separate s strs [] []
1312
1313   let as_to_add = new_as \\ (as ++ bs)
1314       bs_to_add = new_bs \\ (as ++ bs)
1315
1316   io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1317
1318
1319 removeFromContext :: [String] -> GHCi ()
1320 removeFromContext strs = do
1321   s <- getSession
1322   (as,bs) <- io $ GHC.getContext s
1323
1324   (as_to_remove,bs_to_remove) <- separate s strs [] []
1325
1326   let as' = as \\ (as_to_remove ++ bs_to_remove)
1327       bs' = bs \\ (as_to_remove ++ bs_to_remove)
1328
1329   io $ GHC.setContext s as' bs'
1330
1331 ----------------------------------------------------------------------------
1332 -- Code for `:set'
1333
1334 -- set options in the interpreter.  Syntax is exactly the same as the
1335 -- ghc command line, except that certain options aren't available (-C,
1336 -- -E etc.)
1337 --
1338 -- This is pretty fragile: most options won't work as expected.  ToDo:
1339 -- figure out which ones & disallow them.
1340
1341 setCmd :: String -> GHCi ()
1342 setCmd ""
1343   = do st <- getGHCiState
1344        let opts = options st
1345        io $ putStrLn (showSDoc (
1346               text "options currently set: " <>
1347               if null opts
1348                    then text "none."
1349                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1350            ))
1351        dflags <- getDynFlags
1352        io $ putStrLn (showSDoc (
1353           vcat (text "GHCi-specific dynamic flag settings:"
1354                :map (flagSetting dflags) ghciFlags)
1355           ))
1356        io $ putStrLn (showSDoc (
1357           vcat (text "other dynamic, non-language, flag settings:"
1358                :map (flagSetting dflags) nonLanguageDynFlags)
1359           ))
1360   where flagSetting dflags (str,f)
1361           | dopt f dflags = text "  " <> text "-f"    <> text str
1362           | otherwise     = text "  " <> text "-fno-" <> text str
1363         (ghciFlags,others)  = partition (\(_,f)->f `elem` flags)
1364                                         DynFlags.fFlags
1365         nonLanguageDynFlags = filter (\(_,f)->not $ f `elem` map snd xFlags)
1366                                      others
1367         flags = [Opt_PrintExplicitForalls
1368                 ,Opt_PrintBindResult
1369                 ,Opt_BreakOnException
1370                 ,Opt_BreakOnError
1371                 ,Opt_PrintEvldWithShow
1372                 ]
1373 setCmd str
1374   = case toArgs str of
1375         ("args":args) -> setArgs args
1376         ("prog":prog) -> setProg prog
1377         ("prompt":_)  -> setPrompt (after 6)
1378         ("editor":_)  -> setEditor (after 6)
1379         ("stop":_)    -> setStop (after 4)
1380         wds -> setOptions wds
1381    where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1382
1383 setArgs, setProg, setOptions :: [String] -> GHCi ()
1384 setEditor, setStop, setPrompt :: String -> GHCi ()
1385
1386 setArgs args = do
1387   st <- getGHCiState
1388   setGHCiState st{ args = args }
1389
1390 setProg [prog] = do
1391   st <- getGHCiState
1392   setGHCiState st{ progname = prog }
1393 setProg _ = do
1394   io (hPutStrLn stderr "syntax: :set prog <progname>")
1395
1396 setEditor cmd = do
1397   st <- getGHCiState
1398   setGHCiState st{ editor = cmd }
1399
1400 setStop str@(c:_) | isDigit c
1401   = do let (nm_str,rest) = break (not.isDigit) str
1402            nm = read nm_str
1403        st <- getGHCiState
1404        let old_breaks = breaks st
1405        if all ((/= nm) . fst) old_breaks
1406               then printForUser (text "Breakpoint" <+> ppr nm <+>
1407                                  text "does not exist")
1408               else do
1409        let new_breaks = map fn old_breaks
1410            fn (i,loc) | i == nm   = (i,loc { onBreakCmd = dropWhile isSpace rest })
1411                       | otherwise = (i,loc)
1412        setGHCiState st{ breaks = new_breaks }
1413 setStop cmd = do
1414   st <- getGHCiState
1415   setGHCiState st{ stop = cmd }
1416
1417 setPrompt value = do
1418   st <- getGHCiState
1419   if null value
1420       then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1421       else setGHCiState st{ prompt = remQuotes value }
1422   where
1423      remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1424      remQuotes x = x
1425
1426 setOptions wds =
1427    do -- first, deal with the GHCi opts (+s, +t, etc.)
1428       let (plus_opts, minus_opts)  = partitionWith isPlus wds
1429       mapM_ setOpt plus_opts
1430       -- then, dynamic flags
1431       newDynFlags minus_opts
1432
1433 newDynFlags :: [String] -> GHCi ()
1434 newDynFlags minus_opts = do
1435       dflags <- getDynFlags
1436       let pkg_flags = packageFlags dflags
1437       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1438
1439       if (not (null leftovers))
1440                 then throwDyn (CmdLineError ("unrecognised flags: " ++
1441                                                 unwords leftovers))
1442                 else return ()
1443
1444       new_pkgs <- setDynFlags dflags'
1445
1446       -- if the package flags changed, we should reset the context
1447       -- and link the new packages.
1448       dflags <- getDynFlags
1449       when (packageFlags dflags /= pkg_flags) $ do
1450         io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1451         session <- getSession
1452         io (GHC.setTargets session [])
1453         io (GHC.load session LoadAllTargets)
1454         io (linkPackages dflags new_pkgs)
1455         -- package flags changed, we can't re-use any of the old context
1456         setContextAfterLoad session ([],[]) []
1457       return ()
1458
1459
1460 unsetOptions :: String -> GHCi ()
1461 unsetOptions str
1462   = do -- first, deal with the GHCi opts (+s, +t, etc.)
1463        let opts = words str
1464            (minus_opts, rest1) = partition isMinus opts
1465            (plus_opts, rest2)  = partitionWith isPlus rest1
1466
1467        if (not (null rest2))
1468           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1469           else do
1470
1471        mapM_ unsetOpt plus_opts
1472
1473        let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1474            no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1475
1476        no_flags <- mapM no_flag minus_opts
1477        newDynFlags no_flags
1478
1479 isMinus :: String -> Bool
1480 isMinus ('-':_) = True
1481 isMinus _ = False
1482
1483 isPlus :: String -> Either String String
1484 isPlus ('+':opt) = Left opt
1485 isPlus other     = Right other
1486
1487 setOpt, unsetOpt :: String -> GHCi ()
1488
1489 setOpt str
1490   = case strToGHCiOpt str of
1491         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1492         Just o  -> setOption o
1493
1494 unsetOpt str
1495   = case strToGHCiOpt str of
1496         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1497         Just o  -> unsetOption o
1498
1499 strToGHCiOpt :: String -> (Maybe GHCiOption)
1500 strToGHCiOpt "s" = Just ShowTiming
1501 strToGHCiOpt "t" = Just ShowType
1502 strToGHCiOpt "r" = Just RevertCAFs
1503 strToGHCiOpt _   = Nothing
1504
1505 optToStr :: GHCiOption -> String
1506 optToStr ShowTiming = "s"
1507 optToStr ShowType   = "t"
1508 optToStr RevertCAFs = "r"
1509
1510 -- ---------------------------------------------------------------------------
1511 -- code for `:show'
1512
1513 showCmd :: String -> GHCi ()
1514 showCmd str = do
1515   st <- getGHCiState
1516   case words str of
1517         ["args"]     -> io $ putStrLn (show (args st))
1518         ["prog"]     -> io $ putStrLn (show (progname st))
1519         ["prompt"]   -> io $ putStrLn (show (prompt st))
1520         ["editor"]   -> io $ putStrLn (show (editor st))
1521         ["stop"]     -> io $ putStrLn (show (stop st))
1522         ["modules" ] -> showModules
1523         ["bindings"] -> showBindings
1524         ["linker"]   -> io showLinkerState
1525         ["breaks"]   -> showBkptTable
1526         ["context"]  -> showContext
1527         ["packages"]  -> showPackages
1528         ["languages"]  -> showLanguages
1529         _ -> throwDyn (CmdLineError "syntax:  :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1530
1531 showModules :: GHCi ()
1532 showModules = do
1533   session <- getSession
1534   loaded_mods <- getLoadedModules session
1535         -- we want *loaded* modules only, see #1734
1536   let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m)
1537   mapM_ show_one loaded_mods
1538
1539 getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary]
1540 getLoadedModules session = do
1541   graph <- io (GHC.getModuleGraph session)
1542   filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
1543
1544 showBindings :: GHCi ()
1545 showBindings = do
1546   s <- getSession
1547   bindings <- io (GHC.getBindings s)
1548   docs     <- io$ pprTypeAndContents s
1549                   [ id | AnId id <- sortBy compareTyThings bindings]
1550   printForUserPartWay docs
1551
1552 compareTyThings :: TyThing -> TyThing -> Ordering
1553 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1554
1555 printTyThing :: TyThing -> GHCi ()
1556 printTyThing tyth = do dflags <- getDynFlags
1557                        let pefas = dopt Opt_PrintExplicitForalls dflags
1558                        printForUser (pprTyThing pefas tyth)
1559
1560 showBkptTable :: GHCi ()
1561 showBkptTable = do
1562   st <- getGHCiState
1563   printForUser $ prettyLocations (breaks st)
1564
1565 showContext :: GHCi ()
1566 showContext = do
1567    session <- getSession
1568    resumes <- io $ GHC.getResumeContext session
1569    printForUser $ vcat (map pp_resume (reverse resumes))
1570   where
1571    pp_resume resume =
1572         ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1573         $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1574
1575 showPackages :: GHCi ()
1576 showPackages = do
1577   pkg_flags <- fmap packageFlags getDynFlags
1578   io $ putStrLn $ showSDoc $ vcat $
1579     text ("active package flags:"++if null pkg_flags then " none" else "")
1580     : map showFlag pkg_flags
1581   pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1582   io $ putStrLn $ showSDoc $ vcat $
1583     text "packages currently loaded:"
1584     : map (nest 2 . text . packageIdString) pkg_ids
1585   where showFlag (ExposePackage p) = text $ "  -package " ++ p
1586         showFlag (HidePackage p)   = text $ "  -hide-package " ++ p
1587         showFlag (IgnorePackage p) = text $ "  -ignore-package " ++ p
1588
1589 showLanguages :: GHCi ()
1590 showLanguages = do
1591    dflags <- getDynFlags
1592    io $ putStrLn $ showSDoc $ vcat $
1593       text "active language flags:" :
1594       [text ("  -X" ++ str) | (str,f) <- DynFlags.xFlags, dopt f dflags]
1595
1596 -- -----------------------------------------------------------------------------
1597 -- Completion
1598
1599 completeNone :: String -> IO [String]
1600 completeNone _w = return []
1601
1602 completeMacro, completeIdentifier, completeModule,
1603     completeHomeModule, completeSetOptions, completeFilename,
1604     completeHomeModuleOrFile
1605     :: String -> IO [String]
1606
1607 #ifdef USE_READLINE
1608 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1609 completeWord w start end = do
1610   line <- Readline.getLineBuffer
1611   let line_words = words (dropWhile isSpace line)
1612   case w of
1613      ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1614      _other
1615         | ((':':c) : _) <- line_words -> do
1616            maybe_cmd <- lookupCommand' c
1617            let (n,w') = selectWord (words' 0 line)
1618            case maybe_cmd of
1619              Nothing -> return Nothing
1620              Just (_,_,False,complete) -> wrapCompleter complete w
1621              Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1622                                                               return (map (drop n) rets)
1623                                          in wrapCompleter complete' w'
1624         | ("import" : _) <- line_words ->
1625                 wrapCompleter completeModule w
1626         | otherwise     -> do
1627                 --printf "complete %s, start = %d, end = %d\n" w start end
1628                 wrapCompleter completeIdentifier w
1629     where words' _ [] = []
1630           words' n str = let (w,r) = break isSpace str
1631                              (s,r') = span isSpace r
1632                          in (n,w):words' (n+length w+length s) r'
1633           -- In a Haskell expression we want to parse 'a-b' as three words
1634           -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1635           -- only be a single word.
1636           selectWord [] = (0,w)
1637           selectWord ((offset,x):xs)
1638               | offset+length x >= start = (start-offset,take (end-offset) x)
1639               | otherwise = selectWord xs
1640
1641 completeCmd :: String -> IO [String]
1642 completeCmd w = do
1643   cmds <- readIORef macros_ref
1644   return (filter (w `isPrefixOf`) (map (':':)
1645              (map cmdName (builtin_commands ++ cmds))))
1646
1647 completeMacro w = do
1648   cmds <- readIORef macros_ref
1649   return (filter (w `isPrefixOf`) (map cmdName cmds))
1650
1651 completeIdentifier w = do
1652   s <- restoreSession
1653   rdrs <- GHC.getRdrNamesInScope s
1654   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1655
1656 completeModule w = do
1657   s <- restoreSession
1658   dflags <- GHC.getSessionDynFlags s
1659   let pkg_mods = allExposedModules dflags
1660   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1661
1662 completeHomeModule w = do
1663   s <- restoreSession
1664   g <- GHC.getModuleGraph s
1665   let home_mods = map GHC.ms_mod_name g
1666   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1667
1668 completeSetOptions w = do
1669   return (filter (w `isPrefixOf`) options)
1670     where options = "args":"prog":allFlags
1671
1672 completeFilename = Readline.filenameCompletionFunction
1673
1674 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1675
1676 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1677 unionComplete f1 f2 w = do
1678   s1 <- f1 w
1679   s2 <- f2 w
1680   return (s1 ++ s2)
1681
1682 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1683 wrapCompleter fun w =  do
1684   strs <- fun w
1685   case strs of
1686     []  -> return Nothing
1687     [x] -> return (Just (x,[]))
1688     xs  -> case getCommonPrefix xs of
1689                 ""   -> return (Just ("",xs))
1690                 pref -> return (Just (pref,xs))
1691
1692 getCommonPrefix :: [String] -> String
1693 getCommonPrefix [] = ""
1694 getCommonPrefix (s:ss) = foldl common s ss
1695   where common _s "" = ""
1696         common "" _s = ""
1697         common (c:cs) (d:ds)
1698            | c == d = c : common cs ds
1699            | otherwise = ""
1700
1701 allExposedModules :: DynFlags -> [ModuleName]
1702 allExposedModules dflags
1703  = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1704  where
1705   pkg_db = pkgIdMap (pkgState dflags)
1706 #else
1707 completeMacro      = completeNone
1708 completeIdentifier = completeNone
1709 completeModule     = completeNone
1710 completeHomeModule = completeNone
1711 completeSetOptions = completeNone
1712 completeFilename   = completeNone
1713 completeHomeModuleOrFile=completeNone
1714 #endif
1715
1716 -- ---------------------------------------------------------------------------
1717 -- User code exception handling
1718
1719 -- This is the exception handler for exceptions generated by the
1720 -- user's code and exceptions coming from children sessions;
1721 -- it normally just prints out the exception.  The
1722 -- handler must be recursive, in case showing the exception causes
1723 -- more exceptions to be raised.
1724 --
1725 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1726 -- raising another exception.  We therefore don't put the recursive
1727 -- handler arond the flushing operation, so if stderr is closed
1728 -- GHCi will just die gracefully rather than going into an infinite loop.
1729 handler :: Exception -> GHCi Bool
1730
1731 handler exception = do
1732   flushInterpBuffers
1733   io installSignalHandlers
1734   ghciHandle handler (showException exception >> return False)
1735
1736 showException :: Exception -> GHCi ()
1737 showException (DynException dyn) =
1738   case fromDynamic dyn of
1739     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
1740     Just Interrupted      -> io (putStrLn "Interrupted.")
1741     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
1742     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1743     Just other_ghc_ex     -> io (print other_ghc_ex)
1744
1745 showException other_exception
1746   = io (putStrLn ("*** Exception: " ++ show other_exception))
1747
1748 -----------------------------------------------------------------------------
1749 -- recursive exception handlers
1750
1751 -- Don't forget to unblock async exceptions in the handler, or if we're
1752 -- in an exception loop (eg. let a = error a in a) the ^C exception
1753 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1754
1755 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1756 ghciHandle h (GHCi m) = GHCi $ \s ->
1757    Exception.catch (m s)
1758         (\e -> unGHCi (ghciUnblock (h e)) s)
1759
1760 ghciUnblock :: GHCi a -> GHCi a
1761 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1762
1763
1764 -- ----------------------------------------------------------------------------
1765 -- Utils
1766
1767 expandPath :: String -> GHCi String
1768 expandPath path =
1769   case dropWhile isSpace path of
1770    ('~':d) -> do
1771         tilde <- io getHomeDirectory -- will fail if HOME not defined
1772         return (tilde ++ '/':d)
1773    other ->
1774         return other
1775
1776 wantInterpretedModule :: String -> GHCi Module
1777 wantInterpretedModule str = do
1778    session <- getSession
1779    modl <- lookupModule str
1780    is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1781    when (not is_interpreted) $
1782        throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1783    return modl
1784
1785 wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String
1786                               -> (Name -> GHCi ())
1787                               -> GHCi ()
1788 wantNameFromInterpretedModule noCanDo str and_then = do
1789    session <- getSession
1790    names <- io $ GHC.parseName session str
1791    case names of
1792       []    -> return ()
1793       (n:_) -> do
1794             let modl = GHC.nameModule n
1795             if not (GHC.isExternalName n)
1796                then noCanDo n $ ppr n <>
1797                                 text " is not defined in an interpreted module"
1798                else do
1799             is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1800             if not is_interpreted
1801                then noCanDo n $ text "module " <> ppr modl <>
1802                                 text " is not interpreted"
1803                else and_then n
1804
1805 -- -----------------------------------------------------------------------------
1806 -- commands for debugger
1807
1808 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1809 sprintCmd = pprintCommand False False
1810 printCmd  = pprintCommand True False
1811 forceCmd  = pprintCommand False True
1812
1813 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1814 pprintCommand bind force str = do
1815   session <- getSession
1816   io $ pprintClosureCommand session bind force str
1817
1818 stepCmd :: String -> GHCi ()
1819 stepCmd []         = doContinue (const True) GHC.SingleStep
1820 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1821
1822 stepLocalCmd :: String -> GHCi ()
1823 stepLocalCmd  [] = do
1824   mb_span <- getCurrentBreakSpan
1825   case mb_span of
1826     Nothing  -> stepCmd []
1827     Just loc -> do
1828        Just mod <- getCurrentBreakModule
1829        current_toplevel_decl <- enclosingTickSpan mod loc
1830        doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1831
1832 stepLocalCmd expression = stepCmd expression
1833
1834 stepModuleCmd :: String -> GHCi ()
1835 stepModuleCmd  [] = do
1836   mb_span <- getCurrentBreakSpan
1837   case mb_span of
1838     Nothing  -> stepCmd []
1839     Just _ -> do
1840        Just span <- getCurrentBreakSpan
1841        let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
1842        doContinue f GHC.SingleStep
1843
1844 stepModuleCmd expression = stepCmd expression
1845
1846 -- | Returns the span of the largest tick containing the srcspan given
1847 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1848 enclosingTickSpan mod src = do
1849   ticks <- getTickArray mod
1850   let line = srcSpanStartLine src
1851   ASSERT (inRange (bounds ticks) line) do
1852   let enclosing_spans = [ span | (_,span) <- ticks ! line
1853                                , srcSpanEnd span >= srcSpanEnd src]
1854   return . head . sortBy leftmost_largest $ enclosing_spans
1855
1856 traceCmd :: String -> GHCi ()
1857 traceCmd []         = doContinue (const True) GHC.RunAndLogSteps
1858 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1859
1860 continueCmd :: String -> GHCi ()
1861 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1862
1863 -- doContinue :: SingleStep -> GHCi ()
1864 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1865 doContinue pred step = do
1866   session <- getSession
1867   runResult <- io $ GHC.resume session step
1868   afterRunStmt pred runResult
1869   return ()
1870
1871 abandonCmd :: String -> GHCi ()
1872 abandonCmd = noArgs $ do
1873   s <- getSession
1874   b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1875   when (not b) $ io $ putStrLn "There is no computation running."
1876   return ()
1877
1878 deleteCmd :: String -> GHCi ()
1879 deleteCmd argLine = do
1880    deleteSwitch $ words argLine
1881    where
1882    deleteSwitch :: [String] -> GHCi ()
1883    deleteSwitch [] =
1884       io $ putStrLn "The delete command requires at least one argument."
1885    -- delete all break points
1886    deleteSwitch ("*":_rest) = discardActiveBreakPoints
1887    deleteSwitch idents = do
1888       mapM_ deleteOneBreak idents
1889       where
1890       deleteOneBreak :: String -> GHCi ()
1891       deleteOneBreak str
1892          | all isDigit str = deleteBreak (read str)
1893          | otherwise = return ()
1894
1895 historyCmd :: String -> GHCi ()
1896 historyCmd arg
1897   | null arg        = history 20
1898   | all isDigit arg = history (read arg)
1899   | otherwise       = io $ putStrLn "Syntax:  :history [num]"
1900   where
1901   history num = do
1902     s <- getSession
1903     resumes <- io $ GHC.getResumeContext s
1904     case resumes of
1905       [] -> io $ putStrLn "Not stopped at a breakpoint"
1906       (r:_) -> do
1907         let hist = GHC.resumeHistory r
1908             (took,rest) = splitAt num hist
1909         spans <- mapM (io . GHC.getHistorySpan s) took
1910         let nums  = map (printf "-%-3d:") [(1::Int)..]
1911         let names = map GHC.historyEnclosingDecl took
1912         printForUser (vcat(zipWith3
1913                              (\x y z -> x <+> y <+> z)
1914                              (map text nums)
1915                              (map (bold . ppr) names)
1916                              (map (parens . ppr) spans)))
1917         io $ putStrLn $ if null rest then "<end of history>" else "..."
1918
1919 bold :: SDoc -> SDoc
1920 bold c | do_bold   = text start_bold <> c <> text end_bold
1921        | otherwise = c
1922
1923 backCmd :: String -> GHCi ()
1924 backCmd = noArgs $ do
1925   s <- getSession
1926   (names, _, span) <- io $ GHC.back s
1927   printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1928   printTypeOfNames s names
1929    -- run the command set with ":set stop <cmd>"
1930   st <- getGHCiState
1931   enqueueCommands [stop st]
1932
1933 forwardCmd :: String -> GHCi ()
1934 forwardCmd = noArgs $ do
1935   s <- getSession
1936   (names, ix, span) <- io $ GHC.forward s
1937   printForUser $ (if (ix == 0)
1938                     then ptext SLIT("Stopped at")
1939                     else ptext SLIT("Logged breakpoint at")) <+> ppr span
1940   printTypeOfNames s names
1941    -- run the command set with ":set stop <cmd>"
1942   st <- getGHCiState
1943   enqueueCommands [stop st]
1944
1945 -- handle the "break" command
1946 breakCmd :: String -> GHCi ()
1947 breakCmd argLine = do
1948    session <- getSession
1949    breakSwitch session $ words argLine
1950
1951 breakSwitch :: Session -> [String] -> GHCi ()
1952 breakSwitch _session [] = do
1953    io $ putStrLn "The break command requires at least one argument."
1954 breakSwitch session (arg1:rest)
1955    | looksLikeModuleName arg1 = do
1956         mod <- wantInterpretedModule arg1
1957         breakByModule mod rest
1958    | all isDigit arg1 = do
1959         (toplevel, _) <- io $ GHC.getContext session
1960         case toplevel of
1961            (mod : _) -> breakByModuleLine mod (read arg1) rest
1962            [] -> do
1963               io $ putStrLn "Cannot find default module for breakpoint."
1964               io $ putStrLn "Perhaps no modules are loaded for debugging?"
1965    | otherwise = do -- try parsing it as an identifier
1966         wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1967         let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1968         if GHC.isGoodSrcLoc loc
1969                then findBreakAndSet (GHC.nameModule name) $
1970                          findBreakByCoord (Just (GHC.srcLocFile loc))
1971                                           (GHC.srcLocLine loc,
1972                                            GHC.srcLocCol loc)
1973                else noCanDo name $ text "can't find its location: " <> ppr loc
1974        where
1975           noCanDo n why = printForUser $
1976                 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1977
1978 breakByModule :: Module -> [String] -> GHCi ()
1979 breakByModule mod (arg1:rest)
1980    | all isDigit arg1 = do  -- looks like a line number
1981         breakByModuleLine mod (read arg1) rest
1982 breakByModule _ _
1983    = breakSyntax
1984
1985 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1986 breakByModuleLine mod line args
1987    | [] <- args = findBreakAndSet mod $ findBreakByLine line
1988    | [col] <- args, all isDigit col =
1989         findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1990    | otherwise = breakSyntax
1991
1992 breakSyntax :: a
1993 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1994
1995 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1996 findBreakAndSet mod lookupTickTree = do
1997    tickArray <- getTickArray mod
1998    (breakArray, _) <- getModBreak mod
1999    case lookupTickTree tickArray of
2000       Nothing  -> io $ putStrLn $ "No breakpoints found at that location."
2001       Just (tick, span) -> do
2002          success <- io $ setBreakFlag True breakArray tick
2003          if success
2004             then do
2005                (alreadySet, nm) <-
2006                      recordBreak $ BreakLocation
2007                              { breakModule = mod
2008                              , breakLoc = span
2009                              , breakTick = tick
2010                              , onBreakCmd = ""
2011                              }
2012                printForUser $
2013                   text "Breakpoint " <> ppr nm <>
2014                   if alreadySet
2015                      then text " was already set at " <> ppr span
2016                      else text " activated at " <> ppr span
2017             else do
2018             printForUser $ text "Breakpoint could not be activated at"
2019                                  <+> ppr span
2020
2021 -- When a line number is specified, the current policy for choosing
2022 -- the best breakpoint is this:
2023 --    - the leftmost complete subexpression on the specified line, or
2024 --    - the leftmost subexpression starting on the specified line, or
2025 --    - the rightmost subexpression enclosing the specified line
2026 --
2027 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2028 findBreakByLine line arr
2029   | not (inRange (bounds arr) line) = Nothing
2030   | otherwise =
2031     listToMaybe (sortBy (leftmost_largest `on` snd)  complete)   `mplus`
2032     listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2033     listToMaybe (sortBy (rightmost `on` snd) ticks)
2034   where
2035         ticks = arr ! line
2036
2037         starts_here = [ tick | tick@(_,span) <- ticks,
2038                                GHC.srcSpanStartLine span == line ]
2039
2040         (complete,incomplete) = partition ends_here starts_here
2041             where ends_here (_,span) = GHC.srcSpanEndLine span == line
2042
2043 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2044                  -> Maybe (BreakIndex,SrcSpan)
2045 findBreakByCoord mb_file (line, col) arr
2046   | not (inRange (bounds arr) line) = Nothing
2047   | otherwise =
2048     listToMaybe (sortBy (rightmost `on` snd) contains ++
2049                  sortBy (leftmost_smallest `on` snd) after_here)
2050   where
2051         ticks = arr ! line
2052
2053         -- the ticks that span this coordinate
2054         contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2055                             is_correct_file span ]
2056
2057         is_correct_file span
2058                  | Just f <- mb_file = GHC.srcSpanFile span == f
2059                  | otherwise         = True
2060
2061         after_here = [ tick | tick@(_,span) <- ticks,
2062                               GHC.srcSpanStartLine span == line,
2063                               GHC.srcSpanStartCol span >= col ]
2064
2065 -- For now, use ANSI bold on terminals that we know support it.
2066 -- Otherwise, we add a line of carets under the active expression instead.
2067 -- In particular, on Windows and when running the testsuite (which sets
2068 -- TERM to vt100 for other reasons) we get carets.
2069 -- We really ought to use a proper termcap/terminfo library.
2070 do_bold :: Bool
2071 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2072     where mTerm = System.Environment.getEnv "TERM"
2073                   `Exception.catch` \_ -> return "TERM not set"
2074
2075 start_bold :: String
2076 start_bold = "\ESC[1m"
2077 end_bold :: String
2078 end_bold   = "\ESC[0m"
2079
2080 listCmd :: String -> GHCi ()
2081 listCmd "" = do
2082    mb_span <- getCurrentBreakSpan
2083    case mb_span of
2084       Nothing  -> printForUser $ text "not stopped at a breakpoint; nothing to list"
2085       Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
2086                 | otherwise              -> printForUser $ text "unable to list source for" <+> ppr span
2087 listCmd str = list2 (words str)
2088
2089 list2 :: [String] -> GHCi ()
2090 list2 [arg] | all isDigit arg = do
2091     session <- getSession
2092     (toplevel, _) <- io $ GHC.getContext session
2093     case toplevel of
2094         [] -> io $ putStrLn "No module to list"
2095         (mod : _) -> listModuleLine mod (read arg)
2096 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2097         mod <- wantInterpretedModule arg1
2098         listModuleLine mod (read arg2)
2099 list2 [arg] = do
2100         wantNameFromInterpretedModule noCanDo arg $ \name -> do
2101         let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2102         if GHC.isGoodSrcLoc loc
2103                then do
2104                   tickArray <- getTickArray (GHC.nameModule name)
2105                   let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2106                                         (GHC.srcLocLine loc, GHC.srcLocCol loc)
2107                                         tickArray
2108                   case mb_span of
2109                     Nothing       -> io $ listAround (GHC.srcLocSpan loc) False
2110                     Just (_,span) -> io $ listAround span False
2111                else
2112                   noCanDo name $ text "can't find its location: " <>
2113                                  ppr loc
2114     where
2115         noCanDo n why = printForUser $
2116             text "cannot list source code for " <> ppr n <> text ": " <> why
2117 list2  _other =
2118         io $ putStrLn "syntax:  :list [<line> | <module> <line> | <identifier>]"
2119
2120 listModuleLine :: Module -> Int -> GHCi ()
2121 listModuleLine modl line = do
2122    session <- getSession
2123    graph <- io (GHC.getModuleGraph session)
2124    let this = filter ((== modl) . GHC.ms_mod) graph
2125    case this of
2126      [] -> panic "listModuleLine"
2127      summ:_ -> do
2128            let filename = fromJust (ml_hs_file (GHC.ms_location summ))
2129                loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2130            io $ listAround (GHC.srcLocSpan loc) False
2131
2132 -- | list a section of a source file around a particular SrcSpan.
2133 -- If the highlight flag is True, also highlight the span using
2134 -- start_bold/end_bold.
2135 listAround :: SrcSpan -> Bool -> IO ()
2136 listAround span do_highlight = do
2137       contents <- BS.readFile (unpackFS file)
2138       let
2139           lines = BS.split '\n' contents
2140           these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2141                         drop (line1 - 1 - pad_before) $ lines
2142           fst_line = max 1 (line1 - pad_before)
2143           line_nos = [ fst_line .. ]
2144
2145           highlighted | do_highlight = zipWith highlight line_nos these_lines
2146                       | otherwise    = [\p -> BS.concat[p,l] | l <- these_lines]
2147
2148           bs_line_nos = [ BS.pack (show l ++ "  ") | l <- line_nos ]
2149           prefixed = zipWith ($) highlighted bs_line_nos
2150       --
2151       BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed)
2152   where
2153         file  = GHC.srcSpanFile span
2154         line1 = GHC.srcSpanStartLine span
2155         col1  = GHC.srcSpanStartCol span
2156         line2 = GHC.srcSpanEndLine span
2157         col2  = GHC.srcSpanEndCol span
2158
2159         pad_before | line1 == 1 = 0
2160                    | otherwise  = 1
2161         pad_after = 1
2162
2163         highlight | do_bold   = highlight_bold
2164                   | otherwise = highlight_carets
2165
2166         highlight_bold no line prefix
2167           | no == line1 && no == line2
2168           = let (a,r) = BS.splitAt col1 line
2169                 (b,c) = BS.splitAt (col2-col1) r
2170             in
2171             BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2172           | no == line1
2173           = let (a,b) = BS.splitAt col1 line in
2174             BS.concat [prefix, a, BS.pack start_bold, b]
2175           | no == line2
2176           = let (a,b) = BS.splitAt col2 line in
2177             BS.concat [prefix, a, BS.pack end_bold, b]
2178           | otherwise   = BS.concat [prefix, line]
2179
2180         highlight_carets no line prefix
2181           | no == line1 && no == line2
2182           = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2183                                          BS.replicate (col2-col1) '^']
2184           | no == line1
2185           = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2186                                          prefix, line]
2187           | no == line2
2188           = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2189                                          BS.pack "^^"]
2190           | otherwise   = BS.concat [prefix, line]
2191          where
2192            indent = BS.pack ("  " ++ replicate (length (show no)) ' ')
2193            nl = BS.singleton '\n'
2194
2195 -- --------------------------------------------------------------------------
2196 -- Tick arrays
2197
2198 getTickArray :: Module -> GHCi TickArray
2199 getTickArray modl = do
2200    st <- getGHCiState
2201    let arrmap = tickarrays st
2202    case lookupModuleEnv arrmap modl of
2203       Just arr -> return arr
2204       Nothing  -> do
2205         (_breakArray, ticks) <- getModBreak modl
2206         let arr = mkTickArray (assocs ticks)
2207         setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2208         return arr
2209
2210 discardTickArrays :: GHCi ()
2211 discardTickArrays = do
2212    st <- getGHCiState
2213    setGHCiState st{tickarrays = emptyModuleEnv}
2214
2215 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2216 mkTickArray ticks
2217   = accumArray (flip (:)) [] (1, max_line)
2218         [ (line, (nm,span)) | (nm,span) <- ticks,
2219                               line <- srcSpanLines span ]
2220     where
2221         max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2222         srcSpanLines span = [ GHC.srcSpanStartLine span ..
2223                               GHC.srcSpanEndLine span ]
2224
2225 lookupModule :: String -> GHCi Module
2226 lookupModule modName
2227    = do session <- getSession
2228         io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
2229
2230 -- don't reset the counter back to zero?
2231 discardActiveBreakPoints :: GHCi ()
2232 discardActiveBreakPoints = do
2233    st <- getGHCiState
2234    mapM (turnOffBreak.snd) (breaks st)
2235    setGHCiState $ st { breaks = [] }
2236
2237 deleteBreak :: Int -> GHCi ()
2238 deleteBreak identity = do
2239    st <- getGHCiState
2240    let oldLocations    = breaks st
2241        (this,rest)     = partition (\loc -> fst loc == identity) oldLocations
2242    if null this
2243       then printForUser (text "Breakpoint" <+> ppr identity <+>
2244                          text "does not exist")
2245       else do
2246            mapM (turnOffBreak.snd) this
2247            setGHCiState $ st { breaks = rest }
2248
2249 turnOffBreak :: BreakLocation -> GHCi Bool
2250 turnOffBreak loc = do
2251   (arr, _) <- getModBreak (breakModule loc)
2252   io $ setBreakFlag False arr (breakTick loc)
2253
2254 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2255 getModBreak mod = do
2256    session <- getSession
2257    Just mod_info <- io $ GHC.getModuleInfo session mod
2258    let modBreaks  = GHC.modInfoModBreaks mod_info
2259    let array      = GHC.modBreaks_flags modBreaks
2260    let ticks      = GHC.modBreaks_locs  modBreaks
2261    return (array, ticks)
2262
2263 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2264 setBreakFlag toggle array index
2265    | toggle    = GHC.setBreakOn array index
2266    | otherwise = GHC.setBreakOff array index
2267