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
  10 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
  11
  12 #include "HsVersions.h"
  13
  14 import GhciMonad
  15 import GhciTags
  16 import Debugger
  17
  18 -- The GHC interface
  19 import qualified GHC
  20 import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
  21                           Module, ModuleName, TyThing(..), Phase,
  22                           BreakIndex, SrcSpan, Resume, SingleStep )
  23 import PprTyThing
  24 import DynFlags
  25
  26 import Packages
  27 #ifdef USE_READLINE
  28 import PackageConfig
  29 import UniqFM
  30 #endif
  31
  32 import HscTypes         ( implicitTyThings )
  33 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
  34 import Outputable       hiding (printForUser, printForUserPartWay)
  35 import Module           -- for ModuleEnv
  36 import Name
  37 import SrcLoc
  38
  39 -- Other random utilities
  40 import Digraph
  41 import BasicTypes hiding (isTopLevel)
  42 import Panic      hiding (showException)
  43 import Config
  44 import StaticFlags
  45 import Linker
  46 import Util
  47 import NameSet
  48 import Maybes           ( orElse )
  49 import FastString
  50 import Encoding
  51
  52 #ifndef mingw32_HOST_OS
  53 import System.Posix hiding (getEnv)
  54 #else
  55 import GHC.ConsoleHandler ( flushConsole )
  56 import qualified System.Win32
  57 import System.FilePath
  58 #endif
  59
  60 #ifdef USE_READLINE
  61 import Control.Concurrent       ( yield )       -- Used in readline loop
  62 import System.Console.Readline as Readline
  63 #endif
  64
  65 --import SystemExts
  66
  67 import Control.Exception as Exception
  68 -- import Control.Concurrent
  69
  70 import qualified Data.ByteString.Char8 as BS
  71 import Data.List
  72 import Data.Maybe
  73 import System.Cmd
  74 import System.Environment
  75 import System.Exit      ( exitWith, ExitCode(..) )
  76 import System.Directory
  77 import System.IO
  78 import System.IO.Error as IO
  79 import Data.Char
  80 import Data.Dynamic
  81 import Data.Array
  82 import Control.Monad as Monad
  83 import Text.Printf
  84 import Foreign
  85 import Foreign.C
  86 import GHC.Exts         ( unsafeCoerce# )
  87 import GHC.IOBase       ( IOErrorType(InvalidArgument) )
  88 import GHC.TopHandler
  89
  90 import Data.IORef       ( IORef, readIORef, writeIORef )
  91
  92 #ifdef USE_READLINE
  93 import System.Posix.Internals ( setNonBlockingFD )
  94 #endif
  95
  96 -----------------------------------------------------------------------------
  97
  98 ghciWelcomeMsg :: String
  99 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
 100                  ": http://www.haskell.org/ghc/  :? for help"
 101
 102 cmdName :: Command -> String
 103 cmdName (n,_,_,_) = n
 104
 105 macros_ref :: IORef [Command]
 106 GLOBAL_VAR(macros_ref, [], [Command])
 107
 108 builtin_commands :: [Command]
 109 builtin_commands = [
 110         -- Hugs users are accustomed to :e, so make sure it doesn't overlap
 111   ("?",         keepGoing help,                 Nothing, completeNone),
 112   ("add",       keepGoingPaths addModule,       Just filenameWordBreakChars, completeFilename),
 113   ("abandon",   keepGoing abandonCmd,           Nothing, completeNone),
 114   ("break",     keepGoing breakCmd,             Nothing, completeIdentifier),
 115   ("back",      keepGoing backCmd,              Nothing, completeNone),
 116   ("browse",    keepGoing (browseCmd False),    Nothing, completeModule),
 117   ("browse!",   keepGoing (browseCmd True),     Nothing, completeModule),
 118   ("cd",        keepGoing changeDirectory,      Just filenameWordBreakChars, completeFilename),
 119   ("check",     keepGoing checkModule,          Nothing, completeHomeModule),
 120   ("continue",  keepGoing continueCmd,          Nothing, completeNone),
 121   ("cmd",       keepGoing cmdCmd,               Nothing, completeIdentifier),
 122   ("ctags",     keepGoing createCTagsFileCmd,   Just filenameWordBreakChars, completeFilename),
 123   ("def",       keepGoing (defineMacro False),  Nothing, completeIdentifier),
 124   ("def!",      keepGoing (defineMacro True),   Nothing, completeIdentifier),
 125   ("delete",    keepGoing deleteCmd,            Nothing, completeNone),
 126   ("e",         keepGoing editFile,             Just filenameWordBreakChars, completeFilename),
 127   ("edit",      keepGoing editFile,             Just filenameWordBreakChars, completeFilename),
 128   ("etags",     keepGoing createETagsFileCmd,   Just filenameWordBreakChars, completeFilename),
 129   ("force",     keepGoing forceCmd,             Nothing, completeIdentifier),
 130   ("forward",   keepGoing forwardCmd,           Nothing, completeNone),
 131   ("help",      keepGoing help,                 Nothing, completeNone),
 132   ("history",   keepGoing historyCmd,           Nothing, completeNone),
 133   ("info",      keepGoing info,                 Nothing, completeIdentifier),
 134   ("kind",      keepGoing kindOfType,           Nothing, completeIdentifier),
 135   ("load",      keepGoingPaths loadModule_,     Just filenameWordBreakChars, completeHomeModuleOrFile),
 136   ("list",      keepGoing listCmd,              Nothing, completeNone),
 137   ("module",    keepGoing setContext,           Nothing, completeModule),
 138   ("main",      keepGoing runMain,              Nothing, completeIdentifier),
 139   ("print",     keepGoing printCmd,             Nothing, completeIdentifier),
 140   ("quit",      quit,                           Nothing, completeNone),
 141   ("reload",    keepGoing reloadModule,         Nothing, completeNone),
 142   ("run",       keepGoing runRun,               Nothing, completeIdentifier),
 143   ("set",       keepGoing setCmd,               Just flagWordBreakChars, completeSetOptions),
 144   ("show",      keepGoing showCmd,              Nothing, completeNone),
 145   ("sprint",    keepGoing sprintCmd,            Nothing, completeIdentifier),
 146   ("step",      keepGoing stepCmd,              Nothing, completeIdentifier),
 147   ("steplocal", keepGoing stepLocalCmd,         Nothing, completeIdentifier),
 148   ("stepmodule",keepGoing stepModuleCmd,        Nothing, completeIdentifier),
 149   ("type",      keepGoing typeOfExpr,           Nothing, completeIdentifier),
 150   ("trace",     keepGoing traceCmd,             Nothing, completeIdentifier),
 151   ("undef",     keepGoing undefineMacro,        Nothing, completeMacro),
 152   ("unset",     keepGoing unsetOptions,         Just flagWordBreakChars,  completeSetOptions)
 153   ]
 154
 155
 156 -- We initialize readline (in the interactiveUI function) to use
 157 -- word_break_chars as the default set of completion word break characters.
 158 -- This can be overridden for a particular command (for example, filename
 159 -- expansion shouldn't consider '/' to be a word break) by setting the third
 160 -- entry in the Command tuple above.
 161 --
 162 -- NOTE: in order for us to override the default correctly, any custom entry
 163 -- must be a SUBSET of word_break_chars.
 164 #ifdef USE_READLINE
 165 word_break_chars :: String
 166 word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
 167                        specials = "(),;[]`{}"
 168                        spaces = " \t\n"
 169                    in spaces ++ specials ++ symbols
 170 #endif
 171
 172 flagWordBreakChars, filenameWordBreakChars :: String
 173 flagWordBreakChars = " \t\n"
 174 filenameWordBreakChars = " \t\n\\`@$><=;|&{(" -- bash defaults
 175
 176
 177 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 178 keepGoing a str = a str >> return False
 179
 180 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
 181 keepGoingPaths a str
 182  = do case toArgs str of
 183           Left err -> io (hPutStrLn stderr err)
 184           Right args -> a args
 185       return False
 186
 187 shortHelpText :: String
 188 shortHelpText = "use :? for help.\n"
 189
 190 helpText :: String
 191 helpText =
 192  " Commands available from the prompt:\n" ++
 193  "\n" ++
 194  "   <statement>                 evaluate/run <statement>\n" ++
 195  "   :                           repeat last command\n" ++
 196  "   :{\\n ..lines.. \\n:}\\n       multiline command\n" ++
 197  "   :add <filename> ...         add module(s) to the current target set\n" ++
 198  "   :browse[!] [[*]<mod>]       display the names defined by module <mod>\n" ++
 199  "                               (!: more details; *: all top-level names)\n" ++
 200  "   :cd <dir>                   change directory to <dir>\n" ++
 201  "   :cmd <expr>                 run the commands returned by <expr>::IO String\n" ++
 202  "   :ctags [<file>]             create tags file for Vi (default: \"tags\")\n" ++
 203  "   :def <cmd> <expr>           define a command :<cmd>\n" ++
 204  "   :edit <file>                edit file\n" ++
 205  "   :edit                       edit last module\n" ++
 206  "   :etags [<file>]             create tags file for Emacs (default: \"TAGS\")\n" ++
 207  "   :help, :?                   display this list of commands\n" ++
 208  "   :info [<name> ...]          display information about the given names\n" ++
 209  "   :kind <type>                show the kind of <type>\n" ++
 210  "   :load <filename> ...        load module(s) and their dependents\n" ++
 211  "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
 212  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
 213  "   :quit                       exit GHCi\n" ++
 214  "   :reload                     reload the current module set\n" ++
 215  "   :run function [<arguments> ...] run the function with the given arguments\n" ++
 216  "   :type <expr>                show the type of <expr>\n" ++
 217  "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
 218  "   :!<command>                 run the shell command <command>\n" ++
 219  "\n" ++
 220  " -- Commands for debugging:\n" ++
 221  "\n" ++
 222  "   :abandon                    at a breakpoint, abandon current computation\n" ++
 223  "   :back                       go back in the history (after :trace)\n" ++
 224  "   :break [<mod>] <l> [<col>]  set a breakpoint at the specified location\n" ++
 225  "   :break <name>               set a breakpoint on the specified function\n" ++
 226  "   :continue                   resume after a breakpoint\n" ++
 227  "   :delete <number>            delete the specified breakpoint\n" ++
 228  "   :delete *                   delete all breakpoints\n" ++
 229  "   :force <expr>               print <expr>, forcing unevaluated parts\n" ++
 230  "   :forward                    go forward in the history (after :back)\n" ++
 231  "   :history [<n>]              after :trace, show the execution history\n" ++
 232  "   :print [<name> ...]         prints a value without forcing its computation\n" ++
 233  "   :sprint [<name> ...]        simplifed version of :print\n" ++
 234  "   :step                       single-step after stopping at a breakpoint\n"++
 235  "   :step <expr>                single-step into <expr>\n"++
 236  "   :steplocal                  single-step within the current top-level binding\n"++
 237  "   :stepmodule                 single-step restricted to the current module\n"++
 238  "   :trace                      trace after stopping at a breakpoint\n"++
 239  "   :trace <expr>               evaluate <expr> with tracing on (see :history)\n"++
 240
 241  "\n" ++
 242  " -- Commands for changing settings:\n" ++
 243  "\n" ++
 244  "   :set <option> ...           set options\n" ++
 245  "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
 246  "   :set prog <progname>        set the value returned by System.getProgName\n" ++
 247  "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
 248  "   :set editor <cmd>           set the command used for :edit\n" ++
 249  "   :set stop <cmd>             set the command to run when a breakpoint is hit\n" ++
 250  "   :unset <option> ...         unset options\n" ++
 251  "\n" ++
 252  "  Options for ':set' and ':unset':\n" ++
 253  "\n" ++
 254  "    +r            revert top-level expressions after each evaluation\n" ++
 255  "    +s            print timing/memory stats after each evaluation\n" ++
 256  "    +t            print type after evaluation\n" ++
 257  "    -<flags>      most GHC command line flags can also be set here\n" ++
 258  "                         (eg. -v2, -fglasgow-exts, etc.)\n" ++
 259  "                    for GHCi-specific flags, see User's Guide,\n"++
 260  "                    Flag reference, Interactive-mode options\n" ++
 261  "\n" ++
 262  " -- Commands for displaying information:\n" ++
 263  "\n" ++
 264  "   :show bindings              show the current bindings made at the prompt\n" ++
 265  "   :show breaks                show the active breakpoints\n" ++
 266  "   :show context               show the breakpoint context\n" ++
 267  "   :show modules               show the currently loaded modules\n" ++
 268  "   :show packages              show the currently active package flags\n" ++
 269  "   :show languages             show the currently active language flags\n" ++
 270  "   :show <setting>             show value of <setting>, which is one of\n" ++
 271  "                                  [args, prog, prompt, editor, stop]\n" ++
 272  "\n"
 273
 274 findEditor :: IO String
 275 findEditor = do
 276   getEnv "EDITOR"
 277     `IO.catch` \_ -> do
 278 #if mingw32_HOST_OS
 279         win <- System.Win32.getWindowsDirectory
 280         return (win </> "notepad.exe")
 281 #else
 282         return ""
 283 #endif
 284
 285 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe [String]
 286               -> IO ()
 287 interactiveUI session srcs maybe_exprs = do
 288    -- HACK! If we happen to get into an infinite loop (eg the user
 289    -- types 'let x=x in x' at the prompt), then the thread will block
 290    -- on a blackhole, and become unreachable during GC.  The GC will
 291    -- detect that it is unreachable and send it the NonTermination
 292    -- exception.  However, since the thread is unreachable, everything
 293    -- it refers to might be finalized, including the standard Handles.
 294    -- This sounds like a bug, but we don't have a good solution right
 295    -- now.
 296    newStablePtr stdin
 297    newStablePtr stdout
 298    newStablePtr stderr
 299
 300     -- Initialise buffering for the *interpreted* I/O system
 301    initInterpBuffering session
 302
 303    when (isNothing maybe_exprs) $ do
 304         -- Only for GHCi (not runghc and ghc -e):
 305
 306         -- Turn buffering off for the compiled program's stdout/stderr
 307         turnOffBuffering
 308         -- Turn buffering off for GHCi's stdout
 309         hFlush stdout
 310         hSetBuffering stdout NoBuffering
 311         -- We don't want the cmd line to buffer any input that might be
 312         -- intended for the program, so unbuffer stdin.
 313         hSetBuffering stdin NoBuffering
 314
 315 #ifdef USE_READLINE
 316         is_tty <- hIsTerminalDevice stdin
 317         when is_tty $ do
 318             Readline.initialize
 319             Readline.setAttemptedCompletionFunction (Just completeWord)
 320             --Readline.parseAndBind "set show-all-if-ambiguous 1"
 321
 322             Readline.setBasicWordBreakCharacters word_break_chars
 323             Readline.setCompleterWordBreakCharacters word_break_chars
 324             Readline.setCompletionAppendCharacter Nothing
 325 #endif
 326
 327    -- initial context is just the Prelude
 328    prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude")
 329                                       (Just basePackageId)
 330    GHC.setContext session [] [prel_mod]
 331
 332    default_editor <- findEditor
 333
 334    startGHCi (runGHCi srcs maybe_exprs)
 335         GHCiState{ progname = "<interactive>",
 336                    args = [],
 337                    prompt = "%s> ",
 338                    stop = "",
 339                    editor = default_editor,
 340                    session = session,
 341                    options = [],
 342                    prelude = prel_mod,
 343                    break_ctr = 0,
 344                    breaks = [],
 345                    tickarrays = emptyModuleEnv,
 346                    last_command = Nothing,
 347                    cmdqueue = [],
 348                    remembered_ctx = []
 349                  }
 350
 351 #ifdef USE_READLINE
 352    Readline.resetTerminal Nothing
 353 #endif
 354
 355    return ()
 356
 357 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
 358 runGHCi paths maybe_exprs = do
 359   let read_dot_files = not opt_IgnoreDotGhci
 360
 361   when (read_dot_files) $ do
 362     -- Read in ./.ghci.
 363     let file = "./.ghci"
 364     exists <- io (doesFileExist file)
 365     when exists $ do
 366        dir_ok  <- io (checkPerms ".")
 367        file_ok <- io (checkPerms file)
 368        when (dir_ok && file_ok) $ do
 369           either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
 370           case either_hdl of
 371              Left _e   -> return ()
 372              Right hdl -> runCommands (fileLoop hdl False False)
 373
 374   when (read_dot_files) $ do
 375     -- Read in $HOME/.ghci
 376     either_dir <- io (IO.try getHomeDirectory)
 377     case either_dir of
 378        Left _e -> return ()
 379        Right dir -> do
 380           cwd <- io (getCurrentDirectory)
 381           when (dir /= cwd) $ do
 382              let file = dir ++ "/.ghci"
 383              ok <- io (checkPerms file)
 384              when ok $ do
 385                either_hdl <- io (IO.try (openFile file ReadMode))
 386                case either_hdl of
 387                   Left _e   -> return ()
 388                   Right hdl -> runCommands (fileLoop hdl False False)
 389
 390   -- Perform a :load for files given on the GHCi command line
 391   -- When in -e mode, if the load fails then we want to stop
 392   -- immediately rather than going on to evaluate the expression.
 393   when (not (null paths)) $ do
 394      ok <- ghciHandle (\e -> do showException e; return Failed) $
 395                 loadModule paths
 396      when (isJust maybe_exprs && failed ok) $
 397         io (exitWith (ExitFailure 1))
 398
 399   -- if verbosity is greater than 0, or we are connected to a
 400   -- terminal, display the prompt in the interactive loop.
 401   is_tty <- io (hIsTerminalDevice stdin)
 402   dflags <- getDynFlags
 403   let show_prompt = verbosity dflags > 0 || is_tty
 404
 405   case maybe_exprs of
 406         Nothing ->
 407           do
 408 #if defined(mingw32_HOST_OS)
 409             -- The win32 Console API mutates the first character of
 410             -- type-ahead when reading from it in a non-buffered manner. Work
 411             -- around this by flushing the input buffer of type-ahead characters,
 412             -- but only if stdin is available.
 413             flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
 414             case flushed of
 415              Left err | isDoesNotExistError err -> return ()
 416                       | otherwise -> io (ioError err)
 417              Right () -> return ()
 418 #endif
 419             -- enter the interactive loop
 420             interactiveLoop is_tty show_prompt
 421         Just exprs -> do
 422             -- just evaluate the expression we were given
 423             enqueueCommands exprs
 424             let handle e = do st <- getGHCiState
 425                                    -- Jump through some hoops to get the
 426                                    -- current progname in the exception text:
 427                                    -- <progname>: <exception>
 428                               io $ withProgName (progname st)
 429                                    -- The "fast exit" part just calls exit()
 430                                    -- directly instead of doing an orderly
 431                                    -- runtime shutdown, otherwise the main
 432                                    -- GHCi thread will complain about being
 433                                    -- interrupted.
 434                                  $ topHandlerFastExit e
 435             runCommands' handle (return Nothing)
 436
 437   -- and finally, exit
 438   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
 439
 440 interactiveLoop :: Bool -> Bool -> GHCi ()
 441 interactiveLoop is_tty show_prompt =
 442   -- Ignore ^C exceptions caught here
 443   ghciHandleDyn (\e -> case e of
 444                         Interrupted -> do
 445 #if defined(mingw32_HOST_OS)
 446                                 io (putStrLn "")
 447 #endif
 448                                 interactiveLoop is_tty show_prompt
 449                         _other      -> return ()) $
 450
 451   ghciUnblock $ do -- unblock necessary if we recursed from the
 452                    -- exception handler above.
 453
 454   -- read commands from stdin
 455 #ifdef USE_READLINE
 456   if (is_tty)
 457         then runCommands readlineLoop
 458         else runCommands (fileLoop stdin show_prompt is_tty)
 459 #else
 460   runCommands (fileLoop stdin show_prompt is_tty)
 461 #endif
 462
 463
 464 -- NOTE: We only read .ghci files if they are owned by the current user,
 465 -- and aren't world writable.  Otherwise, we could be accidentally
 466 -- running code planted by a malicious third party.
 467
 468 -- Furthermore, We only read ./.ghci if . is owned by the current user
 469 -- and isn't writable by anyone else.  I think this is sufficient: we
 470 -- don't need to check .. and ../.. etc. because "."  always refers to
 471 -- the same directory while a process is running.
 472
 473 checkPerms :: String -> IO Bool
 474 #ifdef mingw32_HOST_OS
 475 checkPerms _ =
 476   return True
 477 #else
 478 checkPerms name =
 479   Util.handle (\_ -> return False) $ do
 480      st <- getFileStatus name
 481      me <- getRealUserID
 482      if fileOwner st /= me then do
 483         putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
 484         return False
 485       else do
 486         let mode =  fileMode st
 487         if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
 488            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
 489            then do
 490                putStrLn $ "*** WARNING: " ++ name ++
 491                           " is writable by someone else, IGNORING!"
 492                return False
 493           else return True
 494 #endif
 495
 496 fileLoop :: Handle -> Bool -> Bool -> GHCi (Maybe String)
 497 fileLoop hdl show_prompt is_tty = do
 498    when show_prompt $ do
 499         prompt <- mkPrompt
 500         (io (putStr prompt))
 501    l <- io (IO.try (hGetLine hdl))
 502    case l of
 503         Left e | isEOFError e              -> return Nothing
 504                | InvalidArgument <- etype  -> return Nothing
 505                | otherwise                 -> io (ioError e)
 506                 where etype = ioeGetErrorType e
 507                 -- treat InvalidArgument in the same way as EOF:
 508                 -- this can happen if the user closed stdin, or
 509                 -- perhaps did getContents which closes stdin at
 510                 -- EOF.
 511         Right l -> do
 512                    str <- io $ consoleInputToUnicode is_tty l
 513                    return (Just str)
 514
 515 #ifdef mingw32_HOST_OS
 516 -- Convert the console input into Unicode according to the current code page.
 517 -- The Windows console stores Unicode characters directly, so this is a
 518 -- rather roundabout way of doing things... oh well.
 519 -- See #782, #1483, #1649
 520 consoleInputToUnicode :: Bool -> String -> IO String
 521 consoleInputToUnicode is_tty str
 522   | is_tty = do
 523     cp <- System.Win32.getConsoleCP
 524     System.Win32.stringToUnicode cp str
 525   | otherwise =
 526     decodeStringAsUTF8 str
 527 #else
 528 -- for Unix, assume the input is in UTF-8 and decode it to a Unicode String.
 529 -- See #782.
 530 consoleInputToUnicode :: Bool -> String -> IO String
 531 consoleInputToUnicode _is_tty str = decodeStringAsUTF8 str
 532 #endif
 533
 534 decodeStringAsUTF8 :: String -> IO String
 535 decodeStringAsUTF8 str =
 536   withCStringLen str $ \(cstr,len) ->
 537     utf8DecodeString (castPtr cstr :: Ptr Word8) len
 538
 539 mkPrompt :: GHCi String
 540 mkPrompt = do
 541   session <- getSession
 542   (toplevs,exports) <- io (GHC.getContext session)
 543   resumes <- io $ GHC.getResumeContext session
 544   -- st <- getGHCiState
 545
 546   context_bit <-
 547         case resumes of
 548             [] -> return empty
 549             r:_ -> do
 550                 let ix = GHC.resumeHistoryIx r
 551                 if ix == 0
 552                    then return (brackets (ppr (GHC.resumeSpan r)) <> space)
 553                    else do
 554                         let hist = GHC.resumeHistory r !! (ix-1)
 555                         span <- io$ GHC.getHistorySpan session hist
 556                         return (brackets (ppr (negate ix) <> char ':'
 557                                           <+> ppr span) <> space)
 558   let
 559         dots | _:rs <- resumes, not (null rs) = text "... "
 560              | otherwise = empty
 561
 562
 563
 564         modules_bit =
 565        -- ToDo: maybe...
 566        --  let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
 567        --  hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
 568        --  hsep (map (\m -> char '!'  <> ppr (GHC.moduleName m)) bexports) <+>
 569              hsep (map (\m -> char '*'  <> ppr (GHC.moduleName m)) toplevs) <+>
 570              hsep (map (ppr . GHC.moduleName) exports)
 571
 572         deflt_prompt = dots <> context_bit <> modules_bit
 573
 574         f ('%':'s':xs) = deflt_prompt <> f xs
 575         f ('%':'%':xs) = char '%' <> f xs
 576         f (x:xs) = char x <> f xs
 577         f [] = empty
 578    --
 579   st <- getGHCiState
 580   return (showSDoc (f (prompt st)))
 581
 582
 583 #ifdef USE_READLINE
 584 readlineLoop :: GHCi (Maybe String)
 585 readlineLoop = do
 586    io yield
 587    saveSession -- for use by completion
 588    prompt <- mkPrompt
 589    l <- io (readline prompt `finally` setNonBlockingFD 0)
 590                 -- readline sometimes puts stdin into blocking mode,
 591                 -- so we need to put it back for the IO library
 592    splatSavedSession
 593    case l of
 594         Nothing -> return Nothing
 595         Just l  -> do
 596                    io (addHistory l)
 597                    str <- io $ consoleInputToUnicode True l
 598                    return (Just str)
 599 #endif
 600
 601 queryQueue :: GHCi (Maybe String)
 602 queryQueue = do
 603   st <- getGHCiState
 604   case cmdqueue st of
 605     []   -> return Nothing
 606     c:cs -> do setGHCiState st{ cmdqueue = cs }
 607                return (Just c)
 608
 609 runCommands :: GHCi (Maybe String) -> GHCi ()
 610 runCommands = runCommands' handler
 611
 612 runCommands' :: (Exception -> GHCi Bool) -- Exception handler
 613              -> GHCi (Maybe String) -> GHCi ()
 614 runCommands' eh getCmd = do
 615   mb_cmd <- noSpace queryQueue
 616   mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
 617   case mb_cmd of
 618     Nothing -> return ()
 619     Just c  -> do
 620       b <- ghciHandle eh (doCommand c)
 621       if b then return () else runCommands' eh getCmd
 622   where
 623     noSpace q = q >>= maybe (return Nothing)
 624                             (\c->case removeSpaces c of
 625                                    ""   -> noSpace q
 626                                    ":{" -> multiLineCmd q
 627                                    c    -> return (Just c) )
 628     multiLineCmd q = do
 629       st <- getGHCiState
 630       let p = prompt st
 631       setGHCiState st{ prompt = "%s| " }
 632       mb_cmd <- collectCommand q ""
 633       getGHCiState >>= \st->setGHCiState st{ prompt = p }
 634       return mb_cmd
 635     -- we can't use removeSpaces for the sublines here, so
 636     -- multiline commands are somewhat more brittle against
 637     -- fileformat errors (such as \r in dos input on unix),
 638     -- we get rid of any extra spaces for the ":}" test;
 639     -- we also avoid silent failure if ":}" is not found;
 640     -- and since there is no (?) valid occurrence of \r (as
 641     -- opposed to its String representation, "\r") inside a
 642     -- ghci command, we replace any such with ' ' (argh:-(
 643     collectCommand q c = q >>=
 644       maybe (io (ioError collectError))
 645             (\l->if removeSpaces l == ":}"
 646                  then return (Just $ removeSpaces c)
 647                  else collectCommand q (c++map normSpace l))
 648       where normSpace '\r' = ' '
 649             normSpace   c  = c
 650     -- QUESTION: is userError the one to use here?
 651     collectError = userError "unterminated multiline command :{ .. :}"
 652     doCommand (':' : cmd) = specialCommand cmd
 653     doCommand stmt        = do timeIt $ runStmt stmt GHC.RunToCompletion
 654                                return False
 655
 656 enqueueCommands :: [String] -> GHCi ()
 657 enqueueCommands cmds = do
 658   st <- getGHCiState
 659   setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
 660
 661
 662 runStmt :: String -> SingleStep -> GHCi Bool
 663 runStmt stmt step
 664  | null (filter (not.isSpace) stmt) = return False
 665  | ["import", mod] <- words stmt    = keepGoing setContext ('+':mod)
 666  | otherwise
 667  = do st <- getGHCiState
 668       session <- getSession
 669       result <- io $ withProgName (progname st) $ withArgs (args st) $
 670                      GHC.runStmt session stmt step
 671       afterRunStmt (const True) result
 672
 673
 674 --afterRunStmt :: GHC.RunResult -> GHCi Bool
 675                                  -- False <=> the statement failed to compile
 676 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
 677 afterRunStmt _ (GHC.RunException e) = throw e
 678 afterRunStmt step_here run_result = do
 679   session     <- getSession
 680   resumes <- io $ GHC.getResumeContext session
 681   case run_result of
 682      GHC.RunOk names -> do
 683         show_types <- isOptionSet ShowType
 684         when show_types $ printTypeOfNames session names
 685      GHC.RunBreak _ names mb_info
 686          | isNothing  mb_info ||
 687            step_here (GHC.resumeSpan $ head resumes) -> do
 688                printForUser $ ptext SLIT("Stopped at") <+>
 689                        ppr (GHC.resumeSpan $ head resumes)
 690 --               printTypeOfNames session names
 691                let namesSorted = sortBy compareNames names
 692                tythings <- catMaybes `liftM`
 693                               io (mapM (GHC.lookupName session) namesSorted)
 694                docs <- io$ pprTypeAndContents session [id | AnId id <- tythings]
 695                printForUserPartWay docs
 696                maybe (return ()) runBreakCmd mb_info
 697                -- run the command set with ":set stop <cmd>"
 698                st <- getGHCiState
 699                enqueueCommands [stop st]
 700                return ()
 701          | otherwise -> io(GHC.resume session GHC.SingleStep) >>=
 702                         afterRunStmt step_here >> return ()
 703      _ -> return ()
 704
 705   flushInterpBuffers
 706   io installSignalHandlers
 707   b <- isOptionSet RevertCAFs
 708   io (when b revertCAFs)
 709
 710   return (case run_result of GHC.RunOk _ -> True; _ -> False)
 711
 712 runBreakCmd :: GHC.BreakInfo -> GHCi ()
 713 runBreakCmd info = do
 714   let mod = GHC.breakInfo_module info
 715       nm  = GHC.breakInfo_number info
 716   st <- getGHCiState
 717   case  [ loc | (_,loc) <- breaks st,
 718                 breakModule loc == mod, breakTick loc == nm ] of
 719         []  -> return ()
 720         loc:_ | null cmd  -> return ()
 721               | otherwise -> do enqueueCommands [cmd]; return ()
 722               where cmd = onBreakCmd loc
 723
 724 printTypeOfNames :: Session -> [Name] -> GHCi ()
 725 printTypeOfNames session names
 726  = mapM_ (printTypeOfName session) $ sortBy compareNames names
 727
 728 compareNames :: Name -> Name -> Ordering
 729 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
 730     where compareWith n = (getOccString n, getSrcSpan n)
 731
 732 printTypeOfName :: Session -> Name -> GHCi ()
 733 printTypeOfName session n
 734    = do maybe_tything <- io (GHC.lookupName session n)
 735         case maybe_tything of
 736             Nothing    -> return ()
 737             Just thing -> printTyThing thing
 738
 739
 740 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
 741
 742 specialCommand :: String -> GHCi Bool
 743 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 744 specialCommand str = do
 745   let (cmd,rest) = break isSpace str
 746   maybe_cmd <- lookupCommand cmd
 747   case maybe_cmd of
 748     GotCommand (_,f,_,_) -> f (dropWhile isSpace rest)
 749     BadCommand ->
 750       do io $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
 751                            ++ shortHelpText)
 752          return False
 753     NoLastCommand ->
 754       do io $ hPutStr stdout ("there is no last command to perform\n"
 755                            ++ shortHelpText)
 756          return False
 757
 758 lookupCommand :: String -> GHCi (MaybeCommand)
 759 lookupCommand "" = do
 760   st <- getGHCiState
 761   case last_command st of
 762       Just c -> return $ GotCommand c
 763       Nothing -> return NoLastCommand
 764 lookupCommand str = do
 765   mc <- io $ lookupCommand' str
 766   st <- getGHCiState
 767   setGHCiState st{ last_command = mc }
 768   return $ case mc of
 769            Just c -> GotCommand c
 770            Nothing -> BadCommand
 771
 772 lookupCommand' :: String -> IO (Maybe Command)
 773 lookupCommand' str = do
 774   macros <- readIORef macros_ref
 775   let cmds = builtin_commands ++ macros
 776   -- look for exact match first, then the first prefix match
 777   return $ case [ c | c <- cmds, str == cmdName c ] of
 778            c:_ -> Just c
 779            [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
 780                  [] -> Nothing
 781                  c:_ -> Just c
 782
 783 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
 784 getCurrentBreakSpan = do
 785   session <- getSession
 786   resumes <- io $ GHC.getResumeContext session
 787   case resumes of
 788     [] -> return Nothing
 789     (r:_) -> do
 790         let ix = GHC.resumeHistoryIx r
 791         if ix == 0
 792            then return (Just (GHC.resumeSpan r))
 793            else do
 794                 let hist = GHC.resumeHistory r !! (ix-1)
 795                 span <- io $ GHC.getHistorySpan session hist
 796                 return (Just span)
 797
 798 getCurrentBreakModule :: GHCi (Maybe Module)
 799 getCurrentBreakModule = do
 800   session <- getSession
 801   resumes <- io $ GHC.getResumeContext session
 802   case resumes of
 803     [] -> return Nothing
 804     (r:_) -> do
 805         let ix = GHC.resumeHistoryIx r
 806         if ix == 0
 807            then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
 808            else do
 809                 let hist = GHC.resumeHistory r !! (ix-1)
 810                 return $ Just $ GHC.getHistoryModule  hist
 811
 812 -----------------------------------------------------------------------------
 813 -- Commands
 814
 815 noArgs :: GHCi () -> String -> GHCi ()
 816 noArgs m "" = m
 817 noArgs _ _  = io $ putStrLn "This command takes no arguments"
 818
 819 help :: String -> GHCi ()
 820 help _ = io (putStr helpText)
 821
 822 info :: String -> GHCi ()
 823 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
 824 info s  = do { let names = words s
 825              ; session <- getSession
 826              ; dflags <- getDynFlags
 827              ; let pefas = dopt Opt_PrintExplicitForalls dflags
 828              ; mapM_ (infoThing pefas session) names }
 829   where
 830     infoThing pefas session str = io $ do
 831         names     <- GHC.parseName session str
 832         mb_stuffs <- mapM (GHC.getInfo session) names
 833         let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
 834         unqual <- GHC.getPrintUnqual session
 835         putStrLn (showSDocForUser unqual $
 836                    vcat (intersperse (text "") $
 837                          map (pprInfo pefas) filtered))
 838
 839   -- Filter out names whose parent is also there Good
 840   -- example is '[]', which is both a type and data
 841   -- constructor in the same type
 842 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
 843 filterOutChildren get_thing xs
 844   = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
 845   where
 846     implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
 847
 848 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
 849 pprInfo pefas (thing, fixity, insts)
 850   =  pprTyThingInContextLoc pefas thing
 851   $$ show_fixity fixity
 852   $$ vcat (map GHC.pprInstance insts)
 853   where
 854     show_fixity fix
 855         | fix == GHC.defaultFixity = empty
 856         | otherwise                = ppr fix <+> ppr (GHC.getName thing)
 857
 858 runMain :: String -> GHCi ()
 859 runMain s = case toArgs s of
 860             Left err   -> io (hPutStrLn stderr err)
 861             Right args ->
 862                 do dflags <- getDynFlags
 863                    case mainFunIs dflags of
 864                        Nothing -> doWithArgs args "main"
 865                        Just f  -> doWithArgs args f
 866
 867 runRun :: String -> GHCi ()
 868 runRun s = case toCmdArgs s of
 869            Left err          -> io (hPutStrLn stderr err)
 870            Right (cmd, args) -> doWithArgs args cmd
 871
 872 doWithArgs :: [String] -> String -> GHCi ()
 873 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
 874                                        show args ++ " (" ++ cmd ++ ")"]
 875
 876 addModule :: [FilePath] -> GHCi ()
 877 addModule files = do
 878   io (revertCAFs)                       -- always revert CAFs on load/add.
 879   files <- mapM expandPath files
 880   targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
 881   session <- getSession
 882   io (mapM_ (GHC.addTarget session) targets)
 883   prev_context <- io $ GHC.getContext session
 884   ok <- io (GHC.load session LoadAllTargets)
 885   afterLoad ok session False prev_context
 886
 887 changeDirectory :: String -> GHCi ()
 888 changeDirectory "" = do
 889   -- :cd on its own changes to the user's home directory
 890   either_dir <- io (IO.try getHomeDirectory)
 891   case either_dir of
 892      Left _e -> return ()
 893      Right dir -> changeDirectory dir
 894 changeDirectory dir = do
 895   session <- getSession
 896   graph <- io (GHC.getModuleGraph session)
 897   when (not (null graph)) $
 898         io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
 899   prev_context <- io $ GHC.getContext session
 900   io (GHC.setTargets session [])
 901   io (GHC.load session LoadAllTargets)
 902   setContextAfterLoad session prev_context False []
 903   io (GHC.workingDirectoryChanged session)
 904   dir <- expandPath dir
 905   io (setCurrentDirectory dir)
 906
 907 editFile :: String -> GHCi ()
 908 editFile str =
 909   do file <- if null str then chooseEditFile else return str
 910      st <- getGHCiState
 911      let cmd = editor st
 912      when (null cmd)
 913        $ throwDyn (CmdLineError "editor not set, use :set editor")
 914      io $ system (cmd ++ ' ':file)
 915      return ()
 916
 917 -- The user didn't specify a file so we pick one for them.
 918 -- Our strategy is to pick the first module that failed to load,
 919 -- or otherwise the first target.
 920 --
 921 -- XXX: Can we figure out what happened if the depndecy analysis fails
 922 --      (e.g., because the porgrammeer mistyped the name of a module)?
 923 -- XXX: Can we figure out the location of an error to pass to the editor?
 924 -- XXX: if we could figure out the list of errors that occured during the
 925 -- last load/reaload, then we could start the editor focused on the first
 926 -- of those.
 927 chooseEditFile :: GHCi String
 928 chooseEditFile =
 929   do session <- getSession
 930      let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
 931
 932      graph <- io (GHC.getModuleGraph session)
 933      failed_graph <- filterM hasFailed graph
 934      let order g  = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
 935          pick xs  = case xs of
 936                       x : _ -> GHC.ml_hs_file (GHC.ms_location x)
 937                       _     -> Nothing
 938
 939      case pick (order failed_graph) of
 940        Just file -> return file
 941        Nothing   ->
 942          do targets <- io (GHC.getTargets session)
 943             case msum (map fromTarget targets) of
 944               Just file -> return file
 945               Nothing   -> throwDyn (CmdLineError "No files to edit.")
 946
 947   where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
 948         fromTarget _ = Nothing -- when would we get a module target?
 949
 950 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
 951 defineMacro overwrite s = do
 952   let (macro_name, definition) = break isSpace s
 953   macros <- io (readIORef macros_ref)
 954   let defined = map cmdName macros
 955   if (null macro_name)
 956         then if null defined
 957                 then io $ putStrLn "no macros defined"
 958                 else io $ putStr ("the following macros are defined:\n" ++
 959                                   unlines defined)
 960         else do
 961   if (not overwrite && macro_name `elem` defined)
 962         then throwDyn (CmdLineError
 963                 ("macro '" ++ macro_name ++ "' is already defined"))
 964         else do
 965
 966   let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
 967
 968   -- give the expression a type signature, so we can be sure we're getting
 969   -- something of the right type.
 970   let new_expr = '(' : definition ++ ") :: String -> IO String"
 971
 972   -- compile the expression
 973   cms <- getSession
 974   maybe_hv <- io (GHC.compileExpr cms new_expr)
 975   case maybe_hv of
 976      Nothing -> return ()
 977      Just hv -> io (writeIORef macros_ref --
 978                     (filtered ++ [(macro_name, runMacro hv, Nothing, completeNone)]))
 979
 980 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
 981 runMacro fun s = do
 982   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 983   enqueueCommands (lines str)
 984   return False
 985
 986 undefineMacro :: String -> GHCi ()
 987 undefineMacro str = mapM_ undef (words str)
 988  where undef macro_name = do
 989         cmds <- io (readIORef macros_ref)
 990         if (macro_name `notElem` map cmdName cmds)
 991            then throwDyn (CmdLineError
 992                 ("macro '" ++ macro_name ++ "' is not defined"))
 993            else do
 994             io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
 995
 996 cmdCmd :: String -> GHCi ()
 997 cmdCmd str = do
 998   let expr = '(' : str ++ ") :: IO String"
 999   session <- getSession
1000   maybe_hv <- io (GHC.compileExpr session expr)
1001   case maybe_hv of
1002     Nothing -> return ()
1003     Just hv -> do
1004         cmds <- io $ (unsafeCoerce# hv :: IO String)
1005         enqueueCommands (lines cmds)
1006         return ()
1007
1008 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
1009 loadModule fs = timeIt (loadModule' fs)
1010
1011 loadModule_ :: [FilePath] -> GHCi ()
1012 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
1013
1014 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
1015 loadModule' files = do
1016   session <- getSession
1017   prev_context <- io $ GHC.getContext session
1018
1019   -- unload first
1020   discardActiveBreakPoints
1021   io (GHC.setTargets session [])
1022   io (GHC.load session LoadAllTargets)
1023
1024   -- expand tildes
1025   let (filenames, phases) = unzip files
1026   exp_filenames <- mapM expandPath filenames
1027   let files' = zip exp_filenames phases
1028   targets <- io (mapM (uncurry GHC.guessTarget) files')
1029
1030   -- NOTE: we used to do the dependency anal first, so that if it
1031   -- fails we didn't throw away the current set of modules.  This would
1032   -- require some re-working of the GHC interface, so we'll leave it
1033   -- as a ToDo for now.
1034
1035   io (GHC.setTargets session targets)
1036   doLoad session False prev_context LoadAllTargets
1037
1038 checkModule :: String -> GHCi ()
1039 checkModule m = do
1040   let modl = GHC.mkModuleName m
1041   session <- getSession
1042   prev_context <- io $ GHC.getContext session
1043   result <- io (GHC.checkModule session modl False)
1044   case result of
1045     Nothing -> io $ putStrLn "Nothing"
1046     Just r  -> io $ putStrLn (showSDoc (
1047         case GHC.checkedModuleInfo r of
1048            Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1049                 let
1050                     (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1051                 in
1052                         (text "global names: " <+> ppr global) $$
1053                         (text "local  names: " <+> ppr local)
1054            _ -> empty))
1055   afterLoad (successIf (isJust result)) session False prev_context
1056
1057 reloadModule :: String -> GHCi ()
1058 reloadModule m = do
1059   session <- getSession
1060   prev_context <- io $ GHC.getContext session
1061   doLoad session True prev_context $
1062         if null m then LoadAllTargets
1063                   else LoadUpTo (GHC.mkModuleName m)
1064   return ()
1065
1066 doLoad :: Session -> Bool -> ([Module],[Module]) -> LoadHowMuch -> GHCi SuccessFlag
1067 doLoad session retain_context prev_context howmuch = do
1068   -- turn off breakpoints before we load: we can't turn them off later, because
1069   -- the ModBreaks will have gone away.
1070   discardActiveBreakPoints
1071   ok <- io (GHC.load session howmuch)
1072   afterLoad ok session retain_context prev_context
1073   return ok
1074
1075 afterLoad :: SuccessFlag -> Session -> Bool -> ([Module],[Module]) -> GHCi ()
1076 afterLoad ok session retain_context prev_context = do
1077   io (revertCAFs)  -- always revert CAFs on load.
1078   discardTickArrays
1079   loaded_mod_summaries <- getLoadedModules session
1080   let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1081       loaded_mod_names = map GHC.moduleName loaded_mods
1082   modulesLoadedMsg ok loaded_mod_names
1083
1084   setContextAfterLoad session prev_context retain_context loaded_mod_summaries
1085
1086
1087 setContextAfterLoad :: Session -> ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi ()
1088 setContextAfterLoad session prev keep_ctxt [] = do
1089   prel_mod <- getPrelude
1090   setContextKeepingPackageModules session prev keep_ctxt ([], [prel_mod])
1091 setContextAfterLoad session prev keep_ctxt ms = do
1092   -- load a target if one is available, otherwise load the topmost module.
1093   targets <- io (GHC.getTargets session)
1094   case [ m | Just m <- map (findTarget ms) targets ] of
1095         []    ->
1096           let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1097           load_this (last graph')
1098         (m:_) ->
1099           load_this m
1100  where
1101    findTarget ms t
1102     = case filter (`matches` t) ms of
1103         []    -> Nothing
1104         (m:_) -> Just m
1105
1106    summary `matches` Target (TargetModule m) _
1107         = GHC.ms_mod_name summary == m
1108    summary `matches` Target (TargetFile f _) _
1109         | Just f' <- GHC.ml_hs_file (GHC.ms_location summary)   = f == f'
1110    _ `matches` _
1111         = False
1112
1113    load_this summary | m <- GHC.ms_mod summary = do
1114         b <- io (GHC.moduleIsInterpreted session m)
1115         if b then setContextKeepingPackageModules session prev keep_ctxt ([m], [])
1116              else do
1117                 prel_mod <- getPrelude
1118                 setContextKeepingPackageModules session prev keep_ctxt ([],[prel_mod,m])
1119
1120 -- | Keep any package modules (except Prelude) when changing the context.
1121 setContextKeepingPackageModules
1122         :: Session
1123         -> ([Module],[Module])          -- previous context
1124         -> Bool                         -- re-execute :module commands
1125         -> ([Module],[Module])          -- new context
1126         -> GHCi ()
1127 setContextKeepingPackageModules session prev_context keep_ctxt (as,bs) = do
1128   let (_,bs0) = prev_context
1129   prel_mod <- getPrelude
1130   let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1131   let bs1 = if null as then nub (prel_mod : bs) else bs
1132   io $ GHC.setContext session as (nub (bs1 ++ pkg_modules))
1133   if keep_ctxt
1134      then do
1135           st <- getGHCiState
1136           mapM_ (playCtxtCmd False) (remembered_ctx st)
1137      else do
1138           st <- getGHCiState
1139           setGHCiState st{ remembered_ctx = [] }
1140
1141 isHomeModule :: Module -> Bool
1142 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1143
1144 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
1145 modulesLoadedMsg ok mods = do
1146   dflags <- getDynFlags
1147   when (verbosity dflags > 0) $ do
1148    let mod_commas
1149         | null mods = text "none."
1150         | otherwise = hsep (
1151             punctuate comma (map ppr mods)) <> text "."
1152    case ok of
1153     Failed ->
1154        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
1155     Succeeded  ->
1156        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
1157
1158
1159 typeOfExpr :: String -> GHCi ()
1160 typeOfExpr str
1161   = do cms <- getSession
1162        maybe_ty <- io (GHC.exprType cms str)
1163        case maybe_ty of
1164           Nothing -> return ()
1165           Just ty -> do dflags <- getDynFlags
1166                         let pefas = dopt Opt_PrintExplicitForalls dflags
1167                         printForUser $ text str <+> dcolon
1168                                         <+> pprTypeForUser pefas ty
1169
1170 kindOfType :: String -> GHCi ()
1171 kindOfType str
1172   = do cms <- getSession
1173        maybe_ty <- io (GHC.typeKind cms str)
1174        case maybe_ty of
1175           Nothing    -> return ()
1176           Just ty    -> printForUser $ text str <+> dcolon <+> ppr ty
1177
1178 quit :: String -> GHCi Bool
1179 quit _ = return True
1180
1181 shellEscape :: String -> GHCi Bool
1182 shellEscape str = io (system str >> return False)
1183
1184 -----------------------------------------------------------------------------
1185 -- Browsing a module's contents
1186
1187 browseCmd :: Bool -> String -> GHCi ()
1188 browseCmd bang m =
1189   case words m of
1190     ['*':s] | looksLikeModuleName s -> do
1191         m <-  wantInterpretedModule s
1192         browseModule bang m False
1193     [s] | looksLikeModuleName s -> do
1194         m <- lookupModule s
1195         browseModule bang m True
1196     [] -> do
1197         s <- getSession
1198         (as,bs) <- io $ GHC.getContext s
1199                 -- Guess which module the user wants to browse.  Pick
1200                 -- modules that are interpreted first.  The most
1201                 -- recently-added module occurs last, it seems.
1202         case (as,bs) of
1203           (as@(_:_), _)   -> browseModule bang (last as) True
1204           ([],  bs@(_:_)) -> browseModule bang (last bs) True
1205           ([],  [])  -> throwDyn (CmdLineError ":browse: no current module")
1206     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
1207
1208 -- without bang, show items in context of their parents and omit children
1209 -- with bang, show class methods and data constructors separately, and
1210 --            indicate import modules, to aid qualifying unqualified names
1211 -- with sorted, sort items alphabetically
1212 browseModule :: Bool -> Module -> Bool -> GHCi ()
1213 browseModule bang modl exports_only = do
1214   s <- getSession
1215   -- :browse! reports qualifiers wrt current context
1216   current_unqual <- io (GHC.getPrintUnqual s)
1217   -- Temporarily set the context to the module we're interested in,
1218   -- just so we can get an appropriate PrintUnqualified
1219   (as,bs) <- io (GHC.getContext s)
1220   prel_mod <- getPrelude
1221   io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1222                       else GHC.setContext s [modl] [])
1223   target_unqual <- io (GHC.getPrintUnqual s)
1224   io (GHC.setContext s as bs)
1225
1226   let unqual = if bang then current_unqual else target_unqual
1227
1228   mb_mod_info <- io $ GHC.getModuleInfo s modl
1229   case mb_mod_info of
1230     Nothing -> throwDyn (CmdLineError ("unknown module: " ++
1231                                 GHC.moduleNameString (GHC.moduleName modl)))
1232     Just mod_info -> do
1233         dflags <- getDynFlags
1234         let names
1235                | exports_only = GHC.modInfoExports mod_info
1236                | otherwise    = GHC.modInfoTopLevelScope mod_info
1237                                 `orElse` []
1238
1239                 -- sort alphabetically name, but putting
1240                 -- locally-defined identifiers first.
1241                 -- We would like to improve this; see #1799.
1242             sorted_names = loc_sort local ++ occ_sort external
1243                 where
1244                 (local,external) = partition ((==modl) . nameModule) names
1245                 occ_sort = sortBy (compare `on` nameOccName)
1246                 -- try to sort by src location.  If the first name in
1247                 -- our list has a good source location, then they all should.
1248                 loc_sort names
1249                       | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1250                       = sortBy (compare `on` nameSrcSpan) names
1251                       | otherwise
1252                       = occ_sort names
1253
1254         mb_things <- io $ mapM (GHC.lookupName s) sorted_names
1255         let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1256
1257         rdr_env <- io $ GHC.getGRE s
1258
1259         let pefas              = dopt Opt_PrintExplicitForalls dflags
1260             things | bang      = catMaybes mb_things
1261                    | otherwise = filtered_things
1262             pretty | bang      = pprTyThing
1263                    | otherwise = pprTyThingInContext
1264
1265             labels  [] = text "-- not currently imported"
1266             labels  l  = text $ intercalate "\n" $ map qualifier l
1267             qualifier  = maybe "-- defined locally"
1268                              (("-- imported via "++) . intercalate ", "
1269                                . map GHC.moduleNameString)
1270             importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1271             modNames   = map (importInfo . GHC.getName) things
1272
1273             -- annotate groups of imports with their import modules
1274             -- the default ordering is somewhat arbitrary, so we group
1275             -- by header and sort groups; the names themselves should
1276             -- really come in order of source appearance.. (trac #1799)
1277             annotate mts = concatMap (\(m,ts)->labels m:ts)
1278                          $ sortBy cmpQualifiers $ group mts
1279               where cmpQualifiers =
1280                       compare `on` (map (fmap (map moduleNameFS)) . fst)
1281             group []            = []
1282             group mts@((m,_):_) = (m,map snd g) : group ng
1283               where (g,ng) = partition ((==m).fst) mts
1284
1285         let prettyThings = map (pretty pefas) things
1286             prettyThings' | bang      = annotate $ zip modNames prettyThings
1287                           | otherwise = prettyThings
1288         io (putStrLn $ showSDocForUser unqual (vcat prettyThings'))
1289         -- ToDo: modInfoInstances currently throws an exception for
1290         -- package modules.  When it works, we can do this:
1291         --        $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1292
1293 -----------------------------------------------------------------------------
1294 -- Setting the module context
1295
1296 setContext :: String -> GHCi ()
1297 setContext str
1298   | all sensible strs = do
1299        playCtxtCmd True (cmd, as, bs)
1300        st <- getGHCiState
1301        setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] }
1302   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
1303   where
1304     (cmd, strs, as, bs) =
1305         case str of
1306                 '+':stuff -> rest AddModules stuff
1307                 '-':stuff -> rest RemModules stuff
1308                 stuff     -> rest SetContext stuff
1309
1310     rest cmd stuff = (cmd, strs, as, bs)
1311        where strs = words stuff
1312              (as,bs) = partitionWith starred strs
1313
1314     sensible ('*':m) = looksLikeModuleName m
1315     sensible m       = looksLikeModuleName m
1316
1317     starred ('*':m) = Left m
1318     starred m       = Right m
1319
1320 playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi ()
1321 playCtxtCmd fail (cmd, as, bs)
1322   = do
1323     s <- getSession
1324     (as',bs') <- do_checks fail
1325     (prev_as,prev_bs) <- io $ GHC.getContext s
1326     (new_as, new_bs) <-
1327       case cmd of
1328         SetContext -> do
1329           prel_mod <- getPrelude
1330           let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs'
1331                                                           else bs'
1332           return (as',bs'')
1333         AddModules -> do
1334           let as_to_add = as' \\ (prev_as ++ prev_bs)
1335               bs_to_add = bs' \\ (prev_as ++ prev_bs)
1336           return (prev_as ++ as_to_add, prev_bs ++ bs_to_add)
1337         RemModules -> do
1338           let new_as = prev_as \\ (as' ++ bs')
1339               new_bs = prev_bs \\ (as' ++ bs')
1340           return (new_as, new_bs)
1341     io $ GHC.setContext s new_as new_bs
1342   where
1343     do_checks True = do
1344       as' <- mapM wantInterpretedModule as
1345       bs' <- mapM lookupModule bs
1346       return (as',bs')
1347     do_checks False = do
1348       as' <- mapM (trymaybe . wantInterpretedModule) as
1349       bs' <- mapM (trymaybe . lookupModule) bs
1350       return (catMaybes as', catMaybes bs')
1351
1352     trymaybe m = do
1353         r <- ghciTry m
1354         case r of
1355           Left _  -> return Nothing
1356           Right a -> return (Just a)
1357
1358 ----------------------------------------------------------------------------
1359 -- Code for `:set'
1360
1361 -- set options in the interpreter.  Syntax is exactly the same as the
1362 -- ghc command line, except that certain options aren't available (-C,
1363 -- -E etc.)
1364 --
1365 -- This is pretty fragile: most options won't work as expected.  ToDo:
1366 -- figure out which ones & disallow them.
1367
1368 setCmd :: String -> GHCi ()
1369 setCmd ""
1370   = do st <- getGHCiState
1371        let opts = options st
1372        io $ putStrLn (showSDoc (
1373               text "options currently set: " <>
1374               if null opts
1375                    then text "none."
1376                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1377            ))
1378        dflags <- getDynFlags
1379        io $ putStrLn (showSDoc (
1380           vcat (text "GHCi-specific dynamic flag settings:"
1381                :map (flagSetting dflags) ghciFlags)
1382           ))
1383        io $ putStrLn (showSDoc (
1384           vcat (text "other dynamic, non-language, flag settings:"
1385                :map (flagSetting dflags) nonLanguageDynFlags)
1386           ))
1387   where flagSetting dflags (str,f)
1388           | dopt f dflags = text "  " <> text "-f"    <> text str
1389           | otherwise     = text "  " <> text "-fno-" <> text str
1390         (ghciFlags,others)  = partition (\(_,f)->f `elem` flags)
1391                                         DynFlags.fFlags
1392         nonLanguageDynFlags = filter (\(_,f)->not $ f `elem` map snd xFlags)
1393                                      others
1394         flags = [Opt_PrintExplicitForalls
1395                 ,Opt_PrintBindResult
1396                 ,Opt_BreakOnException
1397                 ,Opt_BreakOnError
1398                 ,Opt_PrintEvldWithShow
1399                 ]
1400 setCmd str
1401   = case getCmd str of
1402     Right ("args",   rest) ->
1403         case toArgs rest of
1404             Left err -> io (hPutStrLn stderr err)
1405             Right args -> setArgs args
1406     Right ("prog",   rest) ->
1407         case toArgs rest of
1408             Right [prog] -> setProg prog
1409             _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")
1410     Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1411     Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1412     Right ("stop",   rest) -> setStop   $ dropWhile isSpace rest
1413     _ -> case toArgs str of
1414          Left err -> io (hPutStrLn stderr err)
1415          Right wds -> setOptions wds
1416
1417 setArgs, setOptions :: [String] -> GHCi ()
1418 setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
1419
1420 setArgs args = do
1421   st <- getGHCiState
1422   setGHCiState st{ args = args }
1423
1424 setProg prog = do
1425   st <- getGHCiState
1426   setGHCiState st{ progname = prog }
1427
1428 setEditor cmd = do
1429   st <- getGHCiState
1430   setGHCiState st{ editor = cmd }
1431
1432 setStop str@(c:_) | isDigit c
1433   = do let (nm_str,rest) = break (not.isDigit) str
1434            nm = read nm_str
1435        st <- getGHCiState
1436        let old_breaks = breaks st
1437        if all ((/= nm) . fst) old_breaks
1438               then printForUser (text "Breakpoint" <+> ppr nm <+>
1439                                  text "does not exist")
1440               else do
1441        let new_breaks = map fn old_breaks
1442            fn (i,loc) | i == nm   = (i,loc { onBreakCmd = dropWhile isSpace rest })
1443                       | otherwise = (i,loc)
1444        setGHCiState st{ breaks = new_breaks }
1445 setStop cmd = do
1446   st <- getGHCiState
1447   setGHCiState st{ stop = cmd }
1448
1449 setPrompt value = do
1450   st <- getGHCiState
1451   if null value
1452       then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1453       else setGHCiState st{ prompt = remQuotes value }
1454   where
1455      remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1456      remQuotes x = x
1457
1458 setOptions wds =
1459    do -- first, deal with the GHCi opts (+s, +t, etc.)
1460       let (plus_opts, minus_opts)  = partitionWith isPlus wds
1461       mapM_ setOpt plus_opts
1462       -- then, dynamic flags
1463       newDynFlags minus_opts
1464
1465 newDynFlags :: [String] -> GHCi ()
1466 newDynFlags minus_opts = do
1467       dflags <- getDynFlags
1468       let pkg_flags = packageFlags dflags
1469       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1470
1471       if (not (null leftovers))
1472                 then throwDyn (CmdLineError ("unrecognised flags: " ++
1473                                                 unwords leftovers))
1474                 else return ()
1475
1476       new_pkgs <- setDynFlags dflags'
1477
1478       -- if the package flags changed, we should reset the context
1479       -- and link the new packages.
1480       dflags <- getDynFlags
1481       when (packageFlags dflags /= pkg_flags) $ do
1482         io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1483         session <- getSession
1484         io (GHC.setTargets session [])
1485         io (GHC.load session LoadAllTargets)
1486         io (linkPackages dflags new_pkgs)
1487         -- package flags changed, we can't re-use any of the old context
1488         setContextAfterLoad session ([],[]) False []
1489       return ()
1490
1491
1492 unsetOptions :: String -> GHCi ()
1493 unsetOptions str
1494   = do -- first, deal with the GHCi opts (+s, +t, etc.)
1495        let opts = words str
1496            (minus_opts, rest1) = partition isMinus opts
1497            (plus_opts, rest2)  = partitionWith isPlus rest1
1498
1499        if (not (null rest2))
1500           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1501           else do
1502
1503        mapM_ unsetOpt plus_opts
1504
1505        let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1506            no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1507
1508        no_flags <- mapM no_flag minus_opts
1509        newDynFlags no_flags
1510
1511 isMinus :: String -> Bool
1512 isMinus ('-':_) = True
1513 isMinus _ = False
1514
1515 isPlus :: String -> Either String String
1516 isPlus ('+':opt) = Left opt
1517 isPlus other     = Right other
1518
1519 setOpt, unsetOpt :: String -> GHCi ()
1520
1521 setOpt str
1522   = case strToGHCiOpt str of
1523         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1524         Just o  -> setOption o
1525
1526 unsetOpt str
1527   = case strToGHCiOpt str of
1528         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1529         Just o  -> unsetOption o
1530
1531 strToGHCiOpt :: String -> (Maybe GHCiOption)
1532 strToGHCiOpt "s" = Just ShowTiming
1533 strToGHCiOpt "t" = Just ShowType
1534 strToGHCiOpt "r" = Just RevertCAFs
1535 strToGHCiOpt _   = Nothing
1536
1537 optToStr :: GHCiOption -> String
1538 optToStr ShowTiming = "s"
1539 optToStr ShowType   = "t"
1540 optToStr RevertCAFs = "r"
1541
1542 -- ---------------------------------------------------------------------------
1543 -- code for `:show'
1544
1545 showCmd :: String -> GHCi ()
1546 showCmd str = do
1547   st <- getGHCiState
1548   case words str of
1549         ["args"]     -> io $ putStrLn (show (args st))
1550         ["prog"]     -> io $ putStrLn (show (progname st))
1551         ["prompt"]   -> io $ putStrLn (show (prompt st))
1552         ["editor"]   -> io $ putStrLn (show (editor st))
1553         ["stop"]     -> io $ putStrLn (show (stop st))
1554         ["modules" ] -> showModules
1555         ["bindings"] -> showBindings
1556         ["linker"]   -> io showLinkerState
1557         ["breaks"]   -> showBkptTable
1558         ["context"]  -> showContext
1559         ["packages"]  -> showPackages
1560         ["languages"]  -> showLanguages
1561         _ -> throwDyn (CmdLineError ("syntax:  :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
1562                                      "               | breaks | context | packages | languages ]"))
1563
1564 showModules :: GHCi ()
1565 showModules = do
1566   session <- getSession
1567   loaded_mods <- getLoadedModules session
1568         -- we want *loaded* modules only, see #1734
1569   let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m)
1570   mapM_ show_one loaded_mods
1571
1572 getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary]
1573 getLoadedModules session = do
1574   graph <- io (GHC.getModuleGraph session)
1575   filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
1576
1577 showBindings :: GHCi ()
1578 showBindings = do
1579   s <- getSession
1580   bindings <- io (GHC.getBindings s)
1581   docs     <- io$ pprTypeAndContents s
1582                   [ id | AnId id <- sortBy compareTyThings bindings]
1583   printForUserPartWay docs
1584
1585 compareTyThings :: TyThing -> TyThing -> Ordering
1586 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1587
1588 printTyThing :: TyThing -> GHCi ()
1589 printTyThing tyth = do dflags <- getDynFlags
1590                        let pefas = dopt Opt_PrintExplicitForalls dflags
1591                        printForUser (pprTyThing pefas tyth)
1592
1593 showBkptTable :: GHCi ()
1594 showBkptTable = do
1595   st <- getGHCiState
1596   printForUser $ prettyLocations (breaks st)
1597
1598 showContext :: GHCi ()
1599 showContext = do
1600    session <- getSession
1601    resumes <- io $ GHC.getResumeContext session
1602    printForUser $ vcat (map pp_resume (reverse resumes))
1603   where
1604    pp_resume resume =
1605         ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1606         $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1607
1608 showPackages :: GHCi ()
1609 showPackages = do
1610   pkg_flags <- fmap packageFlags getDynFlags
1611   io $ putStrLn $ showSDoc $ vcat $
1612     text ("active package flags:"++if null pkg_flags then " none" else "")
1613     : map showFlag pkg_flags
1614   pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1615   io $ putStrLn $ showSDoc $ vcat $
1616     text "packages currently loaded:"
1617     : map (nest 2 . text . packageIdString) pkg_ids
1618   where showFlag (ExposePackage p) = text $ "  -package " ++ p
1619         showFlag (HidePackage p)   = text $ "  -hide-package " ++ p
1620         showFlag (IgnorePackage p) = text $ "  -ignore-package " ++ p
1621
1622 showLanguages :: GHCi ()
1623 showLanguages = do
1624    dflags <- getDynFlags
1625    io $ putStrLn $ showSDoc $ vcat $
1626       text "active language flags:" :
1627       [text ("  -X" ++ str) | (str,f) <- DynFlags.xFlags, dopt f dflags]
1628
1629 -- -----------------------------------------------------------------------------
1630 -- Completion
1631
1632 completeNone :: String -> IO [String]
1633 completeNone _w = return []
1634
1635 completeMacro, completeIdentifier, completeModule,
1636     completeHomeModule, completeSetOptions, completeFilename,
1637     completeHomeModuleOrFile
1638     :: String -> IO [String]
1639
1640 #ifdef USE_READLINE
1641 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1642 completeWord w start end = do
1643   line <- Readline.getLineBuffer
1644   let line_words = words (dropWhile isSpace line)
1645   case w of
1646      ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1647      _other
1648         | ((':':c) : _) <- line_words -> do
1649            completionVars <- lookupCompletionVars c
1650            case completionVars of
1651              (Nothing,complete) -> wrapCompleter complete w
1652              (Just breakChars,complete)
1653                     -> let (n,w') = selectWord
1654                                         (words' (`elem` breakChars) 0 line)
1655                            complete' w = do rets <- complete w
1656                                             return (map (drop n) rets)
1657                        in wrapCompleter complete' w'
1658         | ("import" : _) <- line_words ->
1659                 wrapCompleter completeModule w
1660         | otherwise     -> do
1661                 --printf "complete %s, start = %d, end = %d\n" w start end
1662                 wrapCompleter completeIdentifier w
1663     where words' _ _ [] = []
1664           words' isBreak n str = let (w,r) = break isBreak str
1665                                      (s,r') = span isBreak r
1666                                  in (n,w):words' isBreak (n+length w+length s) r'
1667           -- In a Haskell expression we want to parse 'a-b' as three words
1668           -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1669           -- only be a single word.
1670           selectWord [] = (0,w)
1671           selectWord ((offset,x):xs)
1672               | offset+length x >= start = (start-offset,take (end-offset) x)
1673               | otherwise = selectWord xs
1674
1675           lookupCompletionVars ('!':_) = return (Just filenameWordBreakChars,
1676                                             completeFilename)
1677           lookupCompletionVars c = do
1678               maybe_cmd <- lookupCommand' c
1679               case maybe_cmd of
1680                   Just (_,_,ws,f) -> return (ws,f)
1681                   Nothing -> return (Just filenameWordBreakChars,
1682                                         completeFilename)
1683
1684
1685 completeCmd :: String -> IO [String]
1686 completeCmd w = do
1687   cmds <- readIORef macros_ref
1688   return (filter (w `isPrefixOf`) (map (':':)
1689              (map cmdName (builtin_commands ++ cmds))))
1690
1691 completeMacro w = do
1692   cmds <- readIORef macros_ref
1693   return (filter (w `isPrefixOf`) (map cmdName cmds))
1694
1695 completeIdentifier w = do
1696   s <- restoreSession
1697   rdrs <- GHC.getRdrNamesInScope s
1698   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1699
1700 completeModule w = do
1701   s <- restoreSession
1702   dflags <- GHC.getSessionDynFlags s
1703   let pkg_mods = allExposedModules dflags
1704   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1705
1706 completeHomeModule w = do
1707   s <- restoreSession
1708   g <- GHC.getModuleGraph s
1709   let home_mods = map GHC.ms_mod_name g
1710   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1711
1712 completeSetOptions w = do
1713   return (filter (w `isPrefixOf`) options)
1714     where options = "args":"prog":allFlags
1715
1716 completeFilename w = do
1717     ws <- Readline.filenameCompletionFunction w
1718     case ws of
1719         -- If we only found one result, and it's a directory,
1720         -- add a trailing slash.
1721         [file] -> do
1722                 isDir <- expandPathIO file >>= doesDirectoryExist
1723                 if isDir && last file /= '/'
1724                     then return [file ++ "/"]
1725                     else return [file]
1726         _ -> return ws
1727
1728
1729 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1730
1731 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1732 unionComplete f1 f2 w = do
1733   s1 <- f1 w
1734   s2 <- f2 w
1735   return (s1 ++ s2)
1736
1737 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1738 wrapCompleter fun w =  do
1739   strs <- fun w
1740   case strs of
1741     []  -> Readline.setAttemptedCompletionOver True >> return Nothing
1742     [x] -> -- Add a trailing space, unless it already has an appended slash.
1743            let appended = if last x == '/' then x else x ++ " "
1744            in return (Just (appended,[]))
1745     xs  -> case getCommonPrefix xs of
1746                 ""   -> return (Just ("",xs))
1747                 pref -> return (Just (pref,xs))
1748
1749 getCommonPrefix :: [String] -> String
1750 getCommonPrefix [] = ""
1751 getCommonPrefix (s:ss) = foldl common s ss
1752   where common _s "" = ""
1753         common "" _s = ""
1754         common (c:cs) (d:ds)
1755            | c == d = c : common cs ds
1756            | otherwise = ""
1757
1758 allExposedModules :: DynFlags -> [ModuleName]
1759 allExposedModules dflags
1760  = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1761  where
1762   pkg_db = pkgIdMap (pkgState dflags)
1763 #else
1764 completeMacro      = completeNone
1765 completeIdentifier = completeNone
1766 completeModule     = completeNone
1767 completeHomeModule = completeNone
1768 completeSetOptions = completeNone
1769 completeFilename   = completeNone
1770 completeHomeModuleOrFile=completeNone
1771 #endif
1772
1773 -- ---------------------------------------------------------------------------
1774 -- User code exception handling
1775
1776 -- This is the exception handler for exceptions generated by the
1777 -- user's code and exceptions coming from children sessions;
1778 -- it normally just prints out the exception.  The
1779 -- handler must be recursive, in case showing the exception causes
1780 -- more exceptions to be raised.
1781 --
1782 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1783 -- raising another exception.  We therefore don't put the recursive
1784 -- handler arond the flushing operation, so if stderr is closed
1785 -- GHCi will just die gracefully rather than going into an infinite loop.
1786 handler :: Exception -> GHCi Bool
1787
1788 handler exception = do
1789   flushInterpBuffers
1790   io installSignalHandlers
1791   ghciHandle handler (showException exception >> return False)
1792
1793 showException :: Exception -> GHCi ()
1794 showException (DynException dyn) =
1795   case fromDynamic dyn of
1796     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
1797     Just Interrupted      -> io (putStrLn "Interrupted.")
1798     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
1799     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1800     Just other_ghc_ex     -> io (print other_ghc_ex)
1801
1802 showException other_exception
1803   = io (putStrLn ("*** Exception: " ++ show other_exception))
1804
1805 -----------------------------------------------------------------------------
1806 -- recursive exception handlers
1807
1808 -- Don't forget to unblock async exceptions in the handler, or if we're
1809 -- in an exception loop (eg. let a = error a in a) the ^C exception
1810 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1811
1812 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1813 ghciHandle h (GHCi m) = GHCi $ \s ->
1814    Exception.catch (m s)
1815         (\e -> unGHCi (ghciUnblock (h e)) s)
1816
1817 ghciUnblock :: GHCi a -> GHCi a
1818 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1819
1820 ghciTry :: GHCi a -> GHCi (Either Exception a)
1821 ghciTry (GHCi m) = GHCi $ \s -> Exception.try (m s)
1822
1823 -- ----------------------------------------------------------------------------
1824 -- Utils
1825
1826 expandPath :: String -> GHCi String
1827 expandPath path = io (expandPathIO path)
1828
1829 expandPathIO :: String -> IO String
1830 expandPathIO path =
1831   case dropWhile isSpace path of
1832    ('~':d) -> do
1833         tilde <- getHomeDirectory -- will fail if HOME not defined
1834         return (tilde ++ '/':d)
1835    other ->
1836         return other
1837
1838 wantInterpretedModule :: String -> GHCi Module
1839 wantInterpretedModule str = do
1840    session <- getSession
1841    modl <- lookupModule str
1842    is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1843    when (not is_interpreted) $
1844        throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1845    return modl
1846
1847 wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String
1848                               -> (Name -> GHCi ())
1849                               -> GHCi ()
1850 wantNameFromInterpretedModule noCanDo str and_then = do
1851    session <- getSession
1852    names <- io $ GHC.parseName session str
1853    case names of
1854       []    -> return ()
1855       (n:_) -> do
1856             let modl = GHC.nameModule n
1857             if not (GHC.isExternalName n)
1858                then noCanDo n $ ppr n <>
1859                                 text " is not defined in an interpreted module"
1860                else do
1861             is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1862             if not is_interpreted
1863                then noCanDo n $ text "module " <> ppr modl <>
1864                                 text " is not interpreted"
1865                else and_then n
1866
1867 -- -----------------------------------------------------------------------------
1868 -- commands for debugger
1869
1870 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1871 sprintCmd = pprintCommand False False
1872 printCmd  = pprintCommand True False
1873 forceCmd  = pprintCommand False True
1874
1875 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1876 pprintCommand bind force str = do
1877   session <- getSession
1878   io $ pprintClosureCommand session bind force str
1879
1880 stepCmd :: String -> GHCi ()
1881 stepCmd []         = doContinue (const True) GHC.SingleStep
1882 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1883
1884 stepLocalCmd :: String -> GHCi ()
1885 stepLocalCmd  [] = do
1886   mb_span <- getCurrentBreakSpan
1887   case mb_span of
1888     Nothing  -> stepCmd []
1889     Just loc -> do
1890        Just mod <- getCurrentBreakModule
1891        current_toplevel_decl <- enclosingTickSpan mod loc
1892        doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1893
1894 stepLocalCmd expression = stepCmd expression
1895
1896 stepModuleCmd :: String -> GHCi ()
1897 stepModuleCmd  [] = do
1898   mb_span <- getCurrentBreakSpan
1899   case mb_span of
1900     Nothing  -> stepCmd []
1901     Just _ -> do
1902        Just span <- getCurrentBreakSpan
1903        let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
1904        doContinue f GHC.SingleStep
1905
1906 stepModuleCmd expression = stepCmd expression
1907
1908 -- | Returns the span of the largest tick containing the srcspan given
1909 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1910 enclosingTickSpan mod src = do
1911   ticks <- getTickArray mod
1912   let line = srcSpanStartLine src
1913   ASSERT (inRange (bounds ticks) line) do
1914   let enclosing_spans = [ span | (_,span) <- ticks ! line
1915                                , srcSpanEnd span >= srcSpanEnd src]
1916   return . head . sortBy leftmost_largest $ enclosing_spans
1917
1918 traceCmd :: String -> GHCi ()
1919 traceCmd []         = doContinue (const True) GHC.RunAndLogSteps
1920 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1921
1922 continueCmd :: String -> GHCi ()
1923 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1924
1925 -- doContinue :: SingleStep -> GHCi ()
1926 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1927 doContinue pred step = do
1928   session <- getSession
1929   runResult <- io $ GHC.resume session step
1930   afterRunStmt pred runResult
1931   return ()
1932
1933 abandonCmd :: String -> GHCi ()
1934 abandonCmd = noArgs $ do
1935   s <- getSession
1936   b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1937   when (not b) $ io $ putStrLn "There is no computation running."
1938   return ()
1939
1940 deleteCmd :: String -> GHCi ()
1941 deleteCmd argLine = do
1942    deleteSwitch $ words argLine
1943    where
1944    deleteSwitch :: [String] -> GHCi ()
1945    deleteSwitch [] =
1946       io $ putStrLn "The delete command requires at least one argument."
1947    -- delete all break points
1948    deleteSwitch ("*":_rest) = discardActiveBreakPoints
1949    deleteSwitch idents = do
1950       mapM_ deleteOneBreak idents
1951       where
1952       deleteOneBreak :: String -> GHCi ()
1953       deleteOneBreak str
1954          | all isDigit str = deleteBreak (read str)
1955          | otherwise = return ()
1956
1957 historyCmd :: String -> GHCi ()
1958 historyCmd arg
1959   | null arg        = history 20
1960   | all isDigit arg = history (read arg)
1961   | otherwise       = io $ putStrLn "Syntax:  :history [num]"
1962   where
1963   history num = do
1964     s <- getSession
1965     resumes <- io $ GHC.getResumeContext s
1966     case resumes of
1967       [] -> io $ putStrLn "Not stopped at a breakpoint"
1968       (r:_) -> do
1969         let hist = GHC.resumeHistory r
1970             (took,rest) = splitAt num hist
1971         case hist of
1972           [] -> io $ putStrLn $
1973                    "Empty history. Perhaps you forgot to use :trace?"
1974           _  -> do
1975                  spans <- mapM (io . GHC.getHistorySpan s) took
1976                  let nums  = map (printf "-%-3d:") [(1::Int)..]
1977                      names = map GHC.historyEnclosingDecl took
1978                  printForUser (vcat(zipWith3
1979                                  (\x y z -> x <+> y <+> z)
1980                                  (map text nums)
1981                                  (map (bold . ppr) names)
1982                                  (map (parens . ppr) spans)))
1983                  io $ putStrLn $ if null rest then "<end of history>" else "..."
1984
1985 bold :: SDoc -> SDoc
1986 bold c | do_bold   = text start_bold <> c <> text end_bold
1987        | otherwise = c
1988
1989 backCmd :: String -> GHCi ()
1990 backCmd = noArgs $ do
1991   s <- getSession
1992   (names, _, span) <- io $ GHC.back s
1993   printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1994   printTypeOfNames s names
1995    -- run the command set with ":set stop <cmd>"
1996   st <- getGHCiState
1997   enqueueCommands [stop st]
1998
1999 forwardCmd :: String -> GHCi ()
2000 forwardCmd = noArgs $ do
2001   s <- getSession
2002   (names, ix, span) <- io $ GHC.forward s
2003   printForUser $ (if (ix == 0)
2004                     then ptext SLIT("Stopped at")
2005                     else ptext SLIT("Logged breakpoint at")) <+> ppr span
2006   printTypeOfNames s names
2007    -- run the command set with ":set stop <cmd>"
2008   st <- getGHCiState
2009   enqueueCommands [stop st]
2010
2011 -- handle the "break" command
2012 breakCmd :: String -> GHCi ()
2013 breakCmd argLine = do
2014    session <- getSession
2015    breakSwitch session $ words argLine
2016
2017 breakSwitch :: Session -> [String] -> GHCi ()
2018 breakSwitch _session [] = do
2019    io $ putStrLn "The break command requires at least one argument."
2020 breakSwitch session (arg1:rest)
2021    | looksLikeModuleName arg1 = do
2022         mod <- wantInterpretedModule arg1
2023         breakByModule mod rest
2024    | all isDigit arg1 = do
2025         (toplevel, _) <- io $ GHC.getContext session
2026         case toplevel of
2027            (mod : _) -> breakByModuleLine mod (read arg1) rest
2028            [] -> do
2029               io $ putStrLn "Cannot find default module for breakpoint."
2030               io $ putStrLn "Perhaps no modules are loaded for debugging?"
2031    | otherwise = do -- try parsing it as an identifier
2032         wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
2033         let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2034         if GHC.isGoodSrcLoc loc
2035                then findBreakAndSet (GHC.nameModule name) $
2036                          findBreakByCoord (Just (GHC.srcLocFile loc))
2037                                           (GHC.srcLocLine loc,
2038                                            GHC.srcLocCol loc)
2039                else noCanDo name $ text "can't find its location: " <> ppr loc
2040        where
2041           noCanDo n why = printForUser $
2042                 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
2043
2044 breakByModule :: Module -> [String] -> GHCi ()
2045 breakByModule mod (arg1:rest)
2046    | all isDigit arg1 = do  -- looks like a line number
2047         breakByModuleLine mod (read arg1) rest
2048 breakByModule _ _
2049    = breakSyntax
2050
2051 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
2052 breakByModuleLine mod line args
2053    | [] <- args = findBreakAndSet mod $ findBreakByLine line
2054    | [col] <- args, all isDigit col =
2055         findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
2056    | otherwise = breakSyntax
2057
2058 breakSyntax :: a
2059 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
2060
2061 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
2062 findBreakAndSet mod lookupTickTree = do
2063    tickArray <- getTickArray mod
2064    (breakArray, _) <- getModBreak mod
2065    case lookupTickTree tickArray of
2066       Nothing  -> io $ putStrLn $ "No breakpoints found at that location."
2067       Just (tick, span) -> do
2068          success <- io $ setBreakFlag True breakArray tick
2069          if success
2070             then do
2071                (alreadySet, nm) <-
2072                      recordBreak $ BreakLocation
2073                              { breakModule = mod
2074                              , breakLoc = span
2075                              , breakTick = tick
2076                              , onBreakCmd = ""
2077                              }
2078                printForUser $
2079                   text "Breakpoint " <> ppr nm <>
2080                   if alreadySet
2081                      then text " was already set at " <> ppr span
2082                      else text " activated at " <> ppr span
2083             else do
2084             printForUser $ text "Breakpoint could not be activated at"
2085                                  <+> ppr span
2086
2087 -- When a line number is specified, the current policy for choosing
2088 -- the best breakpoint is this:
2089 --    - the leftmost complete subexpression on the specified line, or
2090 --    - the leftmost subexpression starting on the specified line, or
2091 --    - the rightmost subexpression enclosing the specified line
2092 --
2093 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2094 findBreakByLine line arr
2095   | not (inRange (bounds arr) line) = Nothing
2096   | otherwise =
2097     listToMaybe (sortBy (leftmost_largest `on` snd)  complete)   `mplus`
2098     listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2099     listToMaybe (sortBy (rightmost `on` snd) ticks)
2100   where
2101         ticks = arr ! line
2102
2103         starts_here = [ tick | tick@(_,span) <- ticks,
2104                                GHC.srcSpanStartLine span == line ]
2105
2106         (complete,incomplete) = partition ends_here starts_here
2107             where ends_here (_,span) = GHC.srcSpanEndLine span == line
2108
2109 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2110                  -> Maybe (BreakIndex,SrcSpan)
2111 findBreakByCoord mb_file (line, col) arr
2112   | not (inRange (bounds arr) line) = Nothing
2113   | otherwise =
2114     listToMaybe (sortBy (rightmost `on` snd) contains ++
2115                  sortBy (leftmost_smallest `on` snd) after_here)
2116   where
2117         ticks = arr ! line
2118
2119         -- the ticks that span this coordinate
2120         contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2121                             is_correct_file span ]
2122
2123         is_correct_file span
2124                  | Just f <- mb_file = GHC.srcSpanFile span == f
2125                  | otherwise         = True
2126
2127         after_here = [ tick | tick@(_,span) <- ticks,
2128                               GHC.srcSpanStartLine span == line,
2129                               GHC.srcSpanStartCol span >= col ]
2130
2131 -- For now, use ANSI bold on terminals that we know support it.
2132 -- Otherwise, we add a line of carets under the active expression instead.
2133 -- In particular, on Windows and when running the testsuite (which sets
2134 -- TERM to vt100 for other reasons) we get carets.
2135 -- We really ought to use a proper termcap/terminfo library.
2136 do_bold :: Bool
2137 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2138     where mTerm = System.Environment.getEnv "TERM"
2139                   `Exception.catch` \_ -> return "TERM not set"
2140
2141 start_bold :: String
2142 start_bold = "\ESC[1m"
2143 end_bold :: String
2144 end_bold   = "\ESC[0m"
2145
2146 listCmd :: String -> GHCi ()
2147 listCmd "" = do
2148    mb_span <- getCurrentBreakSpan
2149    case mb_span of
2150       Nothing ->
2151           printForUser $ text "Not stopped at a breakpoint; nothing to list"
2152       Just span
2153        | GHC.isGoodSrcSpan span -> io $ listAround span True
2154        | otherwise ->
2155           do s <- getSession
2156              resumes <- io $ GHC.getResumeContext s
2157              case resumes of
2158                  [] -> panic "No resumes"
2159                  (r:_) ->
2160                      do let traceIt = case GHC.resumeHistory r of
2161                                       [] -> text "rerunning with :trace,"
2162                                       _ -> empty
2163                             doWhat = traceIt <+> text ":back then :list"
2164                         printForUser (text "Unable to list source for" <+>
2165                                       ppr span
2166                                    $$ text "Try" <+> doWhat)
2167 listCmd str = list2 (words str)
2168
2169 list2 :: [String] -> GHCi ()
2170 list2 [arg] | all isDigit arg = do
2171     session <- getSession
2172     (toplevel, _) <- io $ GHC.getContext session
2173     case toplevel of
2174         [] -> io $ putStrLn "No module to list"
2175         (mod : _) -> listModuleLine mod (read arg)
2176 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2177         mod <- wantInterpretedModule arg1
2178         listModuleLine mod (read arg2)
2179 list2 [arg] = do
2180         wantNameFromInterpretedModule noCanDo arg $ \name -> do
2181         let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2182         if GHC.isGoodSrcLoc loc
2183                then do
2184                   tickArray <- getTickArray (GHC.nameModule name)
2185                   let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2186                                         (GHC.srcLocLine loc, GHC.srcLocCol loc)
2187                                         tickArray
2188                   case mb_span of
2189                     Nothing       -> io $ listAround (GHC.srcLocSpan loc) False
2190                     Just (_,span) -> io $ listAround span False
2191                else
2192                   noCanDo name $ text "can't find its location: " <>
2193                                  ppr loc
2194     where
2195         noCanDo n why = printForUser $
2196             text "cannot list source code for " <> ppr n <> text ": " <> why
2197 list2  _other =
2198         io $ putStrLn "syntax:  :list [<line> | <module> <line> | <identifier>]"
2199
2200 listModuleLine :: Module -> Int -> GHCi ()
2201 listModuleLine modl line = do
2202    session <- getSession
2203    graph <- io (GHC.getModuleGraph session)
2204    let this = filter ((== modl) . GHC.ms_mod) graph
2205    case this of
2206      [] -> panic "listModuleLine"
2207      summ:_ -> do
2208            let filename = fromJust (ml_hs_file (GHC.ms_location summ))
2209                loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2210            io $ listAround (GHC.srcLocSpan loc) False
2211
2212 -- | list a section of a source file around a particular SrcSpan.
2213 -- If the highlight flag is True, also highlight the span using
2214 -- start_bold/end_bold.
2215 listAround :: SrcSpan -> Bool -> IO ()
2216 listAround span do_highlight = do
2217       contents <- BS.readFile (unpackFS file)
2218       let
2219           lines = BS.split '\n' contents
2220           these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2221                         drop (line1 - 1 - pad_before) $ lines
2222           fst_line = max 1 (line1 - pad_before)
2223           line_nos = [ fst_line .. ]
2224
2225           highlighted | do_highlight = zipWith highlight line_nos these_lines
2226                       | otherwise    = [\p -> BS.concat[p,l] | l <- these_lines]
2227
2228           bs_line_nos = [ BS.pack (show l ++ "  ") | l <- line_nos ]
2229           prefixed = zipWith ($) highlighted bs_line_nos
2230       --
2231       BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed)
2232   where
2233         file  = GHC.srcSpanFile span
2234         line1 = GHC.srcSpanStartLine span
2235         col1  = GHC.srcSpanStartCol span
2236         line2 = GHC.srcSpanEndLine span
2237         col2  = GHC.srcSpanEndCol span
2238
2239         pad_before | line1 == 1 = 0
2240                    | otherwise  = 1
2241         pad_after = 1
2242
2243         highlight | do_bold   = highlight_bold
2244                   | otherwise = highlight_carets
2245
2246         highlight_bold no line prefix
2247           | no == line1 && no == line2
2248           = let (a,r) = BS.splitAt col1 line
2249                 (b,c) = BS.splitAt (col2-col1) r
2250             in
2251             BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2252           | no == line1
2253           = let (a,b) = BS.splitAt col1 line in
2254             BS.concat [prefix, a, BS.pack start_bold, b]
2255           | no == line2
2256           = let (a,b) = BS.splitAt col2 line in
2257             BS.concat [prefix, a, BS.pack end_bold, b]
2258           | otherwise   = BS.concat [prefix, line]
2259
2260         highlight_carets no line prefix
2261           | no == line1 && no == line2
2262           = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2263                                          BS.replicate (col2-col1) '^']
2264           | no == line1
2265           = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2266                                          prefix, line]
2267           | no == line2
2268           = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2269                                          BS.pack "^^"]
2270           | otherwise   = BS.concat [prefix, line]
2271          where
2272            indent = BS.pack ("  " ++ replicate (length (show no)) ' ')
2273            nl = BS.singleton '\n'
2274
2275 -- --------------------------------------------------------------------------
2276 -- Tick arrays
2277
2278 getTickArray :: Module -> GHCi TickArray
2279 getTickArray modl = do
2280    st <- getGHCiState
2281    let arrmap = tickarrays st
2282    case lookupModuleEnv arrmap modl of
2283       Just arr -> return arr
2284       Nothing  -> do
2285         (_breakArray, ticks) <- getModBreak modl
2286         let arr = mkTickArray (assocs ticks)
2287         setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2288         return arr
2289
2290 discardTickArrays :: GHCi ()
2291 discardTickArrays = do
2292    st <- getGHCiState
2293    setGHCiState st{tickarrays = emptyModuleEnv}
2294
2295 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2296 mkTickArray ticks
2297   = accumArray (flip (:)) [] (1, max_line)
2298         [ (line, (nm,span)) | (nm,span) <- ticks,
2299                               line <- srcSpanLines span ]
2300     where
2301         max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2302         srcSpanLines span = [ GHC.srcSpanStartLine span ..
2303                               GHC.srcSpanEndLine span ]
2304
2305 lookupModule :: String -> GHCi Module
2306 lookupModule modName
2307    = do session <- getSession
2308         io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
2309
2310 -- don't reset the counter back to zero?
2311 discardActiveBreakPoints :: GHCi ()
2312 discardActiveBreakPoints = do
2313    st <- getGHCiState
2314    mapM (turnOffBreak.snd) (breaks st)
2315    setGHCiState $ st { breaks = [] }
2316
2317 deleteBreak :: Int -> GHCi ()
2318 deleteBreak identity = do
2319    st <- getGHCiState
2320    let oldLocations    = breaks st
2321        (this,rest)     = partition (\loc -> fst loc == identity) oldLocations
2322    if null this
2323       then printForUser (text "Breakpoint" <+> ppr identity <+>
2324                          text "does not exist")
2325       else do
2326            mapM (turnOffBreak.snd) this
2327            setGHCiState $ st { breaks = rest }
2328
2329 turnOffBreak :: BreakLocation -> GHCi Bool
2330 turnOffBreak loc = do
2331   (arr, _) <- getModBreak (breakModule loc)
2332   io $ setBreakFlag False arr (breakTick loc)
2333
2334 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2335 getModBreak mod = do
2336    session <- getSession
2337    Just mod_info <- io $ GHC.getModuleInfo session mod
2338    let modBreaks  = GHC.modInfoModBreaks mod_info
2339    let array      = GHC.modBreaks_flags modBreaks
2340    let ticks      = GHC.modBreaks_locs  modBreaks
2341    return (array, ticks)
2342
2343 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2344 setBreakFlag toggle array index
2345    | toggle    = GHC.setBreakOn array index
2346    | otherwise = GHC.setBreakOff array index