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