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