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