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