compiler/ghci/InteractiveUI.hs

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