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