ghc/InteractiveUI.hs

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