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