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