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