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