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