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