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