compiler/ghci/InteractiveUI.hs

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