compiler/ghci/InteractiveUI.hs

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