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