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