compiler/ghci/InteractiveUI.hs

   1 {-# OPTIONS -#include "Linker.h" #-}
   2 -----------------------------------------------------------------------------
   3 --
   4 -- GHC Interactive User Interface
   5 --
   6 -- (c) The GHC Team 2005-2006
   7 --
   8 -----------------------------------------------------------------------------
   9 module InteractiveUI (
  10         interactiveUI,
  11         ghciWelcomeMsg
  12    ) where
  13
  14 #include "HsVersions.h"
  15
  16 import GhciMonad
  17 import GhciTags
  18 import Debugger
  19
  20 -- The GHC interface
  21 import qualified GHC
  22 import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
  23                           Type, Module, ModuleName, TyThing(..), Phase,
  24                           BreakIndex, Name, SrcSpan, Resume, SingleStep )
  25 import DynFlags
  26 import Packages
  27 import PackageConfig
  28 import UniqFM
  29 import PprTyThing
  30 import Outputable       hiding (printForUser)
  31 import Module           -- for ModuleEnv
  32
  33 -- Other random utilities
  34 import Digraph
  35 import BasicTypes hiding (isTopLevel)
  36 import Panic      hiding (showException)
  37 import Config
  38 import StaticFlags
  39 import Linker
  40 import Util
  41 import FastString
  42
  43 #ifndef mingw32_HOST_OS
  44 import System.Posix hiding (getEnv)
  45 #else
  46 import GHC.ConsoleHandler ( flushConsole )
  47 import System.Win32       ( setConsoleCP, setConsoleOutputCP )
  48 import qualified System.Win32
  49 #endif
  50
  51 #ifdef USE_READLINE
  52 import Control.Concurrent       ( yield )       -- Used in readline loop
  53 import System.Console.Readline as Readline
  54 #endif
  55
  56 --import SystemExts
  57
  58 import Control.Exception as Exception
  59 -- import Control.Concurrent
  60
  61 import qualified Data.ByteString.Char8 as BS
  62 import Data.List
  63 import Data.Maybe
  64 import System.Cmd
  65 import System.Environment
  66 import System.Exit      ( exitWith, ExitCode(..) )
  67 import System.Directory
  68 import System.IO
  69 import System.IO.Error as IO
  70 import Data.Char
  71 import Data.Dynamic
  72 import Data.Array
  73 import Control.Monad as Monad
  74 import Text.Printf
  75
  76 import Foreign.StablePtr        ( newStablePtr )
  77 import GHC.Exts         ( unsafeCoerce# )
  78 import GHC.IOBase       ( IOErrorType(InvalidArgument) )
  79
  80 import Data.IORef       ( IORef, readIORef, writeIORef )
  81
  82 import System.Posix.Internals ( setNonBlockingFD )
  83
  84 -----------------------------------------------------------------------------
  85
  86 ghciWelcomeMsg =
  87  "   ___         ___ _\n"++
  88  "  / _ \\ /\\  /\\/ __(_)\n"++
  89  " / /_\\// /_/ / /  | |    GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
  90  "/ /_\\\\/ __  / /___| |    http://www.haskell.org/ghc/\n"++
  91  "\\____/\\/ /_/\\____/|_|    Type :? for help.\n"
  92
  93 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
  94 cmdName (n,_,_,_) = n
  95
  96 GLOBAL_VAR(commands, builtin_commands, [Command])
  97
  98 builtin_commands :: [Command]
  99 builtin_commands = [
 100         -- Hugs users are accustomed to :e, so make sure it doesn't overlap
 101   ("?",         keepGoing help,                 False, completeNone),
 102   ("add",       keepGoingPaths addModule,       False, completeFilename),
 103   ("abandon",   keepGoing abandonCmd,           False, completeNone),
 104   ("break",     keepGoing breakCmd,             False, completeIdentifier),
 105   ("back",      keepGoing backCmd,              False, completeNone),
 106   ("browse",    keepGoing browseCmd,            False, completeModule),
 107   ("cd",        keepGoing changeDirectory,      False, completeFilename),
 108   ("check",     keepGoing checkModule,          False, completeHomeModule),
 109   ("continue",  keepGoing continueCmd,          False, completeNone),
 110   ("cmd",       keepGoing cmdCmd,               False, completeIdentifier),
 111   ("ctags",     keepGoing createCTagsFileCmd,   False, completeFilename),
 112   ("def",       keepGoing defineMacro,          False, completeIdentifier),
 113   ("delete",    keepGoing deleteCmd,            False, completeNone),
 114   ("e",         keepGoing editFile,             False, completeFilename),
 115   ("edit",      keepGoing editFile,             False, completeFilename),
 116   ("etags",     keepGoing createETagsFileCmd,   False, completeFilename),
 117   ("force",     keepGoing forceCmd,             False, completeIdentifier),
 118   ("forward",   keepGoing forwardCmd,           False, completeNone),
 119   ("help",      keepGoing help,                 False, completeNone),
 120   ("history",   keepGoing historyCmd,           False, completeNone),
 121   ("info",      keepGoing info,                 False, completeIdentifier),
 122   ("kind",      keepGoing kindOfType,           False, completeIdentifier),
 123   ("load",      keepGoingPaths loadModule_,     False, completeHomeModuleOrFile),
 124   ("list",      keepGoing listCmd,              False, completeNone),
 125   ("module",    keepGoing setContext,           False, completeModule),
 126   ("main",      keepGoing runMain,              False, completeIdentifier),
 127   ("print",     keepGoing printCmd,             False, completeIdentifier),
 128   ("quit",      quit,                           False, completeNone),
 129   ("reload",    keepGoing reloadModule,         False, completeNone),
 130   ("set",       keepGoing setCmd,               True,  completeSetOptions),
 131   ("show",      keepGoing showCmd,              False, completeNone),
 132   ("sprint",    keepGoing sprintCmd,            False, completeIdentifier),
 133   ("step",      keepGoing stepCmd,              False, completeIdentifier),
 134   ("type",      keepGoing typeOfExpr,           False, completeIdentifier),
 135   ("trace",     keepGoing traceCmd,             False, completeIdentifier),
 136   ("undef",     keepGoing undefineMacro,        False, completeMacro),
 137   ("unset",     keepGoing unsetOptions,         True,  completeSetOptions)
 138   ]
 139
 140 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 141 keepGoing a str = a str >> return False
 142
 143 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
 144 keepGoingPaths a str = a (toArgs str) >> return False
 145
 146 shortHelpText = "use :? for help.\n"
 147
 148 helpText =
 149  " Commands available from the prompt:\n" ++
 150  "\n" ++
 151  "   <statement>                 evaluate/run <statement>\n" ++
 152  "   :add <filename> ...         add module(s) to the current target set\n" ++
 153  "   :browse [*]<module>         display the names defined by <module>\n" ++
 154  "   :cd <dir>                   change directory to <dir>\n" ++
 155  "   :cmd <expr>                 run the commands returned by <expr>::IO String\n" ++
 156  "   :ctags [<file>]             create tags file for Vi (default: \"tags\")\n" ++
 157  "   :def <cmd> <expr>           define a command :<cmd>\n" ++
 158  "   :edit <file>                edit file\n" ++
 159  "   :edit                       edit last module\n" ++
 160  "   :etags [<file>]             create tags file for Emacs (default: \"TAGS\")\n" ++
 161  "   :help, :?                   display this list of commands\n" ++
 162  "   :info [<name> ...]          display information about the given names\n" ++
 163  "   :kind <type>                show the kind of <type>\n" ++
 164  "   :load <filename> ...        load module(s) and their dependents\n" ++
 165  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
 166  "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
 167  "   :quit                       exit GHCi\n" ++
 168  "   :reload                     reload the current module set\n" ++
 169  "   :type <expr>                show the type of <expr>\n" ++
 170  "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
 171  "   :!<command>                 run the shell command <command>\n" ++
 172  "\n" ++
 173  " -- Commands for debugging:\n" ++
 174  "\n" ++
 175  "   :abandon                    at a breakpoint, abandon current computation\n" ++
 176  "   :back                       go back in the history (after :trace)\n" ++
 177  "   :break [<mod>] <l> [<col>]  set a breakpoint at the specified location\n" ++
 178  "   :break <name>               set a breakpoint on the specified function\n" ++
 179  "   :continue                   resume after a breakpoint\n" ++
 180  "   :delete <number>            delete the specified breakpoint\n" ++
 181  "   :delete *                   delete all breakpoints\n" ++
 182  "   :force <expr>               print <expr>, forcing unevaluated parts\n" ++
 183  "   :forward                    go forward in the history (after :back)\n" ++
 184  "   :history [<n>]              show the last <n> items in the history (after :trace)\n" ++
 185  "   :print [<name> ...]         prints a value without forcing its computation\n" ++
 186  "   :sprint [<name> ...]        simplifed version of :print\n" ++
 187  "   :step                       single-step after stopping at a breakpoint\n"++
 188  "   :step <expr>                single-step into <expr>\n"++
 189  "   :trace                      trace after stopping at a breakpoint\n"++
 190  "   :trace <expr>               trace into <expr> (remembers breakpoints for :history)\n"++
 191
 192  "\n" ++
 193  " -- Commands for changing settings:\n" ++
 194  "\n" ++
 195  "   :set <option> ...           set options\n" ++
 196  "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
 197  "   :set prog <progname>        set the value returned by System.getProgName\n" ++
 198  "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
 199  "   :set editor <cmd>           set the command used for :edit\n" ++
 200  "   :set stop <cmd>             set the command to run when a breakpoint is hit\n" ++
 201  "   :unset <option> ...         unset options\n" ++
 202  "\n" ++
 203  "  Options for ':set' and ':unset':\n" ++
 204  "\n" ++
 205  "    +r            revert top-level expressions after each evaluation\n" ++
 206  "    +s            print timing/memory stats after each evaluation\n" ++
 207  "    +t            print type after evaluation\n" ++
 208  "    -<flags>      most GHC command line flags can also be set here\n" ++
 209  "                         (eg. -v2, -fglasgow-exts, etc.)\n" ++
 210  "\n" ++
 211  " -- Commands for displaying information:\n" ++
 212  "\n" ++
 213  "   :show bindings              show the current bindings made at the prompt\n" ++
 214  "   :show breaks                show the active breakpoints\n" ++
 215  "   :show context               show the breakpoint context\n" ++
 216  "   :show modules               show the currently loaded modules\n" ++
 217  "   :show <setting>             show anything that can be set with :set (e.g. args)\n" ++
 218  "\n"
 219
 220 findEditor = do
 221   getEnv "EDITOR"
 222     `IO.catch` \_ -> do
 223 #if mingw32_HOST_OS
 224         win <- System.Win32.getWindowsDirectory
 225         return (win `joinFileName` "notepad.exe")
 226 #else
 227         return ""
 228 #endif
 229
 230 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
 231 interactiveUI session srcs maybe_expr = do
 232    -- HACK! If we happen to get into an infinite loop (eg the user
 233    -- types 'let x=x in x' at the prompt), then the thread will block
 234    -- on a blackhole, and become unreachable during GC.  The GC will
 235    -- detect that it is unreachable and send it the NonTermination
 236    -- exception.  However, since the thread is unreachable, everything
 237    -- it refers to might be finalized, including the standard Handles.
 238    -- This sounds like a bug, but we don't have a good solution right
 239    -- now.
 240    newStablePtr stdin
 241    newStablePtr stdout
 242    newStablePtr stderr
 243
 244         -- Initialise buffering for the *interpreted* I/O system
 245    initInterpBuffering session
 246
 247    when (isNothing maybe_expr) $ do
 248         -- Only for GHCi (not runghc and ghc -e):
 249         -- Turn buffering off for the compiled program's stdout/stderr
 250         turnOffBuffering
 251         -- Turn buffering off for GHCi's stdout
 252         hFlush stdout
 253         hSetBuffering stdout NoBuffering
 254         -- We don't want the cmd line to buffer any input that might be
 255         -- intended for the program, so unbuffer stdin.
 256         hSetBuffering stdin NoBuffering
 257
 258         -- initial context is just the Prelude
 259    prel_mod <- GHC.findModule session prel_name (Just basePackageId)
 260    GHC.setContext session [] [prel_mod]
 261
 262 #ifdef USE_READLINE
 263    Readline.initialize
 264    Readline.setAttemptedCompletionFunction (Just completeWord)
 265    --Readline.parseAndBind "set show-all-if-ambiguous 1"
 266
 267    let symbols = "!#$%&*+/<=>?@\\^|-~"
 268        specials = "(),;[]`{}"
 269        spaces = " \t\n"
 270        word_break_chars = spaces ++ specials ++ symbols
 271
 272    Readline.setBasicWordBreakCharacters word_break_chars
 273    Readline.setCompleterWordBreakCharacters word_break_chars
 274 #endif
 275
 276    default_editor <- findEditor
 277
 278    startGHCi (runGHCi srcs maybe_expr)
 279         GHCiState{ progname = "<interactive>",
 280                    args = [],
 281                    prompt = "%s> ",
 282                    stop = "",
 283                    editor = default_editor,
 284                    session = session,
 285                    options = [],
 286                    prelude = prel_mod,
 287                    break_ctr = 0,
 288                    breaks = [],
 289                    tickarrays = emptyModuleEnv,
 290                    cmdqueue = []
 291                  }
 292
 293 #ifdef USE_READLINE
 294    Readline.resetTerminal Nothing
 295 #endif
 296
 297    return ()
 298
 299 prel_name = GHC.mkModuleName "Prelude"
 300
 301 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
 302 runGHCi paths maybe_expr = do
 303   let read_dot_files = not opt_IgnoreDotGhci
 304
 305   when (read_dot_files) $ do
 306     -- Read in ./.ghci.
 307     let file = "./.ghci"
 308     exists <- io (doesFileExist file)
 309     when exists $ do
 310        dir_ok  <- io (checkPerms ".")
 311        file_ok <- io (checkPerms file)
 312        when (dir_ok && file_ok) $ do
 313           either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
 314           case either_hdl of
 315              Left e    -> return ()
 316              Right hdl -> fileLoop hdl False
 317
 318   when (read_dot_files) $ do
 319     -- Read in $HOME/.ghci
 320     either_dir <- io (IO.try (getEnv "HOME"))
 321     case either_dir of
 322        Left e -> return ()
 323        Right dir -> do
 324           cwd <- io (getCurrentDirectory)
 325           when (dir /= cwd) $ do
 326              let file = dir ++ "/.ghci"
 327              ok <- io (checkPerms file)
 328              when ok $ do
 329                either_hdl <- io (IO.try (openFile file ReadMode))
 330                case either_hdl of
 331                   Left e    -> return ()
 332                   Right hdl -> fileLoop hdl False
 333
 334   -- Perform a :load for files given on the GHCi command line
 335   -- When in -e mode, if the load fails then we want to stop
 336   -- immediately rather than going on to evaluate the expression.
 337   when (not (null paths)) $ do
 338      ok <- ghciHandle (\e -> do showException e; return Failed) $
 339                 loadModule paths
 340      when (isJust maybe_expr && failed ok) $
 341         io (exitWith (ExitFailure 1))
 342
 343   -- if verbosity is greater than 0, or we are connected to a
 344   -- terminal, display the prompt in the interactive loop.
 345   is_tty <- io (hIsTerminalDevice stdin)
 346   dflags <- getDynFlags
 347   let show_prompt = verbosity dflags > 0 || is_tty
 348
 349   case maybe_expr of
 350         Nothing ->
 351           do
 352 #if defined(mingw32_HOST_OS)
 353             -- The win32 Console API mutates the first character of
 354             -- type-ahead when reading from it in a non-buffered manner. Work
 355             -- around this by flushing the input buffer of type-ahead characters,
 356             -- but only if stdin is available.
 357             flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
 358             case flushed of
 359              Left err | isDoesNotExistError err -> return ()
 360                       | otherwise -> io (ioError err)
 361              Right () -> return ()
 362 #endif
 363             -- initialise the console if necessary
 364             io setUpConsole
 365
 366             -- enter the interactive loop
 367             interactiveLoop is_tty show_prompt
 368         Just expr -> do
 369             -- just evaluate the expression we were given
 370             runCommandEval expr
 371             return ()
 372
 373   -- and finally, exit
 374   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
 375
 376
 377 interactiveLoop is_tty show_prompt =
 378   -- Ignore ^C exceptions caught here
 379   ghciHandleDyn (\e -> case e of
 380                         Interrupted -> do
 381 #if defined(mingw32_HOST_OS)
 382                                 io (putStrLn "")
 383 #endif
 384                                 interactiveLoop is_tty show_prompt
 385                         _other      -> return ()) $
 386
 387   ghciUnblock $ do -- unblock necessary if we recursed from the
 388                    -- exception handler above.
 389
 390   -- read commands from stdin
 391 #ifdef USE_READLINE
 392   if (is_tty)
 393         then readlineLoop
 394         else fileLoop stdin show_prompt
 395 #else
 396   fileLoop stdin show_prompt
 397 #endif
 398
 399
 400 -- NOTE: We only read .ghci files if they are owned by the current user,
 401 -- and aren't world writable.  Otherwise, we could be accidentally
 402 -- running code planted by a malicious third party.
 403
 404 -- Furthermore, We only read ./.ghci if . is owned by the current user
 405 -- and isn't writable by anyone else.  I think this is sufficient: we
 406 -- don't need to check .. and ../.. etc. because "."  always refers to
 407 -- the same directory while a process is running.
 408
 409 checkPerms :: String -> IO Bool
 410 checkPerms name =
 411 #ifdef mingw32_HOST_OS
 412   return True
 413 #else
 414   Util.handle (\_ -> return False) $ do
 415      st <- getFileStatus name
 416      me <- getRealUserID
 417      if fileOwner st /= me then do
 418         putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
 419         return False
 420       else do
 421         let mode =  fileMode st
 422         if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
 423            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
 424            then do
 425                putStrLn $ "*** WARNING: " ++ name ++
 426                           " is writable by someone else, IGNORING!"
 427                return False
 428           else return True
 429 #endif
 430
 431 fileLoop :: Handle -> Bool -> GHCi ()
 432 fileLoop hdl show_prompt = do
 433    when show_prompt $ do
 434         prompt <- mkPrompt
 435         (io (putStr prompt))
 436    l <- io (IO.try (hGetLine hdl))
 437    case l of
 438         Left e | isEOFError e              -> return ()
 439                | InvalidArgument <- etype  -> return ()
 440                | otherwise                 -> io (ioError e)
 441                 where etype = ioeGetErrorType e
 442                 -- treat InvalidArgument in the same way as EOF:
 443                 -- this can happen if the user closed stdin, or
 444                 -- perhaps did getContents which closes stdin at
 445                 -- EOF.
 446         Right l ->
 447           case removeSpaces l of
 448             "" -> fileLoop hdl show_prompt
 449             l  -> do quit <- runCommands l
 450                      if quit then return () else fileLoop hdl show_prompt
 451
 452 mkPrompt = do
 453   session <- getSession
 454   (toplevs,exports) <- io (GHC.getContext session)
 455   resumes <- io $ GHC.getResumeContext session
 456
 457   context_bit <-
 458         case resumes of
 459             [] -> return empty
 460             r:rs -> do
 461                 let ix = GHC.resumeHistoryIx r
 462                 if ix == 0
 463                    then return (brackets (ppr (GHC.resumeSpan r)) <> space)
 464                    else do
 465                         let hist = GHC.resumeHistory r !! (ix-1)
 466                         span <- io $ GHC.getHistorySpan session hist
 467                         return (brackets (ppr (negate ix) <> char ':'
 468                                           <+> ppr span) <> space)
 469   let
 470         dots | r:rs <- resumes, not (null rs) = text "... "
 471              | otherwise = empty
 472
 473         modules_bit =
 474              hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
 475              hsep (map (ppr . GHC.moduleName) exports)
 476
 477         deflt_prompt = dots <> context_bit <> modules_bit
 478
 479         f ('%':'s':xs) = deflt_prompt <> f xs
 480         f ('%':'%':xs) = char '%' <> f xs
 481         f (x:xs) = char x <> f xs
 482         f [] = empty
 483    --
 484   st <- getGHCiState
 485   return (showSDoc (f (prompt st)))
 486
 487
 488 #ifdef USE_READLINE
 489 readlineLoop :: GHCi ()
 490 readlineLoop = do
 491    session <- getSession
 492    (mod,imports) <- io (GHC.getContext session)
 493    io yield
 494    saveSession -- for use by completion
 495    st <- getGHCiState
 496    mb_span <- getCurrentBreakSpan
 497    prompt <- mkPrompt
 498    l <- io (readline prompt `finally` setNonBlockingFD 0)
 499                 -- readline sometimes puts stdin into blocking mode,
 500                 -- so we need to put it back for the IO library
 501    splatSavedSession
 502    case l of
 503         Nothing -> return ()
 504         Just l  ->
 505           case removeSpaces l of
 506             "" -> readlineLoop
 507             l  -> do
 508                   io (addHistory l)
 509                   quit <- runCommands l
 510                   if quit then return () else readlineLoop
 511 #endif
 512
 513 runCommands :: String -> GHCi Bool
 514 runCommands cmd = do
 515         q <- ghciHandle handler (doCommand cmd)
 516         if q then return True else runNext
 517   where
 518        runNext = do
 519           st <- getGHCiState
 520           case cmdqueue st of
 521             []   -> return False
 522             c:cs -> do setGHCiState st{ cmdqueue = cs }
 523                        runCommands c
 524
 525        doCommand (':' : cmd) = specialCommand cmd
 526        doCommand stmt        = do timeIt $ runStmt stmt GHC.RunToCompletion
 527                                   return False
 528
 529 enqueueCommands :: [String] -> GHCi ()
 530 enqueueCommands cmds = do
 531   st <- getGHCiState
 532   setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
 533
 534
 535 -- This version is for the GHC command-line option -e.  The only difference
 536 -- from runCommand is that it catches the ExitException exception and
 537 -- exits, rather than printing out the exception.
 538 runCommandEval c = ghciHandle handleEval (doCommand c)
 539   where
 540     handleEval (ExitException code) = io (exitWith code)
 541     handleEval e                    = do handler e
 542                                          io (exitWith (ExitFailure 1))
 543
 544     doCommand (':' : command) = specialCommand command
 545     doCommand stmt
 546        = do r <- runStmt stmt GHC.RunToCompletion
 547             case r of
 548                 False -> io (exitWith (ExitFailure 1))
 549                   -- failure to run the command causes exit(1) for ghc -e.
 550                 _       -> return True
 551
 552 runStmt :: String -> SingleStep -> GHCi Bool
 553 runStmt stmt step
 554  | null (filter (not.isSpace) stmt) = return False
 555  | ["import", mod] <- words stmt    = keepGoing setContext ('+':mod)
 556  | otherwise
 557  = do st <- getGHCiState
 558       session <- getSession
 559       result <- io $ withProgName (progname st) $ withArgs (args st) $
 560                      GHC.runStmt session stmt step
 561       afterRunStmt result
 562
 563
 564 afterRunStmt :: GHC.RunResult -> GHCi Bool
 565                                  -- False <=> the statement failed to compile
 566 afterRunStmt (GHC.RunException e) = throw e
 567 afterRunStmt run_result = do
 568   session <- getSession
 569   case run_result of
 570      GHC.RunOk names -> do
 571         show_types <- isOptionSet ShowType
 572         when show_types $ mapM_ (showTypeOfName session) names
 573      GHC.RunBreak _ names mb_info -> do
 574         resumes <- io $ GHC.getResumeContext session
 575         printForUser $ ptext SLIT("Stopped at") <+>
 576                        ppr (GHC.resumeSpan (head resumes))
 577         mapM_ (showTypeOfName session) names
 578         maybe (return ()) runBreakCmd mb_info
 579         -- run the command set with ":set stop <cmd>"
 580         st <- getGHCiState
 581         enqueueCommands [stop st]
 582         return ()
 583      _ -> return ()
 584
 585   flushInterpBuffers
 586   io installSignalHandlers
 587   b <- isOptionSet RevertCAFs
 588   io (when b revertCAFs)
 589
 590   return (case run_result of GHC.RunOk _ -> True; _ -> False)
 591
 592 runBreakCmd :: GHC.BreakInfo -> GHCi ()
 593 runBreakCmd info = do
 594   let mod = GHC.breakInfo_module info
 595       nm  = GHC.breakInfo_number info
 596   st <- getGHCiState
 597   case  [ loc | (i,loc) <- breaks st,
 598                 breakModule loc == mod, breakTick loc == nm ] of
 599         []  -> return ()
 600         loc:_ | null cmd  -> return ()
 601               | otherwise -> do enqueueCommands [cmd]; return ()
 602               where cmd = onBreakCmd loc
 603
 604 showTypeOfName :: Session -> Name -> GHCi ()
 605 showTypeOfName session n
 606    = do maybe_tything <- io (GHC.lookupName session n)
 607         case maybe_tything of
 608           Nothing    -> return ()
 609           Just thing -> showTyThing thing
 610
 611 specialCommand :: String -> GHCi Bool
 612 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 613 specialCommand str = do
 614   let (cmd,rest) = break isSpace str
 615   maybe_cmd <- io (lookupCommand cmd)
 616   case maybe_cmd of
 617     Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
 618                                     ++ shortHelpText) >> return False)
 619     Just (_,f,_,_) -> f (dropWhile isSpace rest)
 620
 621 lookupCommand :: String -> IO (Maybe Command)
 622 lookupCommand str = do
 623   cmds <- readIORef commands
 624   -- look for exact match first, then the first prefix match
 625   case [ c | c <- cmds, str == cmdName c ] of
 626      c:_ -> return (Just c)
 627      [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
 628                 [] -> return Nothing
 629                 c:_ -> return (Just c)
 630
 631
 632 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
 633 getCurrentBreakSpan = do
 634   session <- getSession
 635   resumes <- io $ GHC.getResumeContext session
 636   case resumes of
 637     [] -> return Nothing
 638     (r:rs) -> do
 639         let ix = GHC.resumeHistoryIx r
 640         if ix == 0
 641            then return (Just (GHC.resumeSpan r))
 642            else do
 643                 let hist = GHC.resumeHistory r !! (ix-1)
 644                 span <- io $ GHC.getHistorySpan session hist
 645                 return (Just span)
 646
 647 -----------------------------------------------------------------------------
 648 -- Commands
 649
 650 noArgs :: GHCi () -> String -> GHCi ()
 651 noArgs m "" = m
 652 noArgs m _ = io $ putStrLn "This command takes no arguments"
 653
 654 help :: String -> GHCi ()
 655 help _ = io (putStr helpText)
 656
 657 info :: String -> GHCi ()
 658 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
 659 info s  = do { let names = words s
 660              ; session <- getSession
 661              ; dflags <- getDynFlags
 662              ; let exts = dopt Opt_GlasgowExts dflags
 663              ; mapM_ (infoThing exts session) names }
 664   where
 665     infoThing exts session str = io $ do
 666         names <- GHC.parseName session str
 667         let filtered = filterOutChildren names
 668         mb_stuffs <- mapM (GHC.getInfo session) filtered
 669         unqual <- GHC.getPrintUnqual session
 670         putStrLn (showSDocForUser unqual $
 671                    vcat (intersperse (text "") $
 672                    [ pprInfo exts stuff | Just stuff <-  mb_stuffs ]))
 673
 674   -- Filter out names whose parent is also there Good
 675   -- example is '[]', which is both a type and data
 676   -- constructor in the same type
 677 filterOutChildren :: [Name] -> [Name]
 678 filterOutChildren names = filter (not . parent_is_there) names
 679  where parent_is_there n
 680 --       | Just p <- GHC.nameParent_maybe n = p `elem` names
 681 -- ToDo!!
 682          | otherwise                       = False
 683
 684 pprInfo exts (thing, fixity, insts)
 685   =  pprTyThingInContextLoc exts thing
 686   $$ show_fixity fixity
 687   $$ vcat (map GHC.pprInstance insts)
 688   where
 689     show_fixity fix
 690         | fix == GHC.defaultFixity = empty
 691         | otherwise                = ppr fix <+> ppr (GHC.getName thing)
 692
 693 runMain :: String -> GHCi ()
 694 runMain args = do
 695   let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
 696   enqueueCommands  ['[': ss ++ "] `System.Environment.withArgs` main"]
 697
 698 addModule :: [FilePath] -> GHCi ()
 699 addModule files = do
 700   io (revertCAFs)                       -- always revert CAFs on load/add.
 701   files <- mapM expandPath files
 702   targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
 703   session <- getSession
 704   io (mapM_ (GHC.addTarget session) targets)
 705   ok <- io (GHC.load session LoadAllTargets)
 706   afterLoad ok session
 707
 708 changeDirectory :: String -> GHCi ()
 709 changeDirectory dir = do
 710   session <- getSession
 711   graph <- io (GHC.getModuleGraph session)
 712   when (not (null graph)) $
 713         io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
 714   io (GHC.setTargets session [])
 715   io (GHC.load session LoadAllTargets)
 716   setContextAfterLoad session []
 717   io (GHC.workingDirectoryChanged session)
 718   dir <- expandPath dir
 719   io (setCurrentDirectory dir)
 720
 721 editFile :: String -> GHCi ()
 722 editFile str =
 723   do file <- if null str then chooseEditFile else return str
 724      st <- getGHCiState
 725      let cmd = editor st
 726      when (null cmd)
 727        $ throwDyn (CmdLineError "editor not set, use :set editor")
 728      io $ system (cmd ++ ' ':file)
 729      return ()
 730
 731 -- The user didn't specify a file so we pick one for them.
 732 -- Our strategy is to pick the first module that failed to load,
 733 -- or otherwise the first target.
 734 --
 735 -- XXX: Can we figure out what happened if the depndecy analysis fails
 736 --      (e.g., because the porgrammeer mistyped the name of a module)?
 737 -- XXX: Can we figure out the location of an error to pass to the editor?
 738 -- XXX: if we could figure out the list of errors that occured during the
 739 -- last load/reaload, then we could start the editor focused on the first
 740 -- of those.
 741 chooseEditFile :: GHCi String
 742 chooseEditFile =
 743   do session <- getSession
 744      let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
 745
 746      graph <- io (GHC.getModuleGraph session)
 747      failed_graph <- filterM hasFailed graph
 748      let order g  = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
 749          pick xs  = case xs of
 750                       x : _ -> GHC.ml_hs_file (GHC.ms_location x)
 751                       _     -> Nothing
 752
 753      case pick (order failed_graph) of
 754        Just file -> return file
 755        Nothing   ->
 756          do targets <- io (GHC.getTargets session)
 757             case msum (map fromTarget targets) of
 758               Just file -> return file
 759               Nothing   -> throwDyn (CmdLineError "No files to edit.")
 760
 761   where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
 762         fromTarget _ = Nothing -- when would we get a module target?
 763
 764 defineMacro :: String -> GHCi ()
 765 defineMacro s = do
 766   let (macro_name, definition) = break isSpace s
 767   cmds <- io (readIORef commands)
 768   if (null macro_name)
 769         then throwDyn (CmdLineError "invalid macro name")
 770         else do
 771   if (macro_name `elem` map cmdName cmds)
 772         then throwDyn (CmdLineError
 773                 ("command '" ++ macro_name ++ "' is already defined"))
 774         else do
 775
 776   -- give the expression a type signature, so we can be sure we're getting
 777   -- something of the right type.
 778   let new_expr = '(' : definition ++ ") :: String -> IO String"
 779
 780   -- compile the expression
 781   cms <- getSession
 782   maybe_hv <- io (GHC.compileExpr cms new_expr)
 783   case maybe_hv of
 784      Nothing -> return ()
 785      Just hv -> io (writeIORef commands --
 786                     (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
 787
 788 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
 789 runMacro fun s = do
 790   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 791   enqueueCommands (lines str)
 792   return False
 793
 794 undefineMacro :: String -> GHCi ()
 795 undefineMacro macro_name = do
 796   cmds <- io (readIORef commands)
 797   if (macro_name `elem` map cmdName builtin_commands)
 798         then throwDyn (CmdLineError
 799                 ("command '" ++ macro_name ++ "' cannot be undefined"))
 800         else do
 801   if (macro_name `notElem` map cmdName cmds)
 802         then throwDyn (CmdLineError
 803                 ("command '" ++ macro_name ++ "' not defined"))
 804         else do
 805   io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
 806
 807 cmdCmd :: String -> GHCi ()
 808 cmdCmd str = do
 809   let expr = '(' : str ++ ") :: IO String"
 810   session <- getSession
 811   maybe_hv <- io (GHC.compileExpr session expr)
 812   case maybe_hv of
 813     Nothing -> return ()
 814     Just hv -> do
 815         cmds <- io $ (unsafeCoerce# hv :: IO String)
 816         enqueueCommands (lines cmds)
 817         return ()
 818
 819 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 820 loadModule fs = timeIt (loadModule' fs)
 821
 822 loadModule_ :: [FilePath] -> GHCi ()
 823 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
 824
 825 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 826 loadModule' files = do
 827   session <- getSession
 828
 829   -- unload first
 830   discardActiveBreakPoints
 831   io (GHC.setTargets session [])
 832   io (GHC.load session LoadAllTargets)
 833
 834   -- expand tildes
 835   let (filenames, phases) = unzip files
 836   exp_filenames <- mapM expandPath filenames
 837   let files' = zip exp_filenames phases
 838   targets <- io (mapM (uncurry GHC.guessTarget) files')
 839
 840   -- NOTE: we used to do the dependency anal first, so that if it
 841   -- fails we didn't throw away the current set of modules.  This would
 842   -- require some re-working of the GHC interface, so we'll leave it
 843   -- as a ToDo for now.
 844
 845   io (GHC.setTargets session targets)
 846   doLoad session LoadAllTargets
 847
 848 checkModule :: String -> GHCi ()
 849 checkModule m = do
 850   let modl = GHC.mkModuleName m
 851   session <- getSession
 852   result <- io (GHC.checkModule session modl)
 853   case result of
 854     Nothing -> io $ putStrLn "Nothing"
 855     Just r  -> io $ putStrLn (showSDoc (
 856         case GHC.checkedModuleInfo r of
 857            Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
 858                 let
 859                     (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
 860                 in
 861                         (text "global names: " <+> ppr global) $$
 862                         (text "local  names: " <+> ppr local)
 863            _ -> empty))
 864   afterLoad (successIf (isJust result)) session
 865
 866 reloadModule :: String -> GHCi ()
 867 reloadModule m = do
 868   io (revertCAFs)               -- always revert CAFs on reload.
 869   discardActiveBreakPoints
 870   session <- getSession
 871   doLoad session $ if null m then LoadAllTargets
 872                              else LoadUpTo (GHC.mkModuleName m)
 873   return ()
 874
 875 doLoad session howmuch = do
 876   -- turn off breakpoints before we load: we can't turn them off later, because
 877   -- the ModBreaks will have gone away.
 878   discardActiveBreakPoints
 879   ok <- io (GHC.load session howmuch)
 880   afterLoad ok session
 881   return ok
 882
 883 afterLoad ok session = do
 884   io (revertCAFs)  -- always revert CAFs on load.
 885   discardTickArrays
 886   graph <- io (GHC.getModuleGraph session)
 887   graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
 888   setContextAfterLoad session graph'
 889   modulesLoadedMsg ok (map GHC.ms_mod_name graph')
 890
 891 setContextAfterLoad session [] = do
 892   prel_mod <- getPrelude
 893   io (GHC.setContext session [] [prel_mod])
 894 setContextAfterLoad session ms = do
 895   -- load a target if one is available, otherwise load the topmost module.
 896   targets <- io (GHC.getTargets session)
 897   case [ m | Just m <- map (findTarget ms) targets ] of
 898         []    ->
 899           let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
 900           load_this (last graph')
 901         (m:_) ->
 902           load_this m
 903  where
 904    findTarget ms t
 905     = case filter (`matches` t) ms of
 906         []    -> Nothing
 907         (m:_) -> Just m
 908
 909    summary `matches` Target (TargetModule m) _
 910         = GHC.ms_mod_name summary == m
 911    summary `matches` Target (TargetFile f _) _
 912         | Just f' <- GHC.ml_hs_file (GHC.ms_location summary)   = f == f'
 913    summary `matches` target
 914         = False
 915
 916    load_this summary | m <- GHC.ms_mod summary = do
 917         b <- io (GHC.moduleIsInterpreted session m)
 918         if b then io (GHC.setContext session [m] [])
 919              else do
 920                    prel_mod <- getPrelude
 921                    io (GHC.setContext session []  [prel_mod,m])
 922
 923
 924 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
 925 modulesLoadedMsg ok mods = do
 926   dflags <- getDynFlags
 927   when (verbosity dflags > 0) $ do
 928    let mod_commas
 929         | null mods = text "none."
 930         | otherwise = hsep (
 931             punctuate comma (map ppr mods)) <> text "."
 932    case ok of
 933     Failed ->
 934        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 935     Succeeded  ->
 936        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 937
 938
 939 typeOfExpr :: String -> GHCi ()
 940 typeOfExpr str
 941   = do cms <- getSession
 942        maybe_ty <- io (GHC.exprType cms str)
 943        case maybe_ty of
 944           Nothing -> return ()
 945           Just ty -> do ty' <- cleanType ty
 946                         printForUser $ text str <> text " :: " <> ppr ty'
 947
 948 kindOfType :: String -> GHCi ()
 949 kindOfType str
 950   = do cms <- getSession
 951        maybe_ty <- io (GHC.typeKind cms str)
 952        case maybe_ty of
 953           Nothing    -> return ()
 954           Just ty    -> printForUser $ text str <> text " :: " <> ppr ty
 955
 956 quit :: String -> GHCi Bool
 957 quit _ = return True
 958
 959 shellEscape :: String -> GHCi Bool
 960 shellEscape str = io (system str >> return False)
 961
 962 -----------------------------------------------------------------------------
 963 -- Browsing a module's contents
 964
 965 browseCmd :: String -> GHCi ()
 966 browseCmd m =
 967   case words m of
 968     ['*':m] | looksLikeModuleName m -> browseModule m False
 969     [m]     | looksLikeModuleName m -> browseModule m True
 970     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 971
 972 browseModule m exports_only = do
 973   s <- getSession
 974   modl <- if exports_only then lookupModule m
 975                           else wantInterpretedModule m
 976
 977   -- Temporarily set the context to the module we're interested in,
 978   -- just so we can get an appropriate PrintUnqualified
 979   (as,bs) <- io (GHC.getContext s)
 980   prel_mod <- getPrelude
 981   io (if exports_only then GHC.setContext s [] [prel_mod,modl]
 982                       else GHC.setContext s [modl] [])
 983   unqual <- io (GHC.getPrintUnqual s)
 984   io (GHC.setContext s as bs)
 985
 986   mb_mod_info <- io $ GHC.getModuleInfo s modl
 987   case mb_mod_info of
 988     Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
 989     Just mod_info -> do
 990         let names
 991                | exports_only = GHC.modInfoExports mod_info
 992                | otherwise    = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
 993
 994             filtered = filterOutChildren names
 995
 996         things <- io $ mapM (GHC.lookupName s) filtered
 997
 998         dflags <- getDynFlags
 999         let exts = dopt Opt_GlasgowExts dflags
1000         io (putStrLn (showSDocForUser unqual (
1001                 vcat (map (pprTyThingInContext exts) (catMaybes things))
1002            )))
1003         -- ToDo: modInfoInstances currently throws an exception for
1004         -- package modules.  When it works, we can do this:
1005         --      $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1006
1007 -----------------------------------------------------------------------------
1008 -- Setting the module context
1009
1010 setContext str
1011   | all sensible mods = fn mods
1012   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
1013   where
1014     (fn, mods) = case str of
1015                         '+':stuff -> (addToContext,      words stuff)
1016                         '-':stuff -> (removeFromContext, words stuff)
1017                         stuff     -> (newContext,        words stuff)
1018
1019     sensible ('*':m) = looksLikeModuleName m
1020     sensible m       = looksLikeModuleName m
1021
1022 separate :: Session -> [String] -> [Module] -> [Module]
1023         -> GHCi ([Module],[Module])
1024 separate session []           as bs = return (as,bs)
1025 separate session (('*':str):ms) as bs = do
1026    m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1027    b <- io $ GHC.moduleIsInterpreted session m
1028    if b then separate session ms (m:as) bs
1029         else throwDyn (CmdLineError ("module '"
1030                         ++ GHC.moduleNameString (GHC.moduleName m)
1031                         ++ "' is not interpreted"))
1032 separate session (str:ms) as bs = do
1033   m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1034   separate session ms as (m:bs)
1035
1036 newContext :: [String] -> GHCi ()
1037 newContext strs = do
1038   s <- getSession
1039   (as,bs) <- separate s strs [] []
1040   prel_mod <- getPrelude
1041   let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1042   io $ GHC.setContext s as bs'
1043
1044
1045 addToContext :: [String] -> GHCi ()
1046 addToContext strs = do
1047   s <- getSession
1048   (as,bs) <- io $ GHC.getContext s
1049
1050   (new_as,new_bs) <- separate s strs [] []
1051
1052   let as_to_add = new_as \\ (as ++ bs)
1053       bs_to_add = new_bs \\ (as ++ bs)
1054
1055   io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1056
1057
1058 removeFromContext :: [String] -> GHCi ()
1059 removeFromContext strs = do
1060   s <- getSession
1061   (as,bs) <- io $ GHC.getContext s
1062
1063   (as_to_remove,bs_to_remove) <- separate s strs [] []
1064
1065   let as' = as \\ (as_to_remove ++ bs_to_remove)
1066       bs' = bs \\ (as_to_remove ++ bs_to_remove)
1067
1068   io $ GHC.setContext s as' bs'
1069
1070 ----------------------------------------------------------------------------
1071 -- Code for `:set'
1072
1073 -- set options in the interpreter.  Syntax is exactly the same as the
1074 -- ghc command line, except that certain options aren't available (-C,
1075 -- -E etc.)
1076 --
1077 -- This is pretty fragile: most options won't work as expected.  ToDo:
1078 -- figure out which ones & disallow them.
1079
1080 setCmd :: String -> GHCi ()
1081 setCmd ""
1082   = do st <- getGHCiState
1083        let opts = options st
1084        io $ putStrLn (showSDoc (
1085               text "options currently set: " <>
1086               if null opts
1087                    then text "none."
1088                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1089            ))
1090 setCmd str
1091   = case toArgs str of
1092         ("args":args) -> setArgs args
1093         ("prog":prog) -> setProg prog
1094         ("prompt":prompt) -> setPrompt (after 6)
1095         ("editor":cmd) -> setEditor (after 6)
1096         ("stop":cmd) -> setStop (after 4)
1097         wds -> setOptions wds
1098    where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1099
1100 setArgs args = do
1101   st <- getGHCiState
1102   setGHCiState st{ args = args }
1103
1104 setProg [prog] = do
1105   st <- getGHCiState
1106   setGHCiState st{ progname = prog }
1107 setProg _ = do
1108   io (hPutStrLn stderr "syntax: :set prog <progname>")
1109
1110 setEditor cmd = do
1111   st <- getGHCiState
1112   setGHCiState st{ editor = cmd }
1113
1114 setStop str@(c:_) | isDigit c
1115   = do let (nm_str,rest) = break (not.isDigit) str
1116            nm = read nm_str
1117        st <- getGHCiState
1118        let old_breaks = breaks st
1119        if all ((/= nm) . fst) old_breaks
1120               then printForUser (text "Breakpoint" <+> ppr nm <+>
1121                                  text "does not exist")
1122               else do
1123        let new_breaks = map fn old_breaks
1124            fn (i,loc) | i == nm   = (i,loc { onBreakCmd = dropWhile isSpace rest })
1125                       | otherwise = (i,loc)
1126        setGHCiState st{ breaks = new_breaks }
1127 setStop cmd = do
1128   st <- getGHCiState
1129   setGHCiState st{ stop = cmd }
1130
1131 setPrompt value = do
1132   st <- getGHCiState
1133   if null value
1134       then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1135       else setGHCiState st{ prompt = remQuotes value }
1136   where
1137      remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1138      remQuotes x = x
1139
1140 setOptions wds =
1141    do -- first, deal with the GHCi opts (+s, +t, etc.)
1142       let (plus_opts, minus_opts)  = partition isPlus wds
1143       mapM_ setOpt plus_opts
1144       -- then, dynamic flags
1145       newDynFlags minus_opts
1146
1147 newDynFlags minus_opts = do
1148       dflags <- getDynFlags
1149       let pkg_flags = packageFlags dflags
1150       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1151
1152       if (not (null leftovers))
1153                 then throwDyn (CmdLineError ("unrecognised flags: " ++
1154                                                 unwords leftovers))
1155                 else return ()
1156
1157       new_pkgs <- setDynFlags dflags'
1158
1159       -- if the package flags changed, we should reset the context
1160       -- and link the new packages.
1161       dflags <- getDynFlags
1162       when (packageFlags dflags /= pkg_flags) $ do
1163         io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1164         session <- getSession
1165         io (GHC.setTargets session [])
1166         io (GHC.load session LoadAllTargets)
1167         io (linkPackages dflags new_pkgs)
1168         setContextAfterLoad session []
1169       return ()
1170
1171
1172 unsetOptions :: String -> GHCi ()
1173 unsetOptions str
1174   = do -- first, deal with the GHCi opts (+s, +t, etc.)
1175        let opts = words str
1176            (minus_opts, rest1) = partition isMinus opts
1177            (plus_opts, rest2)  = partition isPlus rest1
1178
1179        if (not (null rest2))
1180           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1181           else do
1182
1183        mapM_ unsetOpt plus_opts
1184
1185        let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1186            no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1187
1188        no_flags <- mapM no_flag minus_opts
1189        newDynFlags no_flags
1190
1191 isMinus ('-':s) = True
1192 isMinus _ = False
1193
1194 isPlus ('+':s) = True
1195 isPlus _ = False
1196
1197 setOpt ('+':str)
1198   = case strToGHCiOpt str of
1199         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1200         Just o  -> setOption o
1201
1202 unsetOpt ('+':str)
1203   = case strToGHCiOpt str of
1204         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1205         Just o  -> unsetOption o
1206
1207 strToGHCiOpt :: String -> (Maybe GHCiOption)
1208 strToGHCiOpt "s" = Just ShowTiming
1209 strToGHCiOpt "t" = Just ShowType
1210 strToGHCiOpt "r" = Just RevertCAFs
1211 strToGHCiOpt _   = Nothing
1212
1213 optToStr :: GHCiOption -> String
1214 optToStr ShowTiming = "s"
1215 optToStr ShowType   = "t"
1216 optToStr RevertCAFs = "r"
1217
1218 -- ---------------------------------------------------------------------------
1219 -- code for `:show'
1220
1221 showCmd str = do
1222   st <- getGHCiState
1223   case words str of
1224         ["args"]     -> io $ putStrLn (show (args st))
1225         ["prog"]     -> io $ putStrLn (show (progname st))
1226         ["prompt"]   -> io $ putStrLn (show (prompt st))
1227         ["editor"]   -> io $ putStrLn (show (editor st))
1228         ["stop"]     -> io $ putStrLn (show (stop st))
1229         ["modules" ] -> showModules
1230         ["bindings"] -> showBindings
1231         ["linker"]   -> io showLinkerState
1232         ["breaks"]   -> showBkptTable
1233         ["context"]  -> showContext
1234         _ -> throwDyn (CmdLineError "syntax:  :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1235
1236 showModules = do
1237   session <- getSession
1238   let show_one ms = do m <- io (GHC.showModule session ms)
1239                        io (putStrLn m)
1240   graph <- io (GHC.getModuleGraph session)
1241   mapM_ show_one graph
1242
1243 showBindings = do
1244   s <- getSession
1245   unqual <- io (GHC.getPrintUnqual s)
1246   bindings <- io (GHC.getBindings s)
1247   mapM_ showTyThing bindings
1248   return ()
1249
1250 showTyThing (AnId id) = do
1251   ty' <- cleanType (GHC.idType id)
1252   printForUser $ ppr id <> text " :: " <> ppr ty'
1253 showTyThing _  = return ()
1254
1255 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1256 cleanType :: Type -> GHCi Type
1257 cleanType ty = do
1258   dflags <- getDynFlags
1259   if dopt Opt_GlasgowExts dflags
1260         then return ty
1261         else return $! GHC.dropForAlls ty
1262
1263 showBkptTable :: GHCi ()
1264 showBkptTable = do
1265   st <- getGHCiState
1266   printForUser $ prettyLocations (breaks st)
1267
1268 showContext :: GHCi ()
1269 showContext = do
1270    session <- getSession
1271    resumes <- io $ GHC.getResumeContext session
1272    printForUser $ vcat (map pp_resume (reverse resumes))
1273   where
1274    pp_resume resume =
1275         ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1276         $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1277
1278
1279 -- -----------------------------------------------------------------------------
1280 -- Completion
1281
1282 completeNone :: String -> IO [String]
1283 completeNone w = return []
1284
1285 #ifdef USE_READLINE
1286 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1287 completeWord w start end = do
1288   line <- Readline.getLineBuffer
1289   case w of
1290      ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1291      _other
1292         | Just c <- is_cmd line -> do
1293            maybe_cmd <- lookupCommand c
1294            let (n,w') = selectWord (words' 0 line)
1295            case maybe_cmd of
1296              Nothing -> return Nothing
1297              Just (_,_,False,complete) -> wrapCompleter complete w
1298              Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1299                                                               return (map (drop n) rets)
1300                                          in wrapCompleter complete' w'
1301         | otherwise     -> do
1302                 --printf "complete %s, start = %d, end = %d\n" w start end
1303                 wrapCompleter completeIdentifier w
1304     where words' _ [] = []
1305           words' n str = let (w,r) = break isSpace str
1306                              (s,r') = span isSpace r
1307                          in (n,w):words' (n+length w+length s) r'
1308           -- In a Haskell expression we want to parse 'a-b' as three words
1309           -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1310           -- only be a single word.
1311           selectWord [] = (0,w)
1312           selectWord ((offset,x):xs)
1313               | offset+length x >= start = (start-offset,take (end-offset) x)
1314               | otherwise = selectWord xs
1315
1316 is_cmd line
1317  | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1318  | otherwise = Nothing
1319
1320 completeCmd w = do
1321   cmds <- readIORef commands
1322   return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1323
1324 completeMacro w = do
1325   cmds <- readIORef commands
1326   let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1327   return (filter (w `isPrefixOf`) cmds')
1328
1329 completeIdentifier w = do
1330   s <- restoreSession
1331   rdrs <- GHC.getRdrNamesInScope s
1332   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1333
1334 completeModule w = do
1335   s <- restoreSession
1336   dflags <- GHC.getSessionDynFlags s
1337   let pkg_mods = allExposedModules dflags
1338   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1339
1340 completeHomeModule w = do
1341   s <- restoreSession
1342   g <- GHC.getModuleGraph s
1343   let home_mods = map GHC.ms_mod_name g
1344   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1345
1346 completeSetOptions w = do
1347   return (filter (w `isPrefixOf`) options)
1348     where options = "args":"prog":allFlags
1349
1350 completeFilename = Readline.filenameCompletionFunction
1351
1352 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1353
1354 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1355 unionComplete f1 f2 w = do
1356   s1 <- f1 w
1357   s2 <- f2 w
1358   return (s1 ++ s2)
1359
1360 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1361 wrapCompleter fun w =  do
1362   strs <- fun w
1363   case strs of
1364     []  -> return Nothing
1365     [x] -> return (Just (x,[]))
1366     xs  -> case getCommonPrefix xs of
1367                 ""   -> return (Just ("",xs))
1368                 pref -> return (Just (pref,xs))
1369
1370 getCommonPrefix :: [String] -> String
1371 getCommonPrefix [] = ""
1372 getCommonPrefix (s:ss) = foldl common s ss
1373   where common s "" = ""
1374         common "" s = ""
1375         common (c:cs) (d:ds)
1376            | c == d = c : common cs ds
1377            | otherwise = ""
1378
1379 allExposedModules :: DynFlags -> [ModuleName]
1380 allExposedModules dflags
1381  = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1382  where
1383   pkg_db = pkgIdMap (pkgState dflags)
1384 #else
1385 completeCmd        = completeNone
1386 completeMacro      = completeNone
1387 completeIdentifier = completeNone
1388 completeModule     = completeNone
1389 completeHomeModule = completeNone
1390 completeSetOptions = completeNone
1391 completeFilename   = completeNone
1392 completeHomeModuleOrFile=completeNone
1393 completeBkpt       = completeNone
1394 #endif
1395
1396 -- ---------------------------------------------------------------------------
1397 -- User code exception handling
1398
1399 -- This is the exception handler for exceptions generated by the
1400 -- user's code and exceptions coming from children sessions;
1401 -- it normally just prints out the exception.  The
1402 -- handler must be recursive, in case showing the exception causes
1403 -- more exceptions to be raised.
1404 --
1405 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1406 -- raising another exception.  We therefore don't put the recursive
1407 -- handler arond the flushing operation, so if stderr is closed
1408 -- GHCi will just die gracefully rather than going into an infinite loop.
1409 handler :: Exception -> GHCi Bool
1410
1411 handler exception = do
1412   flushInterpBuffers
1413   io installSignalHandlers
1414   ghciHandle handler (showException exception >> return False)
1415
1416 showException (DynException dyn) =
1417   case fromDynamic dyn of
1418     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
1419     Just Interrupted      -> io (putStrLn "Interrupted.")
1420     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
1421     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1422     Just other_ghc_ex     -> io (print other_ghc_ex)
1423
1424 showException other_exception
1425   = io (putStrLn ("*** Exception: " ++ show other_exception))
1426
1427 -----------------------------------------------------------------------------
1428 -- recursive exception handlers
1429
1430 -- Don't forget to unblock async exceptions in the handler, or if we're
1431 -- in an exception loop (eg. let a = error a in a) the ^C exception
1432 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1433
1434 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1435 ghciHandle h (GHCi m) = GHCi $ \s ->
1436    Exception.catch (m s)
1437         (\e -> unGHCi (ghciUnblock (h e)) s)
1438
1439 ghciUnblock :: GHCi a -> GHCi a
1440 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1441
1442
1443 -- ----------------------------------------------------------------------------
1444 -- Utils
1445
1446 expandPath :: String -> GHCi String
1447 expandPath path =
1448   case dropWhile isSpace path of
1449    ('~':d) -> do
1450         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1451         return (tilde ++ '/':d)
1452    other ->
1453         return other
1454
1455 wantInterpretedModule :: String -> GHCi Module
1456 wantInterpretedModule str = do
1457    session <- getSession
1458    modl <- lookupModule str
1459    is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1460    when (not is_interpreted) $
1461        throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1462    return modl
1463
1464 wantNameFromInterpretedModule noCanDo str and_then = do
1465    session <- getSession
1466    names <- io $ GHC.parseName session str
1467    case names of
1468       []    -> return ()
1469       (n:_) -> do
1470             let modl = GHC.nameModule n
1471             if not (GHC.isExternalName n)
1472                then noCanDo n $ ppr n <>
1473                                 text " is not defined in an interpreted module"
1474                else do
1475             is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1476             if not is_interpreted
1477                then noCanDo n $ text "module " <> ppr modl <>
1478                                 text " is not interpreted"
1479                else and_then n
1480
1481 -- ----------------------------------------------------------------------------
1482 -- Windows console setup
1483
1484 setUpConsole :: IO ()
1485 setUpConsole = do
1486 #ifdef mingw32_HOST_OS
1487         -- On Windows we need to set a known code page, otherwise the characters
1488         -- we read from the console will be be in some strange encoding, and
1489         -- similarly for characters we write to the console.
1490         --
1491         -- At the moment, GHCi pretends all input is Latin-1.  In the
1492         -- future we should support UTF-8, but for now we set the code pages
1493         -- to Latin-1.
1494         --
1495         -- It seems you have to set the font in the console window to
1496         -- a Unicode font in order for output to work properly,
1497         -- otherwise non-ASCII characters are mapped wrongly.  sigh.
1498         -- (see MSDN for SetConsoleOutputCP()).
1499         --
1500         setConsoleCP 28591       -- ISO Latin-1
1501         setConsoleOutputCP 28591 -- ISO Latin-1
1502 #endif
1503         return ()
1504
1505 -- -----------------------------------------------------------------------------
1506 -- commands for debugger
1507
1508 sprintCmd = pprintCommand False False
1509 printCmd  = pprintCommand True False
1510 forceCmd  = pprintCommand False True
1511
1512 pprintCommand bind force str = do
1513   session <- getSession
1514   io $ pprintClosureCommand session bind force str
1515
1516 stepCmd :: String -> GHCi ()
1517 stepCmd []         = doContinue GHC.SingleStep
1518 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1519
1520 traceCmd :: String -> GHCi ()
1521 traceCmd []         = doContinue GHC.RunAndLogSteps
1522 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1523
1524 continueCmd :: String -> GHCi ()
1525 continueCmd = noArgs $ doContinue GHC.RunToCompletion
1526
1527 doContinue :: SingleStep -> GHCi ()
1528 doContinue step = do
1529   session <- getSession
1530   runResult <- io $ GHC.resume session step
1531   afterRunStmt runResult
1532   return ()
1533
1534 abandonCmd :: String -> GHCi ()
1535 abandonCmd = noArgs $ do
1536   s <- getSession
1537   b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1538   when (not b) $ io $ putStrLn "There is no computation running."
1539   return ()
1540
1541 deleteCmd :: String -> GHCi ()
1542 deleteCmd argLine = do
1543    deleteSwitch $ words argLine
1544    where
1545    deleteSwitch :: [String] -> GHCi ()
1546    deleteSwitch [] =
1547       io $ putStrLn "The delete command requires at least one argument."
1548    -- delete all break points
1549    deleteSwitch ("*":_rest) = discardActiveBreakPoints
1550    deleteSwitch idents = do
1551       mapM_ deleteOneBreak idents
1552       where
1553       deleteOneBreak :: String -> GHCi ()
1554       deleteOneBreak str
1555          | all isDigit str = deleteBreak (read str)
1556          | otherwise = return ()
1557
1558 historyCmd :: String -> GHCi ()
1559 historyCmd arg
1560   | null arg        = history 20
1561   | all isDigit arg = history (read arg)
1562   | otherwise       = io $ putStrLn "Syntax:  :history [num]"
1563   where
1564   history num = do
1565     s <- getSession
1566     resumes <- io $ GHC.getResumeContext s
1567     case resumes of
1568       [] -> io $ putStrLn "Not stopped at a breakpoint"
1569       (r:rs) -> do
1570         let hist = GHC.resumeHistory r
1571             (took,rest) = splitAt num hist
1572         spans <- mapM (io . GHC.getHistorySpan s) took
1573         let nums = map (printf "-%-3d:") [(1::Int)..]
1574         printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans)))
1575         io $ putStrLn $ if null rest then "<end of history>" else "..."
1576
1577 backCmd :: String -> GHCi ()
1578 backCmd = noArgs $ do
1579   s <- getSession
1580   (names, ix, span) <- io $ GHC.back s
1581   printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1582   mapM_ (showTypeOfName s) names
1583    -- run the command set with ":set stop <cmd>"
1584   st <- getGHCiState
1585   enqueueCommands [stop st]
1586
1587 forwardCmd :: String -> GHCi ()
1588 forwardCmd = noArgs $ do
1589   s <- getSession
1590   (names, ix, span) <- io $ GHC.forward s
1591   printForUser $ (if (ix == 0)
1592                     then ptext SLIT("Stopped at")
1593                     else ptext SLIT("Logged breakpoint at")) <+> ppr span
1594   mapM_ (showTypeOfName s) names
1595    -- run the command set with ":set stop <cmd>"
1596   st <- getGHCiState
1597   enqueueCommands [stop st]
1598
1599 -- handle the "break" command
1600 breakCmd :: String -> GHCi ()
1601 breakCmd argLine = do
1602    session <- getSession
1603    breakSwitch session $ words argLine
1604
1605 breakSwitch :: Session -> [String] -> GHCi ()
1606 breakSwitch _session [] = do
1607    io $ putStrLn "The break command requires at least one argument."
1608 breakSwitch session args@(arg1:rest)
1609    | looksLikeModuleName arg1 = do
1610         mod <- wantInterpretedModule arg1
1611         breakByModule session mod rest
1612    | all isDigit arg1 = do
1613         (toplevel, _) <- io $ GHC.getContext session
1614         case toplevel of
1615            (mod : _) -> breakByModuleLine mod (read arg1) rest
1616            [] -> do
1617               io $ putStrLn "Cannot find default module for breakpoint."
1618               io $ putStrLn "Perhaps no modules are loaded for debugging?"
1619    | otherwise = do -- try parsing it as an identifier
1620         wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1621         let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1622         if GHC.isGoodSrcLoc loc
1623                then findBreakAndSet (GHC.nameModule name) $
1624                          findBreakByCoord (Just (GHC.srcLocFile loc))
1625                                           (GHC.srcLocLine loc,
1626                                            GHC.srcLocCol loc)
1627                else noCanDo name $ text "can't find its location: " <> ppr loc
1628        where
1629           noCanDo n why = printForUser $
1630                 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1631
1632 breakByModule :: Session -> Module -> [String] -> GHCi ()
1633 breakByModule session mod args@(arg1:rest)
1634    | all isDigit arg1 = do  -- looks like a line number
1635         breakByModuleLine mod (read arg1) rest
1636    | otherwise = io $ putStrLn "Invalid arguments to :break"
1637
1638 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1639 breakByModuleLine mod line args
1640    | [] <- args = findBreakAndSet mod $ findBreakByLine line
1641    | [col] <- args, all isDigit col =
1642         findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1643    | otherwise = io $ putStrLn "Invalid arguments to :break"
1644
1645 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1646 findBreakAndSet mod lookupTickTree = do
1647    tickArray <- getTickArray mod
1648    (breakArray, _) <- getModBreak mod
1649    case lookupTickTree tickArray of
1650       Nothing  -> io $ putStrLn $ "No breakpoints found at that location."
1651       Just (tick, span) -> do
1652          success <- io $ setBreakFlag True breakArray tick
1653          session <- getSession
1654          if success
1655             then do
1656                (alreadySet, nm) <-
1657                      recordBreak $ BreakLocation
1658                              { breakModule = mod
1659                              , breakLoc = span
1660                              , breakTick = tick
1661                              , onBreakCmd = ""
1662                              }
1663                printForUser $
1664                   text "Breakpoint " <> ppr nm <>
1665                   if alreadySet
1666                      then text " was already set at " <> ppr span
1667                      else text " activated at " <> ppr span
1668             else do
1669             printForUser $ text "Breakpoint could not be activated at"
1670                                  <+> ppr span
1671
1672 -- When a line number is specified, the current policy for choosing
1673 -- the best breakpoint is this:
1674 --    - the leftmost complete subexpression on the specified line, or
1675 --    - the leftmost subexpression starting on the specified line, or
1676 --    - the rightmost subexpression enclosing the specified line
1677 --
1678 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1679 findBreakByLine line arr
1680   | not (inRange (bounds arr) line) = Nothing
1681   | otherwise =
1682     listToMaybe (sortBy leftmost_largest  complete)   `mplus`
1683     listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1684     listToMaybe (sortBy rightmost ticks)
1685   where
1686         ticks = arr ! line
1687
1688         starts_here = [ tick | tick@(nm,span) <- ticks,
1689                                GHC.srcSpanStartLine span == line ]
1690
1691         (complete,incomplete) = partition ends_here starts_here
1692             where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1693
1694 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1695                  -> Maybe (BreakIndex,SrcSpan)
1696 findBreakByCoord mb_file (line, col) arr
1697   | not (inRange (bounds arr) line) = Nothing
1698   | otherwise =
1699     listToMaybe (sortBy rightmost contains) `mplus`
1700     listToMaybe (sortBy leftmost_smallest after_here)
1701   where
1702         ticks = arr ! line
1703
1704         -- the ticks that span this coordinate
1705         contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1706                             is_correct_file span ]
1707
1708         is_correct_file span
1709                  | Just f <- mb_file = GHC.srcSpanFile span == f
1710                  | otherwise         = True
1711
1712         after_here = [ tick | tick@(nm,span) <- ticks,
1713                               GHC.srcSpanStartLine span == line,
1714                               GHC.srcSpanStartCol span >= col ]
1715
1716
1717 leftmost_smallest  (_,a) (_,b) = a `compare` b
1718 leftmost_largest   (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1719                                 `thenCmp`
1720                                  (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1721 rightmost (_,a) (_,b) = b `compare` a
1722
1723 spans :: SrcSpan -> (Int,Int) -> Bool
1724 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1725    where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1726
1727 -- for now, use ANSI bold on Unixy systems.  On Windows, we add a line
1728 -- of carets under the active expression instead.  The Windows console
1729 -- doesn't support ANSI escape sequences, and most Unix terminals
1730 -- (including xterm) do, so this is a reasonable guess until we have a
1731 -- proper termcap/terminfo library.
1732 #if !defined(mingw32_TARGET_OS)
1733 do_bold = True
1734 #else
1735 do_bold = False
1736 #endif
1737
1738 start_bold = BS.pack "\ESC[1m"
1739 end_bold   = BS.pack "\ESC[0m"
1740
1741 listCmd :: String -> GHCi ()
1742 listCmd "" = do
1743    mb_span <- getCurrentBreakSpan
1744    case mb_span of
1745       Nothing  -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1746       Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1747                 | otherwise              -> printForUser $ text "unable to list source for" <+> ppr span
1748 listCmd str = list2 (words str)
1749
1750 list2 [arg] | all isDigit arg = do
1751     session <- getSession
1752     (toplevel, _) <- io $ GHC.getContext session
1753     case toplevel of
1754         [] -> io $ putStrLn "No module to list"
1755         (mod : _) -> listModuleLine mod (read arg)
1756 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1757         mod <- wantInterpretedModule arg1
1758         listModuleLine mod (read arg2)
1759 list2 [arg] = do
1760         wantNameFromInterpretedModule noCanDo arg $ \name -> do
1761         let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1762         if GHC.isGoodSrcLoc loc
1763                then do
1764                   tickArray <- getTickArray (GHC.nameModule name)
1765                   let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1766                                         (GHC.srcLocLine loc, GHC.srcLocCol loc)
1767                                         tickArray
1768                   case mb_span of
1769                     Nothing       -> io $ listAround (GHC.srcLocSpan loc) False
1770                     Just (_,span) -> io $ listAround span False
1771                else
1772                   noCanDo name $ text "can't find its location: " <>
1773                                  ppr loc
1774     where
1775         noCanDo n why = printForUser $
1776             text "cannot list source code for " <> ppr n <> text ": " <> why
1777 list2  _other =
1778         io $ putStrLn "syntax:  :list [<line> | <module> <line> | <identifier>]"
1779
1780 listModuleLine :: Module -> Int -> GHCi ()
1781 listModuleLine modl line = do
1782    session <- getSession
1783    graph <- io (GHC.getModuleGraph session)
1784    let this = filter ((== modl) . GHC.ms_mod) graph
1785    case this of
1786      [] -> panic "listModuleLine"
1787      summ:_ -> do
1788            let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1789                loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1790            io $ listAround (GHC.srcLocSpan loc) False
1791
1792 -- | list a section of a source file around a particular SrcSpan.
1793 -- If the highlight flag is True, also highlight the span using
1794 -- start_bold/end_bold.
1795 listAround span do_highlight = do
1796       pwd      <- getEnv "PWD"
1797       contents <- BS.readFile (pwd `joinFileName` unpackFS file)
1798       let
1799           lines = BS.split '\n' contents
1800           these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1801                         drop (line1 - 1 - pad_before) $ lines
1802           fst_line = max 1 (line1 - pad_before)
1803           line_nos = [ fst_line .. ]
1804
1805           highlighted | do_highlight = zipWith highlight line_nos these_lines
1806                       | otherwise   = these_lines
1807
1808           bs_line_nos = [ BS.pack (show l ++ "  ") | l <- line_nos ]
1809           prefixed = zipWith BS.append bs_line_nos highlighted
1810       --
1811       BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1812   where
1813         file  = GHC.srcSpanFile span
1814         line1 = GHC.srcSpanStartLine span
1815         col1  = GHC.srcSpanStartCol span
1816         line2 = GHC.srcSpanEndLine span
1817         col2  = GHC.srcSpanEndCol span
1818
1819         pad_before | line1 == 1 = 0
1820                    | otherwise  = 1
1821         pad_after = 1
1822
1823         highlight | do_bold   = highlight_bold
1824                   | otherwise = highlight_carets
1825
1826         highlight_bold no line
1827           | no == line1 && no == line2
1828           = let (a,r) = BS.splitAt col1 line
1829                 (b,c) = BS.splitAt (col2-col1) r
1830             in
1831             BS.concat [a,start_bold,b,end_bold,c]
1832           | no == line1
1833           = let (a,b) = BS.splitAt col1 line in
1834             BS.concat [a, start_bold, b]
1835           | no == line2
1836           = let (a,b) = BS.splitAt col2 line in
1837             BS.concat [a, end_bold, b]
1838           | otherwise   = line
1839
1840         highlight_carets no line
1841           | no == line1 && no == line2
1842           = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1843                                          BS.replicate (col2-col1) '^']
1844           | no == line1
1845           = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1846                                          BS.replicate (BS.length line-col1) '^']
1847           | no == line2
1848           = BS.concat [line, nl, indent, BS.replicate col2 '^']
1849           | otherwise   = line
1850          where
1851            indent = BS.pack "   "
1852            nl = BS.singleton '\n'
1853
1854 -- --------------------------------------------------------------------------
1855 -- Tick arrays
1856
1857 getTickArray :: Module -> GHCi TickArray
1858 getTickArray modl = do
1859    st <- getGHCiState
1860    let arrmap = tickarrays st
1861    case lookupModuleEnv arrmap modl of
1862       Just arr -> return arr
1863       Nothing  -> do
1864         (breakArray, ticks) <- getModBreak modl
1865         let arr = mkTickArray (assocs ticks)
1866         setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1867         return arr
1868
1869 discardTickArrays :: GHCi ()
1870 discardTickArrays = do
1871    st <- getGHCiState
1872    setGHCiState st{tickarrays = emptyModuleEnv}
1873
1874 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1875 mkTickArray ticks
1876   = accumArray (flip (:)) [] (1, max_line)
1877         [ (line, (nm,span)) | (nm,span) <- ticks,
1878                               line <- srcSpanLines span ]
1879     where
1880         max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1881         srcSpanLines span = [ GHC.srcSpanStartLine span ..
1882                               GHC.srcSpanEndLine span ]
1883
1884 lookupModule :: String -> GHCi Module
1885 lookupModule modName
1886    = do session <- getSession
1887         io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1888
1889 -- don't reset the counter back to zero?
1890 discardActiveBreakPoints :: GHCi ()
1891 discardActiveBreakPoints = do
1892    st <- getGHCiState
1893    mapM (turnOffBreak.snd) (breaks st)
1894    setGHCiState $ st { breaks = [] }
1895
1896 deleteBreak :: Int -> GHCi ()
1897 deleteBreak identity = do
1898    st <- getGHCiState
1899    let oldLocations    = breaks st
1900        (this,rest)     = partition (\loc -> fst loc == identity) oldLocations
1901    if null this
1902       then printForUser (text "Breakpoint" <+> ppr identity <+>
1903                          text "does not exist")
1904       else do
1905            mapM (turnOffBreak.snd) this
1906            setGHCiState $ st { breaks = rest }
1907
1908 turnOffBreak loc = do
1909   (arr, _) <- getModBreak (breakModule loc)
1910   io $ setBreakFlag False arr (breakTick loc)
1911
1912 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1913 getModBreak mod = do
1914    session <- getSession
1915    Just mod_info <- io $ GHC.getModuleInfo session mod
1916    let modBreaks  = GHC.modInfoModBreaks mod_info
1917    let array      = GHC.modBreaks_flags modBreaks
1918    let ticks      = GHC.modBreaks_locs  modBreaks
1919    return (array, ticks)
1920
1921 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1922 setBreakFlag toggle array index
1923    | toggle    = GHC.setBreakOn array index
1924    | otherwise = GHC.setBreakOff array index
1925