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