compiler/ghci/InteractiveUI.hs

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