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