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