compiler/ghci/InteractiveUI.hs

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