ghc/InteractiveUI.hs

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