compiler/ghci/InteractiveUI.hs

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