ghc/InteractiveUI.hs

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