compiler/ghci/InteractiveUI.hs

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