ghc/InteractiveUI.hs

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