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