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