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