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