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