compiler/ghci/InteractiveUI.hs

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