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