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