compiler/ghci/InteractiveUI.hs

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