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",  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",      stepCmd,                        False, completeIdentifier),
 136   ("type",      keepGoing typeOfExpr,           False, completeIdentifier),
 137   ("trace",     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   io (GHC.setTargets session [])
 798   io (GHC.load session LoadAllTargets)
 799
 800   -- expand tildes
 801   let (filenames, phases) = unzip files
 802   exp_filenames <- mapM expandPath filenames
 803   let files' = zip exp_filenames phases
 804   targets <- io (mapM (uncurry GHC.guessTarget) files')
 805
 806   -- NOTE: we used to do the dependency anal first, so that if it
 807   -- fails we didn't throw away the current set of modules.  This would
 808   -- require some re-working of the GHC interface, so we'll leave it
 809   -- as a ToDo for now.
 810
 811   io (GHC.setTargets session targets)
 812   ok <- io (GHC.load session LoadAllTargets)
 813   afterLoad ok session
 814   return ok
 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   session <- getSession
 838   ok <- io (GHC.load session LoadAllTargets)
 839   afterLoad ok session
 840 reloadModule m = do
 841   io (revertCAFs)               -- always revert CAFs on reload.
 842   session <- getSession
 843   ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
 844   afterLoad ok session
 845
 846 afterLoad ok session = do
 847   io (revertCAFs)  -- always revert CAFs on load.
 848   discardTickArrays
 849   discardActiveBreakPoints
 850   graph <- io (GHC.getModuleGraph session)
 851   graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
 852   setContextAfterLoad session graph'
 853   modulesLoadedMsg ok (map GHC.ms_mod_name graph')
 854
 855 setContextAfterLoad session [] = do
 856   prel_mod <- getPrelude
 857   io (GHC.setContext session [] [prel_mod])
 858 setContextAfterLoad session ms = do
 859   -- load a target if one is available, otherwise load the topmost module.
 860   targets <- io (GHC.getTargets session)
 861   case [ m | Just m <- map (findTarget ms) targets ] of
 862         []    ->
 863           let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
 864           load_this (last graph')
 865         (m:_) ->
 866           load_this m
 867  where
 868    findTarget ms t
 869     = case filter (`matches` t) ms of
 870         []    -> Nothing
 871         (m:_) -> Just m
 872
 873    summary `matches` Target (TargetModule m) _
 874         = GHC.ms_mod_name summary == m
 875    summary `matches` Target (TargetFile f _) _
 876         | Just f' <- GHC.ml_hs_file (GHC.ms_location summary)   = f == f'
 877    summary `matches` target
 878         = False
 879
 880    load_this summary | m <- GHC.ms_mod summary = do
 881         b <- io (GHC.moduleIsInterpreted session m)
 882         if b then io (GHC.setContext session [m] [])
 883              else do
 884                    prel_mod <- getPrelude
 885                    io (GHC.setContext session []  [prel_mod,m])
 886
 887
 888 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
 889 modulesLoadedMsg ok mods = do
 890   dflags <- getDynFlags
 891   when (verbosity dflags > 0) $ do
 892    let mod_commas
 893         | null mods = text "none."
 894         | otherwise = hsep (
 895             punctuate comma (map ppr mods)) <> text "."
 896    case ok of
 897     Failed ->
 898        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 899     Succeeded  ->
 900        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 901
 902
 903 typeOfExpr :: String -> GHCi ()
 904 typeOfExpr str
 905   = do cms <- getSession
 906        maybe_ty <- io (GHC.exprType cms str)
 907        case maybe_ty of
 908           Nothing -> return ()
 909           Just ty -> do ty' <- cleanType ty
 910                         printForUser $ text str <> text " :: " <> ppr ty'
 911
 912 kindOfType :: String -> GHCi ()
 913 kindOfType str
 914   = do cms <- getSession
 915        maybe_ty <- io (GHC.typeKind cms str)
 916        case maybe_ty of
 917           Nothing    -> return ()
 918           Just ty    -> printForUser $ text str <> text " :: " <> ppr ty
 919
 920 quit :: String -> GHCi Bool
 921 quit _ = return True
 922
 923 shellEscape :: String -> GHCi Bool
 924 shellEscape str = io (system str >> return False)
 925
 926 -----------------------------------------------------------------------------
 927 -- Browsing a module's contents
 928
 929 browseCmd :: String -> GHCi ()
 930 browseCmd m =
 931   case words m of
 932     ['*':m] | looksLikeModuleName m -> browseModule m False
 933     [m]     | looksLikeModuleName m -> browseModule m True
 934     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 935
 936 browseModule m exports_only = do
 937   s <- getSession
 938   modl <- if exports_only then lookupModule m
 939                           else wantInterpretedModule m
 940
 941   -- Temporarily set the context to the module we're interested in,
 942   -- just so we can get an appropriate PrintUnqualified
 943   (as,bs) <- io (GHC.getContext s)
 944   prel_mod <- getPrelude
 945   io (if exports_only then GHC.setContext s [] [prel_mod,modl]
 946                       else GHC.setContext s [modl] [])
 947   unqual <- io (GHC.getPrintUnqual s)
 948   io (GHC.setContext s as bs)
 949
 950   mb_mod_info <- io $ GHC.getModuleInfo s modl
 951   case mb_mod_info of
 952     Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
 953     Just mod_info -> do
 954         let names
 955                | exports_only = GHC.modInfoExports mod_info
 956                | otherwise    = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
 957
 958             filtered = filterOutChildren names
 959
 960         things <- io $ mapM (GHC.lookupName s) filtered
 961
 962         dflags <- getDynFlags
 963         let exts = dopt Opt_GlasgowExts dflags
 964         io (putStrLn (showSDocForUser unqual (
 965                 vcat (map (pprTyThingInContext exts) (catMaybes things))
 966            )))
 967         -- ToDo: modInfoInstances currently throws an exception for
 968         -- package modules.  When it works, we can do this:
 969         --      $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
 970
 971 -----------------------------------------------------------------------------
 972 -- Setting the module context
 973
 974 setContext str
 975   | all sensible mods = fn mods
 976   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
 977   where
 978     (fn, mods) = case str of
 979                         '+':stuff -> (addToContext,      words stuff)
 980                         '-':stuff -> (removeFromContext, words stuff)
 981                         stuff     -> (newContext,        words stuff)
 982
 983     sensible ('*':m) = looksLikeModuleName m
 984     sensible m       = looksLikeModuleName m
 985
 986 separate :: Session -> [String] -> [Module] -> [Module]
 987         -> GHCi ([Module],[Module])
 988 separate session []           as bs = return (as,bs)
 989 separate session (('*':str):ms) as bs = do
 990    m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
 991    b <- io $ GHC.moduleIsInterpreted session m
 992    if b then separate session ms (m:as) bs
 993         else throwDyn (CmdLineError ("module '"
 994                         ++ GHC.moduleNameString (GHC.moduleName m)
 995                         ++ "' is not interpreted"))
 996 separate session (str:ms) as bs = do
 997   m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
 998   separate session ms as (m:bs)
 999
1000 newContext :: [String] -> GHCi ()
1001 newContext strs = do
1002   s <- getSession
1003   (as,bs) <- separate s strs [] []
1004   prel_mod <- getPrelude
1005   let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1006   io $ GHC.setContext s as bs'
1007
1008
1009 addToContext :: [String] -> GHCi ()
1010 addToContext strs = do
1011   s <- getSession
1012   (as,bs) <- io $ GHC.getContext s
1013
1014   (new_as,new_bs) <- separate s strs [] []
1015
1016   let as_to_add = new_as \\ (as ++ bs)
1017       bs_to_add = new_bs \\ (as ++ bs)
1018
1019   io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1020
1021
1022 removeFromContext :: [String] -> GHCi ()
1023 removeFromContext strs = do
1024   s <- getSession
1025   (as,bs) <- io $ GHC.getContext s
1026
1027   (as_to_remove,bs_to_remove) <- separate s strs [] []
1028
1029   let as' = as \\ (as_to_remove ++ bs_to_remove)
1030       bs' = bs \\ (as_to_remove ++ bs_to_remove)
1031
1032   io $ GHC.setContext s as' bs'
1033
1034 ----------------------------------------------------------------------------
1035 -- Code for `:set'
1036
1037 -- set options in the interpreter.  Syntax is exactly the same as the
1038 -- ghc command line, except that certain options aren't available (-C,
1039 -- -E etc.)
1040 --
1041 -- This is pretty fragile: most options won't work as expected.  ToDo:
1042 -- figure out which ones & disallow them.
1043
1044 setCmd :: String -> GHCi ()
1045 setCmd ""
1046   = do st <- getGHCiState
1047        let opts = options st
1048        io $ putStrLn (showSDoc (
1049               text "options currently set: " <>
1050               if null opts
1051                    then text "none."
1052                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1053            ))
1054 setCmd str
1055   = case toArgs str of
1056         ("args":args) -> setArgs args
1057         ("prog":prog) -> setProg prog
1058         ("prompt":prompt) -> setPrompt (after 6)
1059         ("editor":cmd) -> setEditor (after 6)
1060         ("stop":cmd) -> setStop (after 4)
1061         wds -> setOptions wds
1062    where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1063
1064 setArgs args = do
1065   st <- getGHCiState
1066   setGHCiState st{ args = args }
1067
1068 setProg [prog] = do
1069   st <- getGHCiState
1070   setGHCiState st{ progname = prog }
1071 setProg _ = do
1072   io (hPutStrLn stderr "syntax: :set prog <progname>")
1073
1074 setEditor cmd = do
1075   st <- getGHCiState
1076   setGHCiState st{ editor = cmd }
1077
1078 setStop cmd = do
1079   st <- getGHCiState
1080   setGHCiState st{ stop = cmd }
1081
1082 setPrompt value = do
1083   st <- getGHCiState
1084   if null value
1085       then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1086       else setGHCiState st{ prompt = remQuotes value }
1087   where
1088      remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1089      remQuotes x = x
1090
1091 setOptions wds =
1092    do -- first, deal with the GHCi opts (+s, +t, etc.)
1093       let (plus_opts, minus_opts)  = partition isPlus wds
1094       mapM_ setOpt plus_opts
1095
1096       -- then, dynamic flags
1097       dflags <- getDynFlags
1098       let pkg_flags = packageFlags dflags
1099       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1100
1101       if (not (null leftovers))
1102                 then throwDyn (CmdLineError ("unrecognised flags: " ++
1103                                                 unwords leftovers))
1104                 else return ()
1105
1106       new_pkgs <- setDynFlags dflags'
1107
1108       -- if the package flags changed, we should reset the context
1109       -- and link the new packages.
1110       dflags <- getDynFlags
1111       when (packageFlags dflags /= pkg_flags) $ do
1112         io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1113         session <- getSession
1114         io (GHC.setTargets session [])
1115         io (GHC.load session LoadAllTargets)
1116         io (linkPackages dflags new_pkgs)
1117         setContextAfterLoad session []
1118       return ()
1119
1120
1121 unsetOptions :: String -> GHCi ()
1122 unsetOptions str
1123   = do -- first, deal with the GHCi opts (+s, +t, etc.)
1124        let opts = words str
1125            (minus_opts, rest1) = partition isMinus opts
1126            (plus_opts, rest2)  = partition isPlus rest1
1127
1128        if (not (null rest2))
1129           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1130           else do
1131
1132        mapM_ unsetOpt plus_opts
1133
1134        -- can't do GHC flags for now
1135        if (not (null minus_opts))
1136           then throwDyn (CmdLineError "can't unset GHC command-line flags")
1137           else return ()
1138
1139 isMinus ('-':s) = True
1140 isMinus _ = False
1141
1142 isPlus ('+':s) = True
1143 isPlus _ = False
1144
1145 setOpt ('+':str)
1146   = case strToGHCiOpt str of
1147         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1148         Just o  -> setOption o
1149
1150 unsetOpt ('+':str)
1151   = case strToGHCiOpt str of
1152         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1153         Just o  -> unsetOption o
1154
1155 strToGHCiOpt :: String -> (Maybe GHCiOption)
1156 strToGHCiOpt "s" = Just ShowTiming
1157 strToGHCiOpt "t" = Just ShowType
1158 strToGHCiOpt "r" = Just RevertCAFs
1159 strToGHCiOpt _   = Nothing
1160
1161 optToStr :: GHCiOption -> String
1162 optToStr ShowTiming = "s"
1163 optToStr ShowType   = "t"
1164 optToStr RevertCAFs = "r"
1165
1166 -- ---------------------------------------------------------------------------
1167 -- code for `:show'
1168
1169 showCmd str = do
1170   st <- getGHCiState
1171   case words str of
1172         ["args"]     -> io $ putStrLn (show (args st))
1173         ["prog"]     -> io $ putStrLn (show (progname st))
1174         ["prompt"]   -> io $ putStrLn (show (prompt st))
1175         ["editor"]   -> io $ putStrLn (show (editor st))
1176         ["stop"]     -> io $ putStrLn (show (stop st))
1177         ["modules" ] -> showModules
1178         ["bindings"] -> showBindings
1179         ["linker"]   -> io showLinkerState
1180         ["breaks"]   -> showBkptTable
1181         ["context"]  -> showContext
1182         _ -> throwDyn (CmdLineError "syntax:  :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1183
1184 showModules = do
1185   session <- getSession
1186   let show_one ms = do m <- io (GHC.showModule session ms)
1187                        io (putStrLn m)
1188   graph <- io (GHC.getModuleGraph session)
1189   mapM_ show_one graph
1190
1191 showBindings = do
1192   s <- getSession
1193   unqual <- io (GHC.getPrintUnqual s)
1194   bindings <- io (GHC.getBindings s)
1195   mapM_ showTyThing bindings
1196   return ()
1197
1198 showTyThing (AnId id) = do
1199   ty' <- cleanType (GHC.idType id)
1200   printForUser $ ppr id <> text " :: " <> ppr ty'
1201 showTyThing _  = return ()
1202
1203 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1204 cleanType :: Type -> GHCi Type
1205 cleanType ty = do
1206   dflags <- getDynFlags
1207   if dopt Opt_GlasgowExts dflags
1208         then return ty
1209         else return $! GHC.dropForAlls ty
1210
1211 showBkptTable :: GHCi ()
1212 showBkptTable = do
1213   st <- getGHCiState
1214   printForUser $ prettyLocations (breaks st)
1215
1216 showContext :: GHCi ()
1217 showContext = do
1218    session <- getSession
1219    resumes <- io $ GHC.getResumeContext session
1220    printForUser $ vcat (map pp_resume (reverse resumes))
1221   where
1222    pp_resume resume =
1223         ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1224         $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1225
1226
1227 -- -----------------------------------------------------------------------------
1228 -- Completion
1229
1230 completeNone :: String -> IO [String]
1231 completeNone w = return []
1232
1233 #ifdef USE_READLINE
1234 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1235 completeWord w start end = do
1236   line <- Readline.getLineBuffer
1237   case w of
1238      ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1239      _other
1240         | Just c <- is_cmd line -> do
1241            maybe_cmd <- lookupCommand c
1242            let (n,w') = selectWord (words' 0 line)
1243            case maybe_cmd of
1244              Nothing -> return Nothing
1245              Just (_,_,False,complete) -> wrapCompleter complete w
1246              Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1247                                                               return (map (drop n) rets)
1248                                          in wrapCompleter complete' w'
1249         | otherwise     -> do
1250                 --printf "complete %s, start = %d, end = %d\n" w start end
1251                 wrapCompleter completeIdentifier w
1252     where words' _ [] = []
1253           words' n str = let (w,r) = break isSpace str
1254                              (s,r') = span isSpace r
1255                          in (n,w):words' (n+length w+length s) r'
1256           -- In a Haskell expression we want to parse 'a-b' as three words
1257           -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1258           -- only be a single word.
1259           selectWord [] = (0,w)
1260           selectWord ((offset,x):xs)
1261               | offset+length x >= start = (start-offset,take (end-offset) x)
1262               | otherwise = selectWord xs
1263
1264 is_cmd line
1265  | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1266  | otherwise = Nothing
1267
1268 completeCmd w = do
1269   cmds <- readIORef commands
1270   return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1271
1272 completeMacro w = do
1273   cmds <- readIORef commands
1274   let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1275   return (filter (w `isPrefixOf`) cmds')
1276
1277 completeIdentifier w = do
1278   s <- restoreSession
1279   rdrs <- GHC.getRdrNamesInScope s
1280   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1281
1282 completeModule w = do
1283   s <- restoreSession
1284   dflags <- GHC.getSessionDynFlags s
1285   let pkg_mods = allExposedModules dflags
1286   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1287
1288 completeHomeModule w = do
1289   s <- restoreSession
1290   g <- GHC.getModuleGraph s
1291   let home_mods = map GHC.ms_mod_name g
1292   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1293
1294 completeSetOptions w = do
1295   return (filter (w `isPrefixOf`) options)
1296     where options = "args":"prog":allFlags
1297
1298 completeFilename = Readline.filenameCompletionFunction
1299
1300 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1301
1302 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1303 unionComplete f1 f2 w = do
1304   s1 <- f1 w
1305   s2 <- f2 w
1306   return (s1 ++ s2)
1307
1308 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1309 wrapCompleter fun w =  do
1310   strs <- fun w
1311   case strs of
1312     []  -> return Nothing
1313     [x] -> return (Just (x,[]))
1314     xs  -> case getCommonPrefix xs of
1315                 ""   -> return (Just ("",xs))
1316                 pref -> return (Just (pref,xs))
1317
1318 getCommonPrefix :: [String] -> String
1319 getCommonPrefix [] = ""
1320 getCommonPrefix (s:ss) = foldl common s ss
1321   where common s "" = ""
1322         common "" s = ""
1323         common (c:cs) (d:ds)
1324            | c == d = c : common cs ds
1325            | otherwise = ""
1326
1327 allExposedModules :: DynFlags -> [ModuleName]
1328 allExposedModules dflags
1329  = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1330  where
1331   pkg_db = pkgIdMap (pkgState dflags)
1332 #else
1333 completeCmd        = completeNone
1334 completeMacro      = completeNone
1335 completeIdentifier = completeNone
1336 completeModule     = completeNone
1337 completeHomeModule = completeNone
1338 completeSetOptions = completeNone
1339 completeFilename   = completeNone
1340 completeHomeModuleOrFile=completeNone
1341 completeBkpt       = completeNone
1342 #endif
1343
1344 -- ---------------------------------------------------------------------------
1345 -- User code exception handling
1346
1347 -- This is the exception handler for exceptions generated by the
1348 -- user's code and exceptions coming from children sessions;
1349 -- it normally just prints out the exception.  The
1350 -- handler must be recursive, in case showing the exception causes
1351 -- more exceptions to be raised.
1352 --
1353 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1354 -- raising another exception.  We therefore don't put the recursive
1355 -- handler arond the flushing operation, so if stderr is closed
1356 -- GHCi will just die gracefully rather than going into an infinite loop.
1357 handler :: Exception -> GHCi Bool
1358
1359 handler exception = do
1360   flushInterpBuffers
1361   io installSignalHandlers
1362   ghciHandle handler (showException exception >> return False)
1363
1364 showException (DynException dyn) =
1365   case fromDynamic dyn of
1366     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
1367     Just Interrupted      -> io (putStrLn "Interrupted.")
1368     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
1369     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1370     Just other_ghc_ex     -> io (print other_ghc_ex)
1371
1372 showException other_exception
1373   = io (putStrLn ("*** Exception: " ++ show other_exception))
1374
1375 -----------------------------------------------------------------------------
1376 -- recursive exception handlers
1377
1378 -- Don't forget to unblock async exceptions in the handler, or if we're
1379 -- in an exception loop (eg. let a = error a in a) the ^C exception
1380 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1381
1382 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1383 ghciHandle h (GHCi m) = GHCi $ \s ->
1384    Exception.catch (m s)
1385         (\e -> unGHCi (ghciUnblock (h e)) s)
1386
1387 ghciUnblock :: GHCi a -> GHCi a
1388 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1389
1390
1391 -- ----------------------------------------------------------------------------
1392 -- Utils
1393
1394 expandPath :: String -> GHCi String
1395 expandPath path =
1396   case dropWhile isSpace path of
1397    ('~':d) -> do
1398         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1399         return (tilde ++ '/':d)
1400    other ->
1401         return other
1402
1403 wantInterpretedModule :: String -> GHCi Module
1404 wantInterpretedModule str = do
1405    session <- getSession
1406    modl <- lookupModule str
1407    is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1408    when (not is_interpreted) $
1409        throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1410    return modl
1411
1412 wantNameFromInterpretedModule noCanDo str and_then = do
1413    session <- getSession
1414    names <- io $ GHC.parseName session str
1415    case names of
1416       []    -> return ()
1417       (n:_) -> do
1418             let modl = GHC.nameModule n
1419             is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1420             if not is_interpreted
1421                then noCanDo n $ text "module " <> ppr modl <>
1422                                 text " is not interpreted"
1423                else and_then n
1424
1425 -- ----------------------------------------------------------------------------
1426 -- Windows console setup
1427
1428 setUpConsole :: IO ()
1429 setUpConsole = do
1430 #ifdef mingw32_HOST_OS
1431         -- On Windows we need to set a known code page, otherwise the characters
1432         -- we read from the console will be be in some strange encoding, and
1433         -- similarly for characters we write to the console.
1434         --
1435         -- At the moment, GHCi pretends all input is Latin-1.  In the
1436         -- future we should support UTF-8, but for now we set the code pages
1437         -- to Latin-1.
1438         --
1439         -- It seems you have to set the font in the console window to
1440         -- a Unicode font in order for output to work properly,
1441         -- otherwise non-ASCII characters are mapped wrongly.  sigh.
1442         -- (see MSDN for SetConsoleOutputCP()).
1443         --
1444         setConsoleCP 28591       -- ISO Latin-1
1445         setConsoleOutputCP 28591 -- ISO Latin-1
1446 #endif
1447         return ()
1448
1449 -- -----------------------------------------------------------------------------
1450 -- commands for debugger
1451
1452 sprintCmd = pprintCommand False False
1453 printCmd  = pprintCommand True False
1454 forceCmd  = pprintCommand False True
1455
1456 pprintCommand bind force str = do
1457   session <- getSession
1458   io $ pprintClosureCommand session bind force str
1459
1460 stepCmd :: String -> GHCi Bool
1461 stepCmd []         = doContinue GHC.SingleStep
1462 stepCmd expression = runStmt expression GHC.SingleStep
1463
1464 traceCmd :: String -> GHCi Bool
1465 traceCmd []         = doContinue GHC.RunAndLogSteps
1466 traceCmd expression = runStmt expression GHC.RunAndLogSteps
1467
1468 continueCmd :: String -> GHCi Bool
1469 continueCmd [] = doContinue GHC.RunToCompletion
1470 continueCmd other = do
1471    io $ putStrLn "The continue command accepts no arguments."
1472    return False
1473
1474 doContinue :: SingleStep -> GHCi Bool
1475 doContinue step = do
1476   session <- getSession
1477   runResult <- io $ GHC.resume session step
1478   afterRunStmt runResult
1479   return False
1480
1481 abandonCmd :: String -> GHCi ()
1482 abandonCmd = noArgs $ do
1483   s <- getSession
1484   b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1485   when (not b) $ io $ putStrLn "There is no computation running."
1486   return ()
1487
1488 deleteCmd :: String -> GHCi ()
1489 deleteCmd argLine = do
1490    deleteSwitch $ words argLine
1491    where
1492    deleteSwitch :: [String] -> GHCi ()
1493    deleteSwitch [] =
1494       io $ putStrLn "The delete command requires at least one argument."
1495    -- delete all break points
1496    deleteSwitch ("*":_rest) = discardActiveBreakPoints
1497    deleteSwitch idents = do
1498       mapM_ deleteOneBreak idents
1499       where
1500       deleteOneBreak :: String -> GHCi ()
1501       deleteOneBreak str
1502          | all isDigit str = deleteBreak (read str)
1503          | otherwise = return ()
1504
1505 historyCmd :: String -> GHCi ()
1506 historyCmd arg
1507   | null arg        = history 20
1508   | all isDigit arg = history (read arg)
1509   | otherwise       = io $ putStrLn "Syntax:  :history [num]"
1510   where
1511   history num = do
1512     s <- getSession
1513     resumes <- io $ GHC.getResumeContext s
1514     case resumes of
1515       [] -> io $ putStrLn "Not stopped at a breakpoint"
1516       (r:rs) -> do
1517         let hist = GHC.resumeHistory r
1518             (took,rest) = splitAt num hist
1519         spans <- mapM (io . GHC.getHistorySpan s) took
1520         let nums = map (printf "-%-3d:") [(1::Int)..]
1521         printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans)))
1522         io $ putStrLn $ if null rest then "<end of history>" else "..."
1523
1524 backCmd :: String -> GHCi ()
1525 backCmd = noArgs $ do
1526   s <- getSession
1527   (names, ix, span) <- io $ GHC.back s
1528   printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1529   mapM_ (showTypeOfName s) names
1530    -- run the command set with ":set stop <cmd>"
1531   st <- getGHCiState
1532   runCommand (stop st)
1533   return ()
1534
1535 forwardCmd :: String -> GHCi ()
1536 forwardCmd = noArgs $ do
1537   s <- getSession
1538   (names, ix, span) <- io $ GHC.forward s
1539   printForUser $ (if (ix == 0)
1540                     then ptext SLIT("Stopped at")
1541                     else ptext SLIT("Logged breakpoint at")) <+> ppr span
1542   mapM_ (showTypeOfName s) names
1543    -- run the command set with ":set stop <cmd>"
1544   st <- getGHCiState
1545   runCommand (stop st)
1546   return ()
1547
1548 -- handle the "break" command
1549 breakCmd :: String -> GHCi ()
1550 breakCmd argLine = do
1551    session <- getSession
1552    breakSwitch session $ words argLine
1553
1554 breakSwitch :: Session -> [String] -> GHCi ()
1555 breakSwitch _session [] = do
1556    io $ putStrLn "The break command requires at least one argument."
1557 breakSwitch session args@(arg1:rest)
1558    | looksLikeModuleName arg1 = do
1559         mod <- wantInterpretedModule arg1
1560         breakByModule session mod rest
1561    | all isDigit arg1 = do
1562         (toplevel, _) <- io $ GHC.getContext session
1563         case toplevel of
1564            (mod : _) -> breakByModuleLine mod (read arg1) rest
1565            [] -> do
1566               io $ putStrLn "Cannot find default module for breakpoint."
1567               io $ putStrLn "Perhaps no modules are loaded for debugging?"
1568    | otherwise = do -- try parsing it as an identifier
1569         wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1570         let loc = GHC.nameSrcLoc name
1571         if GHC.isGoodSrcLoc loc
1572                then findBreakAndSet (GHC.nameModule name) $
1573                          findBreakByCoord (Just (GHC.srcLocFile loc))
1574                                           (GHC.srcLocLine loc,
1575                                            GHC.srcLocCol loc)
1576                else noCanDo name $ text "can't find its location: " <> ppr loc
1577        where
1578           noCanDo n why = printForUser $
1579                 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1580
1581 breakByModule :: Session -> Module -> [String] -> GHCi ()
1582 breakByModule session mod args@(arg1:rest)
1583    | all isDigit arg1 = do  -- looks like a line number
1584         breakByModuleLine mod (read arg1) rest
1585    | otherwise = io $ putStrLn "Invalid arguments to :break"
1586
1587 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1588 breakByModuleLine mod line args
1589    | [] <- args = findBreakAndSet mod $ findBreakByLine line
1590    | [col] <- args, all isDigit col =
1591         findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1592    | otherwise = io $ putStrLn "Invalid arguments to :break"
1593
1594 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1595 findBreakAndSet mod lookupTickTree = do
1596    tickArray <- getTickArray mod
1597    (breakArray, _) <- getModBreak mod
1598    case lookupTickTree tickArray of
1599       Nothing  -> io $ putStrLn $ "No breakpoints found at that location."
1600       Just (tick, span) -> do
1601          success <- io $ setBreakFlag True breakArray tick
1602          session <- getSession
1603          if success
1604             then do
1605                (alreadySet, nm) <-
1606                      recordBreak $ BreakLocation
1607                              { breakModule = mod
1608                              , breakLoc = span
1609                              , breakTick = tick
1610                              }
1611                printForUser $
1612                   text "Breakpoint " <> ppr nm <>
1613                   if alreadySet
1614                      then text " was already set at " <> ppr span
1615                      else text " activated at " <> ppr span
1616             else do
1617             printForUser $ text "Breakpoint could not be activated at"
1618                                  <+> ppr span
1619
1620 -- When a line number is specified, the current policy for choosing
1621 -- the best breakpoint is this:
1622 --    - the leftmost complete subexpression on the specified line, or
1623 --    - the leftmost subexpression starting on the specified line, or
1624 --    - the rightmost subexpression enclosing the specified line
1625 --
1626 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1627 findBreakByLine line arr
1628   | not (inRange (bounds arr) line) = Nothing
1629   | otherwise =
1630     listToMaybe (sortBy leftmost_largest  complete)   `mplus`
1631     listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1632     listToMaybe (sortBy rightmost ticks)
1633   where
1634         ticks = arr ! line
1635
1636         starts_here = [ tick | tick@(nm,span) <- ticks,
1637                                GHC.srcSpanStartLine span == line ]
1638
1639         (complete,incomplete) = partition ends_here starts_here
1640             where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1641
1642 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1643                  -> Maybe (BreakIndex,SrcSpan)
1644 findBreakByCoord mb_file (line, col) arr
1645   | not (inRange (bounds arr) line) = Nothing
1646   | otherwise =
1647     listToMaybe (sortBy rightmost contains)
1648   where
1649         ticks = arr ! line
1650
1651         -- the ticks that span this coordinate
1652         contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1653                             is_correct_file span ]
1654
1655         is_correct_file span
1656                  | Just f <- mb_file = GHC.srcSpanFile span == f
1657                  | otherwise         = True
1658
1659
1660 leftmost_smallest  (_,a) (_,b) = a `compare` b
1661 leftmost_largest   (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1662                                 `thenCmp`
1663                                  (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1664 rightmost (_,a) (_,b) = b `compare` a
1665
1666 spans :: SrcSpan -> (Int,Int) -> Bool
1667 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1668    where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1669
1670 start_bold = BS.pack "\ESC[1m"
1671 end_bold   = BS.pack "\ESC[0m"
1672
1673 listCmd :: String -> GHCi ()
1674 listCmd "" = do
1675    mb_span <- getCurrentBreakSpan
1676    case mb_span of
1677       Nothing  -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1678       Just span -> io $ listAround span True
1679 listCmd str = list2 (words str)
1680
1681 list2 [arg] | all isDigit arg = do
1682     session <- getSession
1683     (toplevel, _) <- io $ GHC.getContext session
1684     case toplevel of
1685         [] -> io $ putStrLn "No module to list"
1686         (mod : _) -> listModuleLine mod (read arg)
1687 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1688         mod <- wantInterpretedModule arg1
1689         listModuleLine mod (read arg2)
1690 list2 [arg] = do
1691         wantNameFromInterpretedModule noCanDo arg $ \name -> do
1692         let loc = GHC.nameSrcLoc name
1693         if GHC.isGoodSrcLoc loc
1694                then do
1695                   tickArray <- getTickArray (GHC.nameModule name)
1696                   let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1697                                         (GHC.srcLocLine loc, GHC.srcLocCol loc)
1698                                         tickArray
1699                   case mb_span of
1700                     Nothing       -> io $ listAround (GHC.srcLocSpan loc) False
1701                     Just (_,span) -> io $ listAround span False
1702                else
1703                   noCanDo name $ text "can't find its location: " <>
1704                                  ppr loc
1705     where
1706         noCanDo n why = printForUser $
1707             text "cannot list source code for " <> ppr n <> text ": " <> why
1708 list2  _other =
1709         io $ putStrLn "syntax:  :list [<line> | <module> <line> | <identifier>]"
1710
1711 listModuleLine :: Module -> Int -> GHCi ()
1712 listModuleLine modl line = do
1713    session <- getSession
1714    graph <- io (GHC.getModuleGraph session)
1715    let this = filter ((== modl) . GHC.ms_mod) graph
1716    case this of
1717      [] -> panic "listModuleLine"
1718      summ:_ -> do
1719            let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1720                loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1721            io $ listAround (GHC.srcLocSpan loc) False
1722
1723 -- | list a section of a source file around a particular SrcSpan.
1724 -- If the highlight flag is True, also highlight the span using
1725 -- start_bold/end_bold.
1726 listAround span do_highlight = do
1727       contents <- BS.readFile (unpackFS file)
1728       let
1729           lines = BS.split '\n' contents
1730           these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1731                         drop (line1 - 1 - pad_before) $ lines
1732           fst_line = max 1 (line1 - pad_before)
1733           line_nos = [ fst_line .. ]
1734
1735           highlighted | do_highlight = zipWith highlight line_nos these_lines
1736                       | otherwise   = these_lines
1737
1738           bs_line_nos = [ BS.pack (show l ++ "  ") | l <- line_nos ]
1739           prefixed = zipWith BS.append bs_line_nos highlighted
1740       --
1741       BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1742   where
1743         file  = GHC.srcSpanFile span
1744         line1 = GHC.srcSpanStartLine span
1745         col1  = GHC.srcSpanStartCol span
1746         line2 = GHC.srcSpanEndLine span
1747         col2  = GHC.srcSpanEndCol span
1748
1749         pad_before | line1 == 1 = 0
1750                    | otherwise  = 1
1751         pad_after = 1
1752
1753         highlight no line
1754           | no == line1 && no == line2
1755           = let (a,r) = BS.splitAt col1 line
1756                 (b,c) = BS.splitAt (col2-col1) r
1757             in
1758             BS.concat [a,start_bold,b,end_bold,c]
1759           | no == line1
1760           = let (a,b) = BS.splitAt col1 line in
1761             BS.concat [a, start_bold, b]
1762           | no == line2
1763           = let (a,b) = BS.splitAt col2 line in
1764             BS.concat [a, end_bold, b]
1765           | otherwise   = line
1766
1767 -- --------------------------------------------------------------------------
1768 -- Tick arrays
1769
1770 getTickArray :: Module -> GHCi TickArray
1771 getTickArray modl = do
1772    st <- getGHCiState
1773    let arrmap = tickarrays st
1774    case lookupModuleEnv arrmap modl of
1775       Just arr -> return arr
1776       Nothing  -> do
1777         (breakArray, ticks) <- getModBreak modl
1778         let arr = mkTickArray (assocs ticks)
1779         setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1780         return arr
1781
1782 discardTickArrays :: GHCi ()
1783 discardTickArrays = do
1784    st <- getGHCiState
1785    setGHCiState st{tickarrays = emptyModuleEnv}
1786
1787 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1788 mkTickArray ticks
1789   = accumArray (flip (:)) [] (1, max_line)
1790         [ (line, (nm,span)) | (nm,span) <- ticks,
1791                               line <- srcSpanLines span ]
1792     where
1793         max_line = maximum (map GHC.srcSpanEndLine (map snd ticks))
1794         srcSpanLines span = [ GHC.srcSpanStartLine span ..
1795                               GHC.srcSpanEndLine span ]
1796
1797 lookupModule :: String -> GHCi Module
1798 lookupModule modName
1799    = do session <- getSession
1800         io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1801
1802 -- don't reset the counter back to zero?
1803 discardActiveBreakPoints :: GHCi ()
1804 discardActiveBreakPoints = do
1805    st <- getGHCiState
1806    mapM (turnOffBreak.snd) (breaks st)
1807    setGHCiState $ st { breaks = [] }
1808
1809 deleteBreak :: Int -> GHCi ()
1810 deleteBreak identity = do
1811    st <- getGHCiState
1812    let oldLocations    = breaks st
1813        (this,rest)     = partition (\loc -> fst loc == identity) oldLocations
1814    if null this
1815       then printForUser (text "Breakpoint" <+> ppr identity <+>
1816                          text "does not exist")
1817       else do
1818            mapM (turnOffBreak.snd) this
1819            setGHCiState $ st { breaks = rest }
1820
1821 turnOffBreak loc = do
1822   (arr, _) <- getModBreak (breakModule loc)
1823   io $ setBreakFlag False arr (breakTick loc)
1824
1825 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1826 getModBreak mod = do
1827    session <- getSession
1828    Just mod_info <- io $ GHC.getModuleInfo session mod
1829    let modBreaks  = GHC.modInfoModBreaks mod_info
1830    let array      = GHC.modBreaks_flags modBreaks
1831    let ticks      = GHC.modBreaks_locs  modBreaks
1832    return (array, ticks)
1833
1834 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1835 setBreakFlag toggle array index
1836    | toggle    = GHC.setBreakOn array index
1837    | otherwise = GHC.setBreakOff array index
1838