compiler/ghci/InteractiveUI.hs

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