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