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