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