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       -- then, dynamic flags
1096       newDynFlags minus_opts
1097
1098 newDynFlags minus_opts = do
1099       dflags <- getDynFlags
1100       let pkg_flags = packageFlags dflags
1101       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1102
1103       if (not (null leftovers))
1104                 then throwDyn (CmdLineError ("unrecognised flags: " ++
1105                                                 unwords leftovers))
1106                 else return ()
1107
1108       new_pkgs <- setDynFlags dflags'
1109
1110       -- if the package flags changed, we should reset the context
1111       -- and link the new packages.
1112       dflags <- getDynFlags
1113       when (packageFlags dflags /= pkg_flags) $ do
1114         io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1115         session <- getSession
1116         io (GHC.setTargets session [])
1117         io (GHC.load session LoadAllTargets)
1118         io (linkPackages dflags new_pkgs)
1119         setContextAfterLoad session []
1120       return ()
1121
1122
1123 unsetOptions :: String -> GHCi ()
1124 unsetOptions str
1125   = do -- first, deal with the GHCi opts (+s, +t, etc.)
1126        let opts = words str
1127            (minus_opts, rest1) = partition isMinus opts
1128            (plus_opts, rest2)  = partition isPlus rest1
1129
1130        if (not (null rest2))
1131           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1132           else do
1133
1134        mapM_ unsetOpt plus_opts
1135
1136        let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1137            no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1138
1139        no_flags <- mapM no_flag minus_opts
1140        newDynFlags no_flags
1141
1142 isMinus ('-':s) = True
1143 isMinus _ = False
1144
1145 isPlus ('+':s) = True
1146 isPlus _ = False
1147
1148 setOpt ('+':str)
1149   = case strToGHCiOpt str of
1150         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1151         Just o  -> setOption o
1152
1153 unsetOpt ('+':str)
1154   = case strToGHCiOpt str of
1155         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1156         Just o  -> unsetOption o
1157
1158 strToGHCiOpt :: String -> (Maybe GHCiOption)
1159 strToGHCiOpt "s" = Just ShowTiming
1160 strToGHCiOpt "t" = Just ShowType
1161 strToGHCiOpt "r" = Just RevertCAFs
1162 strToGHCiOpt _   = Nothing
1163
1164 optToStr :: GHCiOption -> String
1165 optToStr ShowTiming = "s"
1166 optToStr ShowType   = "t"
1167 optToStr RevertCAFs = "r"
1168
1169 -- ---------------------------------------------------------------------------
1170 -- code for `:show'
1171
1172 showCmd str = do
1173   st <- getGHCiState
1174   case words str of
1175         ["args"]     -> io $ putStrLn (show (args st))
1176         ["prog"]     -> io $ putStrLn (show (progname st))
1177         ["prompt"]   -> io $ putStrLn (show (prompt st))
1178         ["editor"]   -> io $ putStrLn (show (editor st))
1179         ["stop"]     -> io $ putStrLn (show (stop st))
1180         ["modules" ] -> showModules
1181         ["bindings"] -> showBindings
1182         ["linker"]   -> io showLinkerState
1183         ["breaks"]   -> showBkptTable
1184         ["context"]  -> showContext
1185         _ -> throwDyn (CmdLineError "syntax:  :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1186
1187 showModules = do
1188   session <- getSession
1189   let show_one ms = do m <- io (GHC.showModule session ms)
1190                        io (putStrLn m)
1191   graph <- io (GHC.getModuleGraph session)
1192   mapM_ show_one graph
1193
1194 showBindings = do
1195   s <- getSession
1196   unqual <- io (GHC.getPrintUnqual s)
1197   bindings <- io (GHC.getBindings s)
1198   mapM_ showTyThing bindings
1199   return ()
1200
1201 showTyThing (AnId id) = do
1202   ty' <- cleanType (GHC.idType id)
1203   printForUser $ ppr id <> text " :: " <> ppr ty'
1204 showTyThing _  = return ()
1205
1206 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1207 cleanType :: Type -> GHCi Type
1208 cleanType ty = do
1209   dflags <- getDynFlags
1210   if dopt Opt_GlasgowExts dflags
1211         then return ty
1212         else return $! GHC.dropForAlls ty
1213
1214 showBkptTable :: GHCi ()
1215 showBkptTable = do
1216   st <- getGHCiState
1217   printForUser $ prettyLocations (breaks st)
1218
1219 showContext :: GHCi ()
1220 showContext = do
1221    session <- getSession
1222    resumes <- io $ GHC.getResumeContext session
1223    printForUser $ vcat (map pp_resume (reverse resumes))
1224   where
1225    pp_resume resume =
1226         ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1227         $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1228
1229
1230 -- -----------------------------------------------------------------------------
1231 -- Completion
1232
1233 completeNone :: String -> IO [String]
1234 completeNone w = return []
1235
1236 #ifdef USE_READLINE
1237 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1238 completeWord w start end = do
1239   line <- Readline.getLineBuffer
1240   case w of
1241      ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1242      _other
1243         | Just c <- is_cmd line -> do
1244            maybe_cmd <- lookupCommand c
1245            let (n,w') = selectWord (words' 0 line)
1246            case maybe_cmd of
1247              Nothing -> return Nothing
1248              Just (_,_,False,complete) -> wrapCompleter complete w
1249              Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1250                                                               return (map (drop n) rets)
1251                                          in wrapCompleter complete' w'
1252         | otherwise     -> do
1253                 --printf "complete %s, start = %d, end = %d\n" w start end
1254                 wrapCompleter completeIdentifier w
1255     where words' _ [] = []
1256           words' n str = let (w,r) = break isSpace str
1257                              (s,r') = span isSpace r
1258                          in (n,w):words' (n+length w+length s) r'
1259           -- In a Haskell expression we want to parse 'a-b' as three words
1260           -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1261           -- only be a single word.
1262           selectWord [] = (0,w)
1263           selectWord ((offset,x):xs)
1264               | offset+length x >= start = (start-offset,take (end-offset) x)
1265               | otherwise = selectWord xs
1266
1267 is_cmd line
1268  | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1269  | otherwise = Nothing
1270
1271 completeCmd w = do
1272   cmds <- readIORef commands
1273   return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1274
1275 completeMacro w = do
1276   cmds <- readIORef commands
1277   let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1278   return (filter (w `isPrefixOf`) cmds')
1279
1280 completeIdentifier w = do
1281   s <- restoreSession
1282   rdrs <- GHC.getRdrNamesInScope s
1283   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1284
1285 completeModule w = do
1286   s <- restoreSession
1287   dflags <- GHC.getSessionDynFlags s
1288   let pkg_mods = allExposedModules dflags
1289   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1290
1291 completeHomeModule w = do
1292   s <- restoreSession
1293   g <- GHC.getModuleGraph s
1294   let home_mods = map GHC.ms_mod_name g
1295   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1296
1297 completeSetOptions w = do
1298   return (filter (w `isPrefixOf`) options)
1299     where options = "args":"prog":allFlags
1300
1301 completeFilename = Readline.filenameCompletionFunction
1302
1303 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1304
1305 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1306 unionComplete f1 f2 w = do
1307   s1 <- f1 w
1308   s2 <- f2 w
1309   return (s1 ++ s2)
1310
1311 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1312 wrapCompleter fun w =  do
1313   strs <- fun w
1314   case strs of
1315     []  -> return Nothing
1316     [x] -> return (Just (x,[]))
1317     xs  -> case getCommonPrefix xs of
1318                 ""   -> return (Just ("",xs))
1319                 pref -> return (Just (pref,xs))
1320
1321 getCommonPrefix :: [String] -> String
1322 getCommonPrefix [] = ""
1323 getCommonPrefix (s:ss) = foldl common s ss
1324   where common s "" = ""
1325         common "" s = ""
1326         common (c:cs) (d:ds)
1327            | c == d = c : common cs ds
1328            | otherwise = ""
1329
1330 allExposedModules :: DynFlags -> [ModuleName]
1331 allExposedModules dflags
1332  = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1333  where
1334   pkg_db = pkgIdMap (pkgState dflags)
1335 #else
1336 completeCmd        = completeNone
1337 completeMacro      = completeNone
1338 completeIdentifier = completeNone
1339 completeModule     = completeNone
1340 completeHomeModule = completeNone
1341 completeSetOptions = completeNone
1342 completeFilename   = completeNone
1343 completeHomeModuleOrFile=completeNone
1344 completeBkpt       = completeNone
1345 #endif
1346
1347 -- ---------------------------------------------------------------------------
1348 -- User code exception handling
1349
1350 -- This is the exception handler for exceptions generated by the
1351 -- user's code and exceptions coming from children sessions;
1352 -- it normally just prints out the exception.  The
1353 -- handler must be recursive, in case showing the exception causes
1354 -- more exceptions to be raised.
1355 --
1356 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1357 -- raising another exception.  We therefore don't put the recursive
1358 -- handler arond the flushing operation, so if stderr is closed
1359 -- GHCi will just die gracefully rather than going into an infinite loop.
1360 handler :: Exception -> GHCi Bool
1361
1362 handler exception = do
1363   flushInterpBuffers
1364   io installSignalHandlers
1365   ghciHandle handler (showException exception >> return False)
1366
1367 showException (DynException dyn) =
1368   case fromDynamic dyn of
1369     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
1370     Just Interrupted      -> io (putStrLn "Interrupted.")
1371     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
1372     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1373     Just other_ghc_ex     -> io (print other_ghc_ex)
1374
1375 showException other_exception
1376   = io (putStrLn ("*** Exception: " ++ show other_exception))
1377
1378 -----------------------------------------------------------------------------
1379 -- recursive exception handlers
1380
1381 -- Don't forget to unblock async exceptions in the handler, or if we're
1382 -- in an exception loop (eg. let a = error a in a) the ^C exception
1383 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1384
1385 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1386 ghciHandle h (GHCi m) = GHCi $ \s ->
1387    Exception.catch (m s)
1388         (\e -> unGHCi (ghciUnblock (h e)) s)
1389
1390 ghciUnblock :: GHCi a -> GHCi a
1391 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1392
1393
1394 -- ----------------------------------------------------------------------------
1395 -- Utils
1396
1397 expandPath :: String -> GHCi String
1398 expandPath path =
1399   case dropWhile isSpace path of
1400    ('~':d) -> do
1401         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1402         return (tilde ++ '/':d)
1403    other ->
1404         return other
1405
1406 wantInterpretedModule :: String -> GHCi Module
1407 wantInterpretedModule str = do
1408    session <- getSession
1409    modl <- lookupModule str
1410    is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1411    when (not is_interpreted) $
1412        throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1413    return modl
1414
1415 wantNameFromInterpretedModule noCanDo str and_then = do
1416    session <- getSession
1417    names <- io $ GHC.parseName session str
1418    case names of
1419       []    -> return ()
1420       (n:_) -> do
1421             let modl = GHC.nameModule n
1422             is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1423             if not is_interpreted
1424                then noCanDo n $ text "module " <> ppr modl <>
1425                                 text " is not interpreted"
1426                else and_then n
1427
1428 -- ----------------------------------------------------------------------------
1429 -- Windows console setup
1430
1431 setUpConsole :: IO ()
1432 setUpConsole = do
1433 #ifdef mingw32_HOST_OS
1434         -- On Windows we need to set a known code page, otherwise the characters
1435         -- we read from the console will be be in some strange encoding, and
1436         -- similarly for characters we write to the console.
1437         --
1438         -- At the moment, GHCi pretends all input is Latin-1.  In the
1439         -- future we should support UTF-8, but for now we set the code pages
1440         -- to Latin-1.
1441         --
1442         -- It seems you have to set the font in the console window to
1443         -- a Unicode font in order for output to work properly,
1444         -- otherwise non-ASCII characters are mapped wrongly.  sigh.
1445         -- (see MSDN for SetConsoleOutputCP()).
1446         --
1447         setConsoleCP 28591       -- ISO Latin-1
1448         setConsoleOutputCP 28591 -- ISO Latin-1
1449 #endif
1450         return ()
1451
1452 -- -----------------------------------------------------------------------------
1453 -- commands for debugger
1454
1455 sprintCmd = pprintCommand False False
1456 printCmd  = pprintCommand True False
1457 forceCmd  = pprintCommand False True
1458
1459 pprintCommand bind force str = do
1460   session <- getSession
1461   io $ pprintClosureCommand session bind force str
1462
1463 stepCmd :: String -> GHCi Bool
1464 stepCmd []         = doContinue GHC.SingleStep
1465 stepCmd expression = runStmt expression GHC.SingleStep
1466
1467 traceCmd :: String -> GHCi Bool
1468 traceCmd []         = doContinue GHC.RunAndLogSteps
1469 traceCmd expression = runStmt expression GHC.RunAndLogSteps
1470
1471 continueCmd :: String -> GHCi Bool
1472 continueCmd [] = doContinue GHC.RunToCompletion
1473 continueCmd other = do
1474    io $ putStrLn "The continue command accepts no arguments."
1475    return False
1476
1477 doContinue :: SingleStep -> GHCi Bool
1478 doContinue step = do
1479   session <- getSession
1480   runResult <- io $ GHC.resume session step
1481   afterRunStmt runResult
1482   return False
1483
1484 abandonCmd :: String -> GHCi ()
1485 abandonCmd = noArgs $ do
1486   s <- getSession
1487   b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1488   when (not b) $ io $ putStrLn "There is no computation running."
1489   return ()
1490
1491 deleteCmd :: String -> GHCi ()
1492 deleteCmd argLine = do
1493    deleteSwitch $ words argLine
1494    where
1495    deleteSwitch :: [String] -> GHCi ()
1496    deleteSwitch [] =
1497       io $ putStrLn "The delete command requires at least one argument."
1498    -- delete all break points
1499    deleteSwitch ("*":_rest) = discardActiveBreakPoints
1500    deleteSwitch idents = do
1501       mapM_ deleteOneBreak idents
1502       where
1503       deleteOneBreak :: String -> GHCi ()
1504       deleteOneBreak str
1505          | all isDigit str = deleteBreak (read str)
1506          | otherwise = return ()
1507
1508 historyCmd :: String -> GHCi ()
1509 historyCmd arg
1510   | null arg        = history 20
1511   | all isDigit arg = history (read arg)
1512   | otherwise       = io $ putStrLn "Syntax:  :history [num]"
1513   where
1514   history num = do
1515     s <- getSession
1516     resumes <- io $ GHC.getResumeContext s
1517     case resumes of
1518       [] -> io $ putStrLn "Not stopped at a breakpoint"
1519       (r:rs) -> do
1520         let hist = GHC.resumeHistory r
1521             (took,rest) = splitAt num hist
1522         spans <- mapM (io . GHC.getHistorySpan s) took
1523         let nums = map (printf "-%-3d:") [(1::Int)..]
1524         printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans)))
1525         io $ putStrLn $ if null rest then "<end of history>" else "..."
1526
1527 backCmd :: String -> GHCi ()
1528 backCmd = noArgs $ do
1529   s <- getSession
1530   (names, ix, span) <- io $ GHC.back s
1531   printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1532   mapM_ (showTypeOfName s) names
1533    -- run the command set with ":set stop <cmd>"
1534   st <- getGHCiState
1535   runCommand (stop st)
1536   return ()
1537
1538 forwardCmd :: String -> GHCi ()
1539 forwardCmd = noArgs $ do
1540   s <- getSession
1541   (names, ix, span) <- io $ GHC.forward s
1542   printForUser $ (if (ix == 0)
1543                     then ptext SLIT("Stopped at")
1544                     else ptext SLIT("Logged breakpoint at")) <+> ppr span
1545   mapM_ (showTypeOfName s) names
1546    -- run the command set with ":set stop <cmd>"
1547   st <- getGHCiState
1548   runCommand (stop st)
1549   return ()
1550
1551 -- handle the "break" command
1552 breakCmd :: String -> GHCi ()
1553 breakCmd argLine = do
1554    session <- getSession
1555    breakSwitch session $ words argLine
1556
1557 breakSwitch :: Session -> [String] -> GHCi ()
1558 breakSwitch _session [] = do
1559    io $ putStrLn "The break command requires at least one argument."
1560 breakSwitch session args@(arg1:rest)
1561    | looksLikeModuleName arg1 = do
1562         mod <- wantInterpretedModule arg1
1563         breakByModule session mod rest
1564    | all isDigit arg1 = do
1565         (toplevel, _) <- io $ GHC.getContext session
1566         case toplevel of
1567            (mod : _) -> breakByModuleLine mod (read arg1) rest
1568            [] -> do
1569               io $ putStrLn "Cannot find default module for breakpoint."
1570               io $ putStrLn "Perhaps no modules are loaded for debugging?"
1571    | otherwise = do -- try parsing it as an identifier
1572         wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1573         let loc = GHC.nameSrcLoc name
1574         if GHC.isGoodSrcLoc loc
1575                then findBreakAndSet (GHC.nameModule name) $
1576                          findBreakByCoord (Just (GHC.srcLocFile loc))
1577                                           (GHC.srcLocLine loc,
1578                                            GHC.srcLocCol loc)
1579                else noCanDo name $ text "can't find its location: " <> ppr loc
1580        where
1581           noCanDo n why = printForUser $
1582                 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1583
1584 breakByModule :: Session -> Module -> [String] -> GHCi ()
1585 breakByModule session mod args@(arg1:rest)
1586    | all isDigit arg1 = do  -- looks like a line number
1587         breakByModuleLine mod (read arg1) rest
1588    | otherwise = io $ putStrLn "Invalid arguments to :break"
1589
1590 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1591 breakByModuleLine mod line args
1592    | [] <- args = findBreakAndSet mod $ findBreakByLine line
1593    | [col] <- args, all isDigit col =
1594         findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1595    | otherwise = io $ putStrLn "Invalid arguments to :break"
1596
1597 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1598 findBreakAndSet mod lookupTickTree = do
1599    tickArray <- getTickArray mod
1600    (breakArray, _) <- getModBreak mod
1601    case lookupTickTree tickArray of
1602       Nothing  -> io $ putStrLn $ "No breakpoints found at that location."
1603       Just (tick, span) -> do
1604          success <- io $ setBreakFlag True breakArray tick
1605          session <- getSession
1606          if success
1607             then do
1608                (alreadySet, nm) <-
1609                      recordBreak $ BreakLocation
1610                              { breakModule = mod
1611                              , breakLoc = span
1612                              , breakTick = tick
1613                              }
1614                printForUser $
1615                   text "Breakpoint " <> ppr nm <>
1616                   if alreadySet
1617                      then text " was already set at " <> ppr span
1618                      else text " activated at " <> ppr span
1619             else do
1620             printForUser $ text "Breakpoint could not be activated at"
1621                                  <+> ppr span
1622
1623 -- When a line number is specified, the current policy for choosing
1624 -- the best breakpoint is this:
1625 --    - the leftmost complete subexpression on the specified line, or
1626 --    - the leftmost subexpression starting on the specified line, or
1627 --    - the rightmost subexpression enclosing the specified line
1628 --
1629 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1630 findBreakByLine line arr
1631   | not (inRange (bounds arr) line) = Nothing
1632   | otherwise =
1633     listToMaybe (sortBy leftmost_largest  complete)   `mplus`
1634     listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1635     listToMaybe (sortBy rightmost ticks)
1636   where
1637         ticks = arr ! line
1638
1639         starts_here = [ tick | tick@(nm,span) <- ticks,
1640                                GHC.srcSpanStartLine span == line ]
1641
1642         (complete,incomplete) = partition ends_here starts_here
1643             where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1644
1645 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1646                  -> Maybe (BreakIndex,SrcSpan)
1647 findBreakByCoord mb_file (line, col) arr
1648   | not (inRange (bounds arr) line) = Nothing
1649   | otherwise =
1650     listToMaybe (sortBy rightmost contains)
1651   where
1652         ticks = arr ! line
1653
1654         -- the ticks that span this coordinate
1655         contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1656                             is_correct_file span ]
1657
1658         is_correct_file span
1659                  | Just f <- mb_file = GHC.srcSpanFile span == f
1660                  | otherwise         = True
1661
1662
1663 leftmost_smallest  (_,a) (_,b) = a `compare` b
1664 leftmost_largest   (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1665                                 `thenCmp`
1666                                  (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1667 rightmost (_,a) (_,b) = b `compare` a
1668
1669 spans :: SrcSpan -> (Int,Int) -> Bool
1670 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1671    where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1672
1673 start_bold = BS.pack "\ESC[1m"
1674 end_bold   = BS.pack "\ESC[0m"
1675
1676 listCmd :: String -> GHCi ()
1677 listCmd "" = do
1678    mb_span <- getCurrentBreakSpan
1679    case mb_span of
1680       Nothing  -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1681       Just span -> io $ listAround span True
1682 listCmd str = list2 (words str)
1683
1684 list2 [arg] | all isDigit arg = do
1685     session <- getSession
1686     (toplevel, _) <- io $ GHC.getContext session
1687     case toplevel of
1688         [] -> io $ putStrLn "No module to list"
1689         (mod : _) -> listModuleLine mod (read arg)
1690 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1691         mod <- wantInterpretedModule arg1
1692         listModuleLine mod (read arg2)
1693 list2 [arg] = do
1694         wantNameFromInterpretedModule noCanDo arg $ \name -> do
1695         let loc = GHC.nameSrcLoc name
1696         if GHC.isGoodSrcLoc loc
1697                then do
1698                   tickArray <- getTickArray (GHC.nameModule name)
1699                   let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1700                                         (GHC.srcLocLine loc, GHC.srcLocCol loc)
1701                                         tickArray
1702                   case mb_span of
1703                     Nothing       -> io $ listAround (GHC.srcLocSpan loc) False
1704                     Just (_,span) -> io $ listAround span False
1705                else
1706                   noCanDo name $ text "can't find its location: " <>
1707                                  ppr loc
1708     where
1709         noCanDo n why = printForUser $
1710             text "cannot list source code for " <> ppr n <> text ": " <> why
1711 list2  _other =
1712         io $ putStrLn "syntax:  :list [<line> | <module> <line> | <identifier>]"
1713
1714 listModuleLine :: Module -> Int -> GHCi ()
1715 listModuleLine modl line = do
1716    session <- getSession
1717    graph <- io (GHC.getModuleGraph session)
1718    let this = filter ((== modl) . GHC.ms_mod) graph
1719    case this of
1720      [] -> panic "listModuleLine"
1721      summ:_ -> do
1722            let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1723                loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1724            io $ listAround (GHC.srcLocSpan loc) False
1725
1726 -- | list a section of a source file around a particular SrcSpan.
1727 -- If the highlight flag is True, also highlight the span using
1728 -- start_bold/end_bold.
1729 listAround span do_highlight = do
1730       contents <- BS.readFile (unpackFS file)
1731       let
1732           lines = BS.split '\n' contents
1733           these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1734                         drop (line1 - 1 - pad_before) $ lines
1735           fst_line = max 1 (line1 - pad_before)
1736           line_nos = [ fst_line .. ]
1737
1738           highlighted | do_highlight = zipWith highlight line_nos these_lines
1739                       | otherwise   = these_lines
1740
1741           bs_line_nos = [ BS.pack (show l ++ "  ") | l <- line_nos ]
1742           prefixed = zipWith BS.append bs_line_nos highlighted
1743       --
1744       BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1745   where
1746         file  = GHC.srcSpanFile span
1747         line1 = GHC.srcSpanStartLine span
1748         col1  = GHC.srcSpanStartCol span
1749         line2 = GHC.srcSpanEndLine span
1750         col2  = GHC.srcSpanEndCol span
1751
1752         pad_before | line1 == 1 = 0
1753                    | otherwise  = 1
1754         pad_after = 1
1755
1756         highlight no line
1757           | no == line1 && no == line2
1758           = let (a,r) = BS.splitAt col1 line
1759                 (b,c) = BS.splitAt (col2-col1) r
1760             in
1761             BS.concat [a,start_bold,b,end_bold,c]
1762           | no == line1
1763           = let (a,b) = BS.splitAt col1 line in
1764             BS.concat [a, start_bold, b]
1765           | no == line2
1766           = let (a,b) = BS.splitAt col2 line in
1767             BS.concat [a, end_bold, b]
1768           | otherwise   = line
1769
1770 -- --------------------------------------------------------------------------
1771 -- Tick arrays
1772
1773 getTickArray :: Module -> GHCi TickArray
1774 getTickArray modl = do
1775    st <- getGHCiState
1776    let arrmap = tickarrays st
1777    case lookupModuleEnv arrmap modl of
1778       Just arr -> return arr
1779       Nothing  -> do
1780         (breakArray, ticks) <- getModBreak modl
1781         let arr = mkTickArray (assocs ticks)
1782         setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1783         return arr
1784
1785 discardTickArrays :: GHCi ()
1786 discardTickArrays = do
1787    st <- getGHCiState
1788    setGHCiState st{tickarrays = emptyModuleEnv}
1789
1790 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1791 mkTickArray ticks
1792   = accumArray (flip (:)) [] (1, max_line)
1793         [ (line, (nm,span)) | (nm,span) <- ticks,
1794                               line <- srcSpanLines span ]
1795     where
1796         max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1797         srcSpanLines span = [ GHC.srcSpanStartLine span ..
1798                               GHC.srcSpanEndLine span ]
1799
1800 lookupModule :: String -> GHCi Module
1801 lookupModule modName
1802    = do session <- getSession
1803         io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1804
1805 -- don't reset the counter back to zero?
1806 discardActiveBreakPoints :: GHCi ()
1807 discardActiveBreakPoints = do
1808    st <- getGHCiState
1809    mapM (turnOffBreak.snd) (breaks st)
1810    setGHCiState $ st { breaks = [] }
1811
1812 deleteBreak :: Int -> GHCi ()
1813 deleteBreak identity = do
1814    st <- getGHCiState
1815    let oldLocations    = breaks st
1816        (this,rest)     = partition (\loc -> fst loc == identity) oldLocations
1817    if null this
1818       then printForUser (text "Breakpoint" <+> ppr identity <+>
1819                          text "does not exist")
1820       else do
1821            mapM (turnOffBreak.snd) this
1822            setGHCiState $ st { breaks = rest }
1823
1824 turnOffBreak loc = do
1825   (arr, _) <- getModBreak (breakModule loc)
1826   io $ setBreakFlag False arr (breakTick loc)
1827
1828 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1829 getModBreak mod = do
1830    session <- getSession
1831    Just mod_info <- io $ GHC.getModuleInfo session mod
1832    let modBreaks  = GHC.modInfoModBreaks mod_info
1833    let array      = GHC.modBreaks_flags modBreaks
1834    let ticks      = GHC.modBreaks_locs  modBreaks
1835    return (array, ticks)
1836
1837 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1838 setBreakFlag toggle array index
1839    | toggle    = GHC.setBreakOn array index
1840    | otherwise = GHC.setBreakOff array index
1841