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