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