ghc/InteractiveUI.hs

   1 {-# OPTIONS -fno-cse #-}
   2 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
   3
   4 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
   5 -----------------------------------------------------------------------------
   6 --
   7 -- GHC Interactive User Interface
   8 --
   9 -- (c) The GHC Team 2005-2006
  10 --
  11 -----------------------------------------------------------------------------
  12
  13 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
  14
  15 #include "HsVersions.h"
  16
  17 import qualified GhciMonad
  18 import GhciMonad hiding (runStmt)
  19 import GhciTags
  20 import Debugger
  21
  22 -- The GHC interface
  23 import qualified GHC hiding (resume, runStmt)
  24 import GHC              ( LoadHowMuch(..), Target(..),  TargetId(..),
  25                           TyThing(..), Phase,
  26                           BreakIndex, Resume, SingleStep,
  27                           Ghc, handleSourceError )
  28 import PprTyThing
  29 import DynFlags
  30 import qualified Lexer
  31 import StringBuffer
  32
  33 import Packages
  34 -- import PackageConfig
  35 import UniqFM
  36
  37 import HscTypes ( handleFlagWarnings )
  38 import HsImpExp
  39 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
  40 import RdrName (RdrName)
  41 import Outputable       hiding (printForUser, printForUserPartWay)
  42 import Module           -- for ModuleEnv
  43 import Name
  44 import SrcLoc
  45
  46 -- Other random utilities
  47 import 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', macros ++ builtin_commands) }
 852   -- look for exact match first, then the first prefix match
 853   return $ case [ c | c <- cmds, str == cmdName c ] of
 854            c:_ -> Just c
 855            [] -> case [ c | c@(s,_,_) <- cmds, str `isPrefixOf` s ] of
 856                  [] -> Nothing
 857                  c:_ -> Just c
 858
 859 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
 860 getCurrentBreakSpan = do
 861   resumes <- GHC.getResumeContext
 862   case resumes of
 863     [] -> return Nothing
 864     (r:_) -> do
 865         let ix = GHC.resumeHistoryIx r
 866         if ix == 0
 867            then return (Just (GHC.resumeSpan r))
 868            else do
 869                 let hist = GHC.resumeHistory r !! (ix-1)
 870                 span <- GHC.getHistorySpan hist
 871                 return (Just span)
 872
 873 getCurrentBreakModule :: GHCi (Maybe Module)
 874 getCurrentBreakModule = do
 875   resumes <- GHC.getResumeContext
 876   case resumes of
 877     [] -> return Nothing
 878     (r:_) -> do
 879         let ix = GHC.resumeHistoryIx r
 880         if ix == 0
 881            then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
 882            else do
 883                 let hist = GHC.resumeHistory r !! (ix-1)
 884                 return $ Just $ GHC.getHistoryModule  hist
 885
 886 -----------------------------------------------------------------------------
 887 -- Commands
 888
 889 noArgs :: GHCi () -> String -> GHCi ()
 890 noArgs m "" = m
 891 noArgs _ _  = liftIO $ putStrLn "This command takes no arguments"
 892
 893 help :: String -> GHCi ()
 894 help _ = liftIO (putStr helpText)
 895
 896 info :: String -> InputT GHCi ()
 897 info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
 898 info s  = handleSourceError GHC.printException $
 899           do { let names = words s
 900              ; dflags <- getDynFlags
 901              ; let pefas = dopt Opt_PrintExplicitForalls dflags
 902              ; mapM_ (infoThing pefas) names }
 903   where
 904     infoThing pefas str = do
 905         names     <- GHC.parseName str
 906         mb_stuffs <- mapM GHC.getInfo names
 907         let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
 908         unqual <- GHC.getPrintUnqual
 909         liftIO $ putStrLn $ showSDocForUser unqual $
 910                      vcat (intersperse (text "") $
 911                            map (pprInfo pefas) filtered)
 912
 913   -- Filter out names whose parent is also there Good
 914   -- example is '[]', which is both a type and data
 915   -- constructor in the same type
 916 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
 917 filterOutChildren get_thing xs
 918   = filterOut has_parent xs
 919   where
 920     all_names = mkNameSet (map (getName . get_thing) xs)
 921     has_parent x = case pprTyThingParent_maybe (get_thing x) of
 922                      Just p  -> getName p `elemNameSet` all_names
 923                      Nothing -> False
 924
 925 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
 926 pprInfo pefas (thing, fixity, insts)
 927   =  pprTyThingInContextLoc pefas thing
 928   $$ show_fixity fixity
 929   $$ vcat (map GHC.pprInstance insts)
 930   where
 931     show_fixity fix
 932         | fix == GHC.defaultFixity = empty
 933         | otherwise                = ppr fix <+> ppr (GHC.getName thing)
 934
 935 runMain :: String -> GHCi ()
 936 runMain s = case toArgs s of
 937             Left err   -> liftIO (hPutStrLn stderr err)
 938             Right args ->
 939                 do dflags <- getDynFlags
 940                    case mainFunIs dflags of
 941                        Nothing -> doWithArgs args "main"
 942                        Just f  -> doWithArgs args f
 943
 944 runRun :: String -> GHCi ()
 945 runRun s = case toCmdArgs s of
 946            Left err          -> liftIO (hPutStrLn stderr err)
 947            Right (cmd, args) -> doWithArgs args cmd
 948
 949 doWithArgs :: [String] -> String -> GHCi ()
 950 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
 951                                        show args ++ " (" ++ cmd ++ ")"]
 952
 953 addModule :: [FilePath] -> InputT GHCi ()
 954 addModule files = do
 955   lift revertCAFs -- always revert CAFs on load/add.
 956   files <- mapM expandPath files
 957   targets <- mapM (\m -> GHC.guessTarget m Nothing) files
 958   -- remove old targets with the same id; e.g. for :add *M
 959   mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
 960   mapM_ GHC.addTarget targets
 961   prev_context <- GHC.getContext
 962   ok <- trySuccess $ GHC.load LoadAllTargets
 963   afterLoad ok False prev_context
 964
 965 changeDirectory :: String -> InputT GHCi ()
 966 changeDirectory "" = do
 967   -- :cd on its own changes to the user's home directory
 968   either_dir <- liftIO $ tryIO getHomeDirectory
 969   case either_dir of
 970      Left _e -> return ()
 971      Right dir -> changeDirectory dir
 972 changeDirectory dir = do
 973   graph <- GHC.getModuleGraph
 974   when (not (null graph)) $
 975         liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."
 976   prev_context <- GHC.getContext
 977   GHC.setTargets []
 978   _ <- GHC.load LoadAllTargets
 979   lift $ setContextAfterLoad prev_context False []
 980   GHC.workingDirectoryChanged
 981   dir <- expandPath dir
 982   liftIO $ setCurrentDirectory dir
 983
 984 trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
 985 trySuccess act =
 986     handleSourceError (\e -> do GHC.printException e
 987                                 return Failed) $ do
 988       act
 989
 990 editFile :: String -> GHCi ()
 991 editFile str =
 992   do file <- if null str then chooseEditFile else return str
 993      st <- getGHCiState
 994      let cmd = editor st
 995      when (null cmd)
 996        $ ghcError (CmdLineError "editor not set, use :set editor")
 997      _ <- liftIO $ system (cmd ++ ' ':file)
 998      return ()
 999
1000 -- The user didn't specify a file so we pick one for them.
1001 -- Our strategy is to pick the first module that failed to load,
1002 -- or otherwise the first target.
1003 --
1004 -- XXX: Can we figure out what happened if the depndecy analysis fails
1005 --      (e.g., because the porgrammeer mistyped the name of a module)?
1006 -- XXX: Can we figure out the location of an error to pass to the editor?
1007 -- XXX: if we could figure out the list of errors that occured during the
1008 -- last load/reaload, then we could start the editor focused on the first
1009 -- of those.
1010 chooseEditFile :: GHCi String
1011 chooseEditFile =
1012   do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
1013
1014      graph <- GHC.getModuleGraph
1015      failed_graph <- filterM hasFailed graph
1016      let order g  = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
1017          pick xs  = case xs of
1018                       x : _ -> GHC.ml_hs_file (GHC.ms_location x)
1019                       _     -> Nothing
1020
1021      case pick (order failed_graph) of
1022        Just file -> return file
1023        Nothing   ->
1024          do targets <- GHC.getTargets
1025             case msum (map fromTarget targets) of
1026               Just file -> return file
1027               Nothing   -> ghcError (CmdLineError "No files to edit.")
1028
1029   where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
1030         fromTarget _ = Nothing -- when would we get a module target?
1031
1032 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
1033 defineMacro _ (':':_) =
1034   liftIO $ putStrLn "macro name cannot start with a colon"
1035 defineMacro overwrite s = do
1036   let (macro_name, definition) = break isSpace s
1037   macros <- liftIO (readIORef macros_ref)
1038   let defined = map cmdName macros
1039   if (null macro_name)
1040         then if null defined
1041                 then liftIO $ putStrLn "no macros defined"
1042                 else liftIO $ putStr ("the following macros are defined:\n" ++
1043                                       unlines defined)
1044         else do
1045   if (not overwrite && macro_name `elem` defined)
1046         then ghcError (CmdLineError
1047                 ("macro '" ++ macro_name ++ "' is already defined"))
1048         else do
1049
1050   let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
1051
1052   -- give the expression a type signature, so we can be sure we're getting
1053   -- something of the right type.
1054   let new_expr = '(' : definition ++ ") :: String -> IO String"
1055
1056   -- compile the expression
1057   handleSourceError (\e -> GHC.printException e) $
1058    do
1059     hv <- GHC.compileExpr new_expr
1060     liftIO (writeIORef macros_ref --
1061             (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)]))
1062
1063 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
1064 runMacro fun s = do
1065   str <- liftIO ((unsafeCoerce# fun :: String -> IO String) s)
1066   -- make sure we force any exceptions in the result, while we are still
1067   -- inside the exception handler for commands:
1068   seqList str (return ())
1069   enqueueCommands (lines str)
1070   return False
1071
1072 undefineMacro :: String -> GHCi ()
1073 undefineMacro str = mapM_ undef (words str)
1074  where undef macro_name = do
1075         cmds <- liftIO (readIORef macros_ref)
1076         if (macro_name `notElem` map cmdName cmds)
1077            then ghcError (CmdLineError
1078                 ("macro '" ++ macro_name ++ "' is not defined"))
1079            else do
1080             liftIO (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
1081
1082 cmdCmd :: String -> GHCi ()
1083 cmdCmd str = do
1084   let expr = '(' : str ++ ") :: IO String"
1085   handleSourceError (\e -> GHC.printException e) $
1086    do
1087     hv <- GHC.compileExpr expr
1088     cmds <- liftIO $ (unsafeCoerce# hv :: IO String)
1089     enqueueCommands (lines cmds)
1090     return ()
1091
1092 loadModuleName :: GHC.GhcMonad m => ImportDecl RdrName -> m Module
1093 loadModuleName = flip GHC.findModule Nothing . unLoc . ideclName
1094
1095 loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
1096 loadModule fs = timeIt (loadModule' fs)
1097
1098 loadModule_ :: [FilePath] -> InputT GHCi ()
1099 loadModule_ fs = loadModule (zip fs (repeat Nothing)) >> return ()
1100
1101 loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
1102 loadModule' files = do
1103   prev_context <- GHC.getContext
1104
1105   -- unload first
1106   _ <- GHC.abandonAll
1107   lift discardActiveBreakPoints
1108   GHC.setTargets []
1109   _ <- GHC.load LoadAllTargets
1110
1111   let (filenames, phases) = unzip files
1112   exp_filenames <- mapM expandPath filenames
1113   let files' = zip exp_filenames phases
1114   targets <- mapM (uncurry GHC.guessTarget) files'
1115
1116   -- NOTE: we used to do the dependency anal first, so that if it
1117   -- fails we didn't throw away the current set of modules.  This would
1118   -- require some re-working of the GHC interface, so we'll leave it
1119   -- as a ToDo for now.
1120
1121   GHC.setTargets targets
1122   doLoad False prev_context LoadAllTargets
1123
1124 checkModule :: String -> InputT GHCi ()
1125 checkModule m = do
1126   let modl = GHC.mkModuleName m
1127   prev_context <- GHC.getContext
1128   ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do
1129           r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
1130           liftIO $ putStrLn $ showSDoc $
1131            case GHC.moduleInfo r of
1132              cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1133                 let
1134                     (local,global) = ASSERT( all isExternalName scope )
1135                                      partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1136                 in
1137                         (text "global names: " <+> ppr global) $$
1138                         (text "local  names: " <+> ppr local)
1139              _ -> empty
1140           return True
1141   afterLoad (successIf ok) False prev_context
1142
1143 reloadModule :: String -> InputT GHCi ()
1144 reloadModule m = do
1145   prev_context <- GHC.getContext
1146   _ <- doLoad True prev_context $
1147         if null m then LoadAllTargets
1148                   else LoadUpTo (GHC.mkModuleName m)
1149   return ()
1150
1151 doLoad :: Bool -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> LoadHowMuch -> InputT GHCi SuccessFlag
1152 doLoad retain_context prev_context howmuch = do
1153   -- turn off breakpoints before we load: we can't turn them off later, because
1154   -- the ModBreaks will have gone away.
1155   lift discardActiveBreakPoints
1156   ok <- trySuccess $ GHC.load howmuch
1157   afterLoad ok retain_context prev_context
1158   return ok
1159
1160 afterLoad :: SuccessFlag -> Bool -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> InputT GHCi ()
1161 afterLoad ok retain_context prev_context = do
1162   lift revertCAFs  -- always revert CAFs on load.
1163   lift discardTickArrays
1164   loaded_mod_summaries <- getLoadedModules
1165   let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1166       loaded_mod_names = map GHC.moduleName loaded_mods
1167   modulesLoadedMsg ok loaded_mod_names
1168
1169   lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
1170
1171
1172 setContextAfterLoad :: ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> Bool -> [GHC.ModSummary] -> GHCi ()
1173 setContextAfterLoad prev keep_ctxt [] = do
1174   prel_mod <- getPrelude
1175   setContextKeepingPackageModules prev keep_ctxt ([], [(prel_mod, Nothing)])
1176 setContextAfterLoad prev keep_ctxt ms = do
1177   -- load a target if one is available, otherwise load the topmost module.
1178   targets <- GHC.getTargets
1179   case [ m | Just m <- map (findTarget ms) targets ] of
1180         []    ->
1181           let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1182           load_this (last graph')
1183         (m:_) ->
1184           load_this m
1185  where
1186    findTarget ms t
1187     = case filter (`matches` t) ms of
1188         []    -> Nothing
1189         (m:_) -> Just m
1190
1191    summary `matches` Target (TargetModule m) _ _
1192         = GHC.ms_mod_name summary == m
1193    summary `matches` Target (TargetFile f _) _ _
1194         | Just f' <- GHC.ml_hs_file (GHC.ms_location summary)   = f == f'
1195    _ `matches` _
1196         = False
1197
1198    load_this summary | m <- GHC.ms_mod summary = do
1199         b <- GHC.moduleIsInterpreted m
1200         if b then setContextKeepingPackageModules prev keep_ctxt ([m], [])
1201              else do
1202                 prel_mod <- getPrelude
1203                 setContextKeepingPackageModules prev keep_ctxt ([],[(prel_mod,Nothing),(m,Nothing)])
1204
1205 -- | Keep any package modules (except Prelude) when changing the context.
1206 setContextKeepingPackageModules
1207         :: ([Module],[(Module, Maybe (ImportDecl RdrName))])          -- previous context
1208         -> Bool                         -- re-execute :module commands
1209         -> ([Module],[(Module, Maybe (ImportDecl RdrName))])          -- new context
1210         -> GHCi ()
1211 setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do
1212   let (_,bs0) = prev_context
1213   prel_mod <- getPrelude
1214   -- filter everything, not just lefts
1215   let pkg_modules = filter ((\p -> not (isHomeModule p) && p /= prel_mod) . fst) bs0
1216   let bs1 = if null as then nubBy sameFst ((prel_mod,Nothing) : bs) else bs
1217   GHC.setContext as (nubBy sameFst (bs1 ++ pkg_modules))
1218   if keep_ctxt
1219      then do
1220           st <- getGHCiState
1221           mapM_ (playCtxtCmd False) (remembered_ctx st)
1222      else do
1223           st <- getGHCiState
1224           setGHCiState st{ remembered_ctx = [] }
1225
1226 isHomeModule :: Module -> Bool
1227 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1228
1229 sameFst :: (Module, Maybe (ImportDecl RdrName)) -> (Module, Maybe (ImportDecl RdrName)) -> Bool
1230 sameFst x y = fst x == fst y
1231
1232 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi ()
1233 modulesLoadedMsg ok mods = do
1234   dflags <- getDynFlags
1235   when (verbosity dflags > 0) $ do
1236    let mod_commas
1237         | null mods = text "none."
1238         | otherwise = hsep (
1239             punctuate comma (map ppr mods)) <> text "."
1240    case ok of
1241     Failed ->
1242        liftIO $ putStrLn $ showSDoc (text "Failed, modules loaded: " <> mod_commas)
1243     Succeeded  ->
1244        liftIO $ putStrLn $ showSDoc (text "Ok, modules loaded: " <> mod_commas)
1245
1246
1247 typeOfExpr :: String -> InputT GHCi ()
1248 typeOfExpr str
1249   = handleSourceError GHC.printException
1250   $ do
1251        ty <- GHC.exprType str
1252        dflags <- getDynFlags
1253        let pefas = dopt Opt_PrintExplicitForalls dflags
1254        printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]
1255
1256 kindOfType :: String -> InputT GHCi ()
1257 kindOfType str
1258   = handleSourceError GHC.printException
1259   $ do
1260        ty <- GHC.typeKind str
1261        printForUser $ text str <+> dcolon <+> ppr ty
1262
1263 quit :: String -> InputT GHCi Bool
1264 quit _ = return True
1265
1266 shellEscape :: String -> GHCi Bool
1267 shellEscape str = liftIO (system str >> return False)
1268
1269 -----------------------------------------------------------------------------
1270 -- running a script file #1363
1271
1272 scriptCmd :: String -> InputT GHCi ()
1273 scriptCmd s = do
1274   case words s of
1275     [s]    -> runScript s
1276     _      -> ghcError (CmdLineError "syntax:  :script <filename>")
1277
1278 runScript :: String    -- ^ filename
1279            -> InputT GHCi ()
1280 runScript filename = do
1281   either_script <- liftIO $ tryIO (openFile filename ReadMode)
1282   case either_script of
1283     Left _err    -> ghcError (CmdLineError $ "IO error:  \""++filename++"\" "
1284                       ++(ioeGetErrorString _err))
1285     Right script -> do
1286       st <- lift $ getGHCiState
1287       let prog = progname st
1288           line = line_number st
1289       lift $ setGHCiState st{progname=filename,line_number=0}
1290       scriptLoop script
1291       liftIO $ hClose script
1292       new_st <- lift $ getGHCiState
1293       lift $ setGHCiState new_st{progname=prog,line_number=line}
1294   where scriptLoop script = do
1295           res <- runOneCommand handler $ fileLoop script
1296           case res of
1297             Nothing   -> return ()
1298             Just succ -> if succ
1299               then scriptLoop script
1300               else return ()
1301
1302 -----------------------------------------------------------------------------
1303 -- Browsing a module's contents
1304
1305 browseCmd :: Bool -> String -> InputT GHCi ()
1306 browseCmd bang m =
1307   case words m of
1308     ['*':s] | looksLikeModuleName s -> do
1309         m <- lift $ wantInterpretedModule s
1310         browseModule bang m False
1311     [s] | looksLikeModuleName s -> do
1312         m <- lift $ lookupModule s
1313         browseModule bang m True
1314     [] -> do
1315         (as,bs) <- GHC.getContext
1316                 -- Guess which module the user wants to browse.  Pick
1317                 -- modules that are interpreted first.  The most
1318                 -- recently-added module occurs last, it seems.
1319         case (as,bs) of
1320           (as@(_:_), _)   -> browseModule bang (last as) True
1321           ([],  bs@(_:_)) -> browseModule bang (fst (last bs)) True
1322           ([], [])  -> ghcError (CmdLineError ":browse: no current module")
1323     _ -> ghcError (CmdLineError "syntax:  :browse <module>")
1324
1325 -- without bang, show items in context of their parents and omit children
1326 -- with bang, show class methods and data constructors separately, and
1327 --            indicate import modules, to aid qualifying unqualified names
1328 -- with sorted, sort items alphabetically
1329 browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
1330 browseModule bang modl exports_only = do
1331   -- :browse! reports qualifiers wrt current context
1332   current_unqual <- GHC.getPrintUnqual
1333   -- Temporarily set the context to the module we're interested in,
1334   -- just so we can get an appropriate PrintUnqualified
1335   (as,bs) <- GHC.getContext
1336   prel_mod <- lift getPrelude
1337   if exports_only then GHC.setContext [] [(prel_mod,Nothing), (modl,Nothing)]
1338                   else GHC.setContext [modl] []
1339   target_unqual <- GHC.getPrintUnqual
1340   GHC.setContext as bs
1341
1342   let unqual = if bang then current_unqual else target_unqual
1343
1344   mb_mod_info <- GHC.getModuleInfo modl
1345   case mb_mod_info of
1346     Nothing -> ghcError (CmdLineError ("unknown module: " ++
1347                                 GHC.moduleNameString (GHC.moduleName modl)))
1348     Just mod_info -> do
1349         dflags <- getDynFlags
1350         let names
1351                | exports_only = GHC.modInfoExports mod_info
1352                | otherwise    = GHC.modInfoTopLevelScope mod_info
1353                                 `orElse` []
1354
1355                 -- sort alphabetically name, but putting
1356                 -- locally-defined identifiers first.
1357                 -- We would like to improve this; see #1799.
1358             sorted_names = loc_sort local ++ occ_sort external
1359                 where
1360                 (local,external) = ASSERT( all isExternalName names )
1361                                    partition ((==modl) . nameModule) names
1362                 occ_sort = sortBy (compare `on` nameOccName)
1363                 -- try to sort by src location.  If the first name in
1364                 -- our list has a good source location, then they all should.
1365                 loc_sort names
1366                       | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1367                       = sortBy (compare `on` nameSrcSpan) names
1368                       | otherwise
1369                       = occ_sort names
1370
1371         mb_things <- mapM GHC.lookupName sorted_names
1372         let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1373
1374         rdr_env <- GHC.getGRE
1375
1376         let pefas              = dopt Opt_PrintExplicitForalls dflags
1377             things | bang      = catMaybes mb_things
1378                    | otherwise = filtered_things
1379             pretty | bang      = pprTyThing
1380                    | otherwise = pprTyThingInContext
1381
1382             labels  [] = text "-- not currently imported"
1383             labels  l  = text $ intercalate "\n" $ map qualifier l
1384             qualifier  = maybe "-- defined locally"
1385                              (("-- imported via "++) . intercalate ", "
1386                                . map GHC.moduleNameString)
1387             importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1388             modNames   = map (importInfo . GHC.getName) things
1389
1390             -- annotate groups of imports with their import modules
1391             -- the default ordering is somewhat arbitrary, so we group
1392             -- by header and sort groups; the names themselves should
1393             -- really come in order of source appearance.. (trac #1799)
1394             annotate mts = concatMap (\(m,ts)->labels m:ts)
1395                          $ sortBy cmpQualifiers $ group mts
1396               where cmpQualifiers =
1397                       compare `on` (map (fmap (map moduleNameFS)) . fst)
1398             group []            = []
1399             group mts@((m,_):_) = (m,map snd g) : group ng
1400               where (g,ng) = partition ((==m).fst) mts
1401
1402         let prettyThings = map (pretty pefas) things
1403             prettyThings' | bang      = annotate $ zip modNames prettyThings
1404                           | otherwise = prettyThings
1405         liftIO $ putStrLn $ showSDocForUser unqual (vcat prettyThings')
1406         -- ToDo: modInfoInstances currently throws an exception for
1407         -- package modules.  When it works, we can do this:
1408         --        $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1409
1410 -----------------------------------------------------------------------------
1411 -- Setting the module context
1412
1413 newContextCmd :: CtxtCmd -> GHCi ()
1414 newContextCmd cmd = do
1415   playCtxtCmd True cmd
1416   st <- getGHCiState
1417   let cmds = remembered_ctx st
1418   setGHCiState st{ remembered_ctx = cmds ++ [cmd] }
1419
1420 setContext :: String -> GHCi ()
1421 setContext str
1422   | all sensible strs = newContextCmd cmd
1423   | otherwise = ghcError (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
1424   where
1425     (cmd, strs) =
1426         case str of
1427                 '+':stuff -> rest AddModules stuff
1428                 '-':stuff -> rest RemModules stuff
1429                 stuff     -> rest SetContext stuff
1430
1431     rest cmd stuff = (cmd as bs, strs)
1432        where strs = words stuff
1433              (as,bs) = partitionWith starred strs
1434
1435     sensible ('*':m) = looksLikeModuleName m
1436     sensible m       = looksLikeModuleName m
1437
1438     starred ('*':m) = Left m
1439     starred m       = Right m
1440
1441 playCtxtCmd:: Bool -> CtxtCmd -> GHCi ()
1442 playCtxtCmd fail cmd = do
1443     (prev_as,prev_bs) <- GHC.getContext
1444     case cmd of
1445         SetContext as bs -> do
1446           (as',bs') <- do_checks as bs
1447           prel_mod <- getPrelude
1448           let bs'' = if null as && prel_mod `notElem` (map fst bs')
1449                         then (prel_mod,Nothing):bs'
1450                         else bs'
1451           GHC.setContext as' bs''
1452
1453         AddModules as bs -> do
1454           (as',bs') <- do_checks as bs
1455           -- it should replace the old stuff, not the other way around
1456           -- need deleteAllBy, not deleteFirstsBy for sameFst
1457           let remaining_as = prev_as \\ (as' ++ map fst bs')
1458               remaining_bs = deleteAllBy sameFst prev_bs (bs' ++ map contextualize as')
1459           GHC.setContext (remaining_as ++ as') (remaining_bs ++ bs')
1460
1461         RemModules as bs -> do
1462           (as',bs') <- do_checks as bs
1463           let new_as = prev_as \\ (as' ++ map fst bs')
1464               new_bs = deleteAllBy sameFst prev_bs (map contextualize as' ++ bs')
1465           GHC.setContext new_as new_bs
1466
1467         Import str -> do
1468           m_idecl <- maybe_fail $ GHC.parseImportDecl str
1469           case m_idecl of
1470             Nothing    -> return ()
1471             Just idecl -> do
1472               m_mdl <- maybe_fail $ loadModuleName idecl
1473               case m_mdl of
1474                 Nothing -> return ()
1475                 Just m -> GHC.setContext prev_as (prev_bs ++ [(m, Just idecl)])
1476
1477   where
1478     maybe_fail | fail      = liftM Just
1479                | otherwise = trymaybe
1480
1481     do_checks as bs = do
1482          as' <- mapM (maybe_fail . wantInterpretedModule) as
1483          bs' <- mapM (maybe_fail . lookupModule) bs
1484          return (catMaybes as', map contextualize (catMaybes bs'))
1485
1486     contextualize x = (x,Nothing)
1487     deleteAllBy f a b = filter (\x->(not (any (f x) b))) a
1488
1489 trymaybe ::GHCi a -> GHCi (Maybe a)
1490 trymaybe m = do
1491     r <- ghciTry m
1492     case r of
1493       Left _  -> return Nothing
1494       Right a -> return (Just a)
1495
1496 ----------------------------------------------------------------------------
1497 -- Code for `:set'
1498
1499 -- set options in the interpreter.  Syntax is exactly the same as the
1500 -- ghc command line, except that certain options aren't available (-C,
1501 -- -E etc.)
1502 --
1503 -- This is pretty fragile: most options won't work as expected.  ToDo:
1504 -- figure out which ones & disallow them.
1505
1506 setCmd :: String -> GHCi ()
1507 setCmd ""
1508   = do st <- getGHCiState
1509        let opts = options st
1510        liftIO $ putStrLn (showSDoc (
1511               text "options currently set: " <>
1512               if null opts
1513                    then text "none."
1514                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1515            ))
1516        dflags <- getDynFlags
1517        liftIO $ putStrLn (showSDoc (
1518           vcat (text "GHCi-specific dynamic flag settings:"
1519                :map (flagSetting dflags) ghciFlags)
1520           ))
1521        liftIO $ putStrLn (showSDoc (
1522           vcat (text "other dynamic, non-language, flag settings:"
1523                :map (flagSetting dflags) others)
1524           ))
1525   where flagSetting dflags (str, f, _)
1526           | dopt f dflags = text "  " <> text "-f"    <> text str
1527           | otherwise     = text "  " <> text "-fno-" <> text str
1528         (ghciFlags,others)  = partition (\(_, f, _) -> f `elem` flags)
1529                                         DynFlags.fFlags
1530         flags = [Opt_PrintExplicitForalls
1531                 ,Opt_PrintBindResult
1532                 ,Opt_BreakOnException
1533                 ,Opt_BreakOnError
1534                 ,Opt_PrintEvldWithShow
1535                 ]
1536 setCmd str
1537   = case getCmd str of
1538     Right ("args",   rest) ->
1539         case toArgs rest of
1540             Left err -> liftIO (hPutStrLn stderr err)
1541             Right args -> setArgs args
1542     Right ("prog",   rest) ->
1543         case toArgs rest of
1544             Right [prog] -> setProg prog
1545             _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")
1546     Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1547     Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1548     Right ("stop",   rest) -> setStop   $ dropWhile isSpace rest
1549     _ -> case toArgs str of
1550          Left err -> liftIO (hPutStrLn stderr err)
1551          Right wds -> setOptions wds
1552
1553 setArgs, setOptions :: [String] -> GHCi ()
1554 setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
1555
1556 setArgs args = do
1557   st <- getGHCiState
1558   setGHCiState st{ args = args }
1559
1560 setProg prog = do
1561   st <- getGHCiState
1562   setGHCiState st{ progname = prog }
1563
1564 setEditor cmd = do
1565   st <- getGHCiState
1566   setGHCiState st{ editor = cmd }
1567
1568 setStop str@(c:_) | isDigit c
1569   = do let (nm_str,rest) = break (not.isDigit) str
1570            nm = read nm_str
1571        st <- getGHCiState
1572        let old_breaks = breaks st
1573        if all ((/= nm) . fst) old_breaks
1574               then printForUser (text "Breakpoint" <+> ppr nm <+>
1575                                  text "does not exist")
1576               else do
1577        let new_breaks = map fn old_breaks
1578            fn (i,loc) | i == nm   = (i,loc { onBreakCmd = dropWhile isSpace rest })
1579                       | otherwise = (i,loc)
1580        setGHCiState st{ breaks = new_breaks }
1581 setStop cmd = do
1582   st <- getGHCiState
1583   setGHCiState st{ stop = cmd }
1584
1585 setPrompt value = do
1586   st <- getGHCiState
1587   if null value
1588       then liftIO $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1589       else case value of
1590            '\"' : _ -> case reads value of
1591                        [(value', xs)] | all isSpace xs ->
1592                            setGHCiState (st { prompt = value' })
1593                        _ ->
1594                            liftIO $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
1595            _ -> setGHCiState (st { prompt = value })
1596
1597 setOptions wds =
1598    do -- first, deal with the GHCi opts (+s, +t, etc.)
1599       let (plus_opts, minus_opts)  = partitionWith isPlus wds
1600       mapM_ setOpt plus_opts
1601       -- then, dynamic flags
1602       newDynFlags minus_opts
1603
1604 newDynFlags :: [String] -> GHCi ()
1605 newDynFlags minus_opts = do
1606       dflags <- getDynFlags
1607       let pkg_flags = packageFlags dflags
1608       (dflags', leftovers, warns) <- liftIO $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
1609       liftIO $ handleFlagWarnings dflags' warns
1610
1611       if (not (null leftovers))
1612         then ghcError . CmdLineError
1613            $ "Some flags have not been recognized: "
1614           ++ (concat . intersperse ", " $ map unLoc leftovers)
1615         else return ()
1616
1617       new_pkgs <- setDynFlags dflags'
1618
1619       -- if the package flags changed, we should reset the context
1620       -- and link the new packages.
1621       dflags <- getDynFlags
1622       when (packageFlags dflags /= pkg_flags) $ do
1623         liftIO $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
1624         GHC.setTargets []
1625         _ <- GHC.load LoadAllTargets
1626         liftIO (linkPackages dflags new_pkgs)
1627         -- package flags changed, we can't re-use any of the old context
1628         setContextAfterLoad ([],[]) False []
1629       return ()
1630
1631
1632 unsetOptions :: String -> GHCi ()
1633 unsetOptions str
1634   =   -- first, deal with the GHCi opts (+s, +t, etc.)
1635      let opts = words str
1636          (minus_opts, rest1) = partition isMinus opts
1637          (plus_opts, rest2)  = partitionWith isPlus rest1
1638          (other_opts, rest3) = partition (`elem` map fst defaulters) rest2
1639
1640          defaulters =
1641            [ ("args"  , setArgs default_args)
1642            , ("prog"  , setProg default_progname)
1643            , ("prompt", setPrompt default_prompt)
1644            , ("editor", liftIO findEditor >>= setEditor)
1645            , ("stop"  , setStop default_stop)
1646            ]
1647
1648          no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1649          no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
1650
1651      in if (not (null rest3))
1652            then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))
1653            else do
1654              mapM_ (fromJust.flip lookup defaulters) other_opts
1655
1656              mapM_ unsetOpt plus_opts
1657
1658              no_flags <- mapM no_flag minus_opts
1659              newDynFlags no_flags
1660
1661 isMinus :: String -> Bool
1662 isMinus ('-':_) = True
1663 isMinus _ = False
1664
1665 isPlus :: String -> Either String String
1666 isPlus ('+':opt) = Left opt
1667 isPlus other     = Right other
1668
1669 setOpt, unsetOpt :: String -> GHCi ()
1670
1671 setOpt str
1672   = case strToGHCiOpt str of
1673         Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
1674         Just o  -> setOption o
1675
1676 unsetOpt str
1677   = case strToGHCiOpt str of
1678         Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
1679         Just o  -> unsetOption o
1680
1681 strToGHCiOpt :: String -> (Maybe GHCiOption)
1682 strToGHCiOpt "m" = Just Multiline
1683 strToGHCiOpt "s" = Just ShowTiming
1684 strToGHCiOpt "t" = Just ShowType
1685 strToGHCiOpt "r" = Just RevertCAFs
1686 strToGHCiOpt _   = Nothing
1687
1688 optToStr :: GHCiOption -> String
1689 optToStr Multiline  = "m"
1690 optToStr ShowTiming = "s"
1691 optToStr ShowType   = "t"
1692 optToStr RevertCAFs = "r"
1693
1694 -- ---------------------------------------------------------------------------
1695 -- code for `:show'
1696
1697 showCmd :: String -> GHCi ()
1698 showCmd str = do
1699   st <- getGHCiState
1700   case words str of
1701         ["args"]     -> liftIO $ putStrLn (show (args st))
1702         ["prog"]     -> liftIO $ putStrLn (show (progname st))
1703         ["prompt"]   -> liftIO $ putStrLn (show (prompt st))
1704         ["editor"]   -> liftIO $ putStrLn (show (editor st))
1705         ["stop"]     -> liftIO $ putStrLn (show (stop st))
1706         ["modules" ] -> showModules
1707         ["bindings"] -> showBindings
1708         ["linker"]   -> liftIO showLinkerState
1709         ["breaks"]   -> showBkptTable
1710         ["context"]  -> showContext
1711         ["packages"]  -> showPackages
1712         ["languages"]  -> showLanguages
1713         _ -> ghcError (CmdLineError ("syntax:  :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
1714                                      "               | breaks | context | packages | languages ]"))
1715
1716 showModules :: GHCi ()
1717 showModules = do
1718   loaded_mods <- getLoadedModules
1719         -- we want *loaded* modules only, see #1734
1720   let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)
1721   mapM_ show_one loaded_mods
1722
1723 getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
1724 getLoadedModules = do
1725   graph <- GHC.getModuleGraph
1726   filterM (GHC.isLoaded . GHC.ms_mod_name) graph
1727
1728 showBindings :: GHCi ()
1729 showBindings = do
1730   bindings <- GHC.getBindings
1731   docs     <- pprTypeAndContents
1732                   [ id | AnId id <- sortBy compareTyThings bindings]
1733   printForUserPartWay docs
1734
1735 compareTyThings :: TyThing -> TyThing -> Ordering
1736 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1737
1738 printTyThing :: TyThing -> GHCi ()
1739 printTyThing tyth = do dflags <- getDynFlags
1740                        let pefas = dopt Opt_PrintExplicitForalls dflags
1741                        printForUser (pprTyThing pefas tyth)
1742
1743 showBkptTable :: GHCi ()
1744 showBkptTable = do
1745   st <- getGHCiState
1746   printForUser $ prettyLocations (breaks st)
1747
1748 showContext :: GHCi ()
1749 showContext = do
1750    resumes <- GHC.getResumeContext
1751    printForUser $ vcat (map pp_resume (reverse resumes))
1752   where
1753    pp_resume resume =
1754         ptext (sLit "--> ") <> text (GHC.resumeStmt resume)
1755         $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume))
1756
1757 showPackages :: GHCi ()
1758 showPackages = do
1759   pkg_flags <- fmap packageFlags getDynFlags
1760   liftIO $ putStrLn $ showSDoc $ vcat $
1761     text ("active package flags:"++if null pkg_flags then " none" else "")
1762     : map showFlag pkg_flags
1763   where showFlag (ExposePackage p) = text $ "  -package " ++ p
1764         showFlag (HidePackage p)   = text $ "  -hide-package " ++ p
1765         showFlag (IgnorePackage p) = text $ "  -ignore-package " ++ p
1766         showFlag (ExposePackageId p) = text $ "  -package-id " ++ p
1767
1768 showLanguages :: GHCi ()
1769 showLanguages = do
1770    dflags <- getDynFlags
1771    liftIO $ putStrLn $ showSDoc $ vcat $
1772       text "active language flags:" :
1773       [text ("  -X" ++ str) | (str, f, _) <- DynFlags.xFlags, xopt f dflags]
1774
1775 -- -----------------------------------------------------------------------------
1776 -- Completion
1777
1778 completeCmd, completeMacro, completeIdentifier, completeModule,
1779     completeSetModule,
1780     completeHomeModule, completeSetOptions, completeShowOptions,
1781     completeHomeModuleOrFile, completeExpression
1782     :: CompletionFunc GHCi
1783
1784 ghciCompleteWord :: CompletionFunc GHCi
1785 ghciCompleteWord line@(left,_) = case firstWord of
1786     ':':cmd     | null rest     -> completeCmd line
1787                 | otherwise     -> do
1788                         completion <- lookupCompletion cmd
1789                         completion line
1790     "import"    -> completeModule line
1791     _           -> completeExpression line
1792   where
1793     (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
1794     lookupCompletion ('!':_) = return completeFilename
1795     lookupCompletion c = do
1796         maybe_cmd <- liftIO $ lookupCommand' c
1797         case maybe_cmd of
1798             Just (_,_,f) -> return f
1799             Nothing -> return completeFilename
1800
1801 completeCmd = wrapCompleter " " $ \w -> do
1802   macros <- liftIO $ readIORef macros_ref
1803   let macro_names = map (':':) . map cmdName $ macros
1804   let command_names = map (':':) . map cmdName $ builtin_commands
1805   let{ candidates = case w of
1806       ':' : ':' : _ -> map (':':) command_names
1807       _ -> nub $ macro_names ++ command_names }
1808   return $ filter (w `isPrefixOf`) candidates
1809
1810 completeMacro = wrapIdentCompleter $ \w -> do
1811   cmds <- liftIO $ readIORef macros_ref
1812   return (filter (w `isPrefixOf`) (map cmdName cmds))
1813
1814 completeIdentifier = wrapIdentCompleter $ \w -> do
1815   rdrs <- GHC.getRdrNamesInScope
1816   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1817
1818 completeModule = wrapIdentCompleter $ \w -> do
1819   dflags <- GHC.getSessionDynFlags
1820   let pkg_mods = allExposedModules dflags
1821   loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
1822   return $ filter (w `isPrefixOf`)
1823         $ map (showSDoc.ppr) $ loaded_mods ++ pkg_mods
1824
1825 completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
1826   modules <- case m of
1827     Just '-' -> do
1828       (toplevs, exports) <- GHC.getContext
1829       return $ map GHC.moduleName (nub (map fst exports) ++ toplevs)
1830     _ -> do
1831       dflags <- GHC.getSessionDynFlags
1832       let pkg_mods = allExposedModules dflags
1833       loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
1834       return $ loaded_mods ++ pkg_mods
1835   return $ filter (w `isPrefixOf`) $ map (showSDoc.ppr) modules
1836
1837 completeHomeModule = wrapIdentCompleter listHomeModules
1838
1839 listHomeModules :: String -> GHCi [String]
1840 listHomeModules w = do
1841     g <- GHC.getModuleGraph
1842     let home_mods = map GHC.ms_mod_name g
1843     return $ sort $ filter (w `isPrefixOf`)
1844             $ map (showSDoc.ppr) home_mods
1845
1846 completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
1847   return (filter (w `isPrefixOf`) options)
1848     where options = "args":"prog":"prompt":"editor":"stop":flagList
1849           flagList = map head $ group $ sort allFlags
1850
1851 completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
1852   return (filter (w `isPrefixOf`) options)
1853     where options = ["args", "prog", "prompt", "editor", "stop",
1854                      "modules", "bindings", "linker", "breaks",
1855                      "context", "packages", "languages"]
1856
1857 completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
1858                 $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
1859                             listFiles
1860
1861 unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
1862 unionComplete f1 f2 line = do
1863   cs1 <- f1 line
1864   cs2 <- f2 line
1865   return (cs1 ++ cs2)
1866
1867 wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
1868 wrapCompleter breakChars fun = completeWord Nothing breakChars
1869     $ fmap (map simpleCompletion) . fmap sort . fun
1870
1871 wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
1872 wrapIdentCompleter = wrapCompleter word_break_chars
1873
1874 wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi
1875 wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars
1876     $ \rest -> fmap (map simpleCompletion) . fmap sort . fun (getModifier rest)
1877  where
1878   getModifier = find (`elem` modifChars)
1879
1880 allExposedModules :: DynFlags -> [ModuleName]
1881 allExposedModules dflags
1882  = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1883  where
1884   pkg_db = pkgIdMap (pkgState dflags)
1885
1886 completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
1887                         completeIdentifier
1888
1889 -- ---------------------------------------------------------------------------
1890 -- User code exception handling
1891
1892 -- This is the exception handler for exceptions generated by the
1893 -- user's code and exceptions coming from children sessions;
1894 -- it normally just prints out the exception.  The
1895 -- handler must be recursive, in case showing the exception causes
1896 -- more exceptions to be raised.
1897 --
1898 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1899 -- raising another exception.  We therefore don't put the recursive
1900 -- handler arond the flushing operation, so if stderr is closed
1901 -- GHCi will just die gracefully rather than going into an infinite loop.
1902 handler :: SomeException -> GHCi Bool
1903
1904 handler exception = do
1905   flushInterpBuffers
1906   liftIO installSignalHandlers
1907   ghciHandle handler (showException exception >> return False)
1908
1909 showException :: SomeException -> GHCi ()
1910 showException se =
1911   liftIO $ case fromException se of
1912            -- omit the location for CmdLineError:
1913            Just (CmdLineError s)    -> putStrLn s
1914            -- ditto:
1915            Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
1916            Just other_ghc_ex        -> print other_ghc_ex
1917            Nothing                  ->
1918                case fromException se of
1919                Just UserInterrupt -> putStrLn "Interrupted."
1920                _                  -> putStrLn ("*** Exception: " ++ show se)
1921
1922 -----------------------------------------------------------------------------
1923 -- recursive exception handlers
1924
1925 -- Don't forget to unblock async exceptions in the handler, or if we're
1926 -- in an exception loop (eg. let a = error a in a) the ^C exception
1927 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1928
1929 ghciHandle :: MonadException m => (SomeException -> m a) -> m a -> m a
1930 ghciHandle h m = Haskeline.catch m $ \e -> unblock (h e)
1931
1932 ghciTry :: GHCi a -> GHCi (Either SomeException a)
1933 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
1934
1935 -- ----------------------------------------------------------------------------
1936 -- Utils
1937
1938 -- TODO: won't work if home dir is encoded.
1939 -- (changeDirectory may not work either in that case.)
1940 expandPath :: MonadIO m => String -> InputT m String
1941 expandPath path = do
1942     exp_path <- liftIO $ expandPathIO path
1943     enc <- fmap BS.unpack $ Encoding.encode exp_path
1944     return enc
1945
1946 expandPathIO :: String -> IO String
1947 expandPathIO path =
1948   case dropWhile isSpace path of
1949    ('~':d) -> do
1950         tilde <- getHomeDirectory -- will fail if HOME not defined
1951         return (tilde ++ '/':d)
1952    other ->
1953         return other
1954
1955 wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
1956 wantInterpretedModule str = do
1957    modl <- lookupModule str
1958    dflags <- getDynFlags
1959    when (GHC.modulePackageId modl /= thisPackage dflags) $
1960       ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
1961    is_interpreted <- GHC.moduleIsInterpreted modl
1962    when (not is_interpreted) $
1963        ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
1964    return modl
1965
1966 wantNameFromInterpretedModule :: GHC.GhcMonad m
1967                               => (Name -> SDoc -> m ())
1968                               -> String
1969                               -> (Name -> m ())
1970                               -> m ()
1971 wantNameFromInterpretedModule noCanDo str and_then =
1972   handleSourceError GHC.printException $ do
1973    names <- GHC.parseName str
1974    case names of
1975       []    -> return ()
1976       (n:_) -> do
1977             let modl = ASSERT( isExternalName n ) GHC.nameModule n
1978             if not (GHC.isExternalName n)
1979                then noCanDo n $ ppr n <>
1980                                 text " is not defined in an interpreted module"
1981                else do
1982             is_interpreted <- GHC.moduleIsInterpreted modl
1983             if not is_interpreted
1984                then noCanDo n $ text "module " <> ppr modl <>
1985                                 text " is not interpreted"
1986                else and_then n
1987
1988 -- -----------------------------------------------------------------------------
1989 -- commands for debugger
1990
1991 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1992 sprintCmd = pprintCommand False False
1993 printCmd  = pprintCommand True False
1994 forceCmd  = pprintCommand False True
1995
1996 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1997 pprintCommand bind force str = do
1998   pprintClosureCommand bind force str
1999
2000 stepCmd :: String -> GHCi ()
2001 stepCmd []         = doContinue (const True) GHC.SingleStep
2002 stepCmd expression = runStmt expression GHC.SingleStep >> return ()
2003
2004 stepLocalCmd :: String -> GHCi ()
2005 stepLocalCmd  [] = do
2006   mb_span <- getCurrentBreakSpan
2007   case mb_span of
2008     Nothing  -> stepCmd []
2009     Just loc -> do
2010        Just mod <- getCurrentBreakModule
2011        current_toplevel_decl <- enclosingTickSpan mod loc
2012        doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
2013
2014 stepLocalCmd expression = stepCmd expression
2015
2016 stepModuleCmd :: String -> GHCi ()
2017 stepModuleCmd  [] = do
2018   mb_span <- getCurrentBreakSpan
2019   case mb_span of
2020     Nothing  -> stepCmd []
2021     Just _ -> do
2022        Just span <- getCurrentBreakSpan
2023        let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span
2024        doContinue f GHC.SingleStep
2025
2026 stepModuleCmd expression = stepCmd expression
2027
2028 -- | Returns the span of the largest tick containing the srcspan given
2029 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
2030 enclosingTickSpan mod src = do
2031   ticks <- getTickArray mod
2032   let line = srcSpanStartLine src
2033   ASSERT (inRange (bounds ticks) line) do
2034   let enclosing_spans = [ span | (_,span) <- ticks ! line
2035                                , srcSpanEnd span >= srcSpanEnd src]
2036   return . head . sortBy leftmost_largest $ enclosing_spans
2037
2038 traceCmd :: String -> GHCi ()
2039 traceCmd []         = doContinue (const True) GHC.RunAndLogSteps
2040 traceCmd expression = runStmt expression GHC.RunAndLogSteps >> return ()
2041
2042 continueCmd :: String -> GHCi ()
2043 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
2044
2045 -- doContinue :: SingleStep -> GHCi ()
2046 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
2047 doContinue pred step = do
2048   runResult <- resume pred step
2049   _ <- afterRunStmt pred runResult
2050   return ()
2051
2052 abandonCmd :: String -> GHCi ()
2053 abandonCmd = noArgs $ do
2054   b <- GHC.abandon -- the prompt will change to indicate the new context
2055   when (not b) $ liftIO $ putStrLn "There is no computation running."
2056
2057 deleteCmd :: String -> GHCi ()
2058 deleteCmd argLine = do
2059    deleteSwitch $ words argLine
2060    where
2061    deleteSwitch :: [String] -> GHCi ()
2062    deleteSwitch [] =
2063       liftIO $ putStrLn "The delete command requires at least one argument."
2064    -- delete all break points
2065    deleteSwitch ("*":_rest) = discardActiveBreakPoints
2066    deleteSwitch idents = do
2067       mapM_ deleteOneBreak idents
2068       where
2069       deleteOneBreak :: String -> GHCi ()
2070       deleteOneBreak str
2071          | all isDigit str = deleteBreak (read str)
2072          | otherwise = return ()
2073
2074 historyCmd :: String -> GHCi ()
2075 historyCmd arg
2076   | null arg        = history 20
2077   | all isDigit arg = history (read arg)
2078   | otherwise       = liftIO $ putStrLn "Syntax:  :history [num]"
2079   where
2080   history num = do
2081     resumes <- GHC.getResumeContext
2082     case resumes of
2083       [] -> liftIO $ putStrLn "Not stopped at a breakpoint"
2084       (r:_) -> do
2085         let hist = GHC.resumeHistory r
2086             (took,rest) = splitAt num hist
2087         case hist of
2088           [] -> liftIO $ putStrLn $
2089                    "Empty history. Perhaps you forgot to use :trace?"
2090           _  -> do
2091                  spans <- mapM GHC.getHistorySpan took
2092                  let nums  = map (printf "-%-3d:") [(1::Int)..]
2093                      names = map GHC.historyEnclosingDecls took
2094                  printForUser (vcat(zipWith3
2095                                  (\x y z -> x <+> y <+> z)
2096                                  (map text nums)
2097                                  (map (bold . hcat . punctuate colon . map text) names)
2098                                  (map (parens . ppr) spans)))
2099                  liftIO $ putStrLn $ if null rest then "<end of history>" else "..."
2100
2101 bold :: SDoc -> SDoc
2102 bold c | do_bold   = text start_bold <> c <> text end_bold
2103        | otherwise = c
2104
2105 backCmd :: String -> GHCi ()
2106 backCmd = noArgs $ do
2107   (names, _, span) <- GHC.back
2108   printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span
2109   printTypeOfNames names
2110    -- run the command set with ":set stop <cmd>"
2111   st <- getGHCiState
2112   enqueueCommands [stop st]
2113
2114 forwardCmd :: String -> GHCi ()
2115 forwardCmd = noArgs $ do
2116   (names, ix, span) <- GHC.forward
2117   printForUser $ (if (ix == 0)
2118                     then ptext (sLit "Stopped at")
2119                     else ptext (sLit "Logged breakpoint at")) <+> ppr span
2120   printTypeOfNames names
2121    -- run the command set with ":set stop <cmd>"
2122   st <- getGHCiState
2123   enqueueCommands [stop st]
2124
2125 -- handle the "break" command
2126 breakCmd :: String -> GHCi ()
2127 breakCmd argLine = do
2128    breakSwitch $ words argLine
2129
2130 breakSwitch :: [String] -> GHCi ()
2131 breakSwitch [] = do
2132    liftIO $ putStrLn "The break command requires at least one argument."
2133 breakSwitch (arg1:rest)
2134    | looksLikeModuleName arg1 && not (null rest) = do
2135         mod <- wantInterpretedModule arg1
2136         breakByModule mod rest
2137    | all isDigit arg1 = do
2138         (toplevel, _) <- GHC.getContext
2139         case toplevel of
2140            (mod : _) -> breakByModuleLine mod (read arg1) rest
2141            [] -> do
2142               liftIO $ putStrLn "Cannot find default module for breakpoint."
2143               liftIO $ putStrLn "Perhaps no modules are loaded for debugging?"
2144    | otherwise = do -- try parsing it as an identifier
2145         wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
2146         let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2147         if GHC.isGoodSrcLoc loc
2148                then ASSERT( isExternalName name )
2149                     findBreakAndSet (GHC.nameModule name) $
2150                          findBreakByCoord (Just (GHC.srcLocFile loc))
2151                                           (GHC.srcLocLine loc,
2152                                            GHC.srcLocCol loc)
2153                else noCanDo name $ text "can't find its location: " <> ppr loc
2154        where
2155           noCanDo n why = printForUser $
2156                 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
2157
2158 breakByModule :: Module -> [String] -> GHCi ()
2159 breakByModule mod (arg1:rest)
2160    | all isDigit arg1 = do  -- looks like a line number
2161         breakByModuleLine mod (read arg1) rest
2162 breakByModule _ _
2163    = breakSyntax
2164
2165 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
2166 breakByModuleLine mod line args
2167    | [] <- args = findBreakAndSet mod $ findBreakByLine line
2168    | [col] <- args, all isDigit col =
2169         findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
2170    | otherwise = breakSyntax
2171
2172 breakSyntax :: a
2173 breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
2174
2175 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
2176 findBreakAndSet mod lookupTickTree = do
2177    tickArray <- getTickArray mod
2178    (breakArray, _) <- getModBreak mod
2179    case lookupTickTree tickArray of
2180       Nothing  -> liftIO $ putStrLn $ "No breakpoints found at that location."
2181       Just (tick, span) -> do
2182          success <- liftIO $ setBreakFlag True breakArray tick
2183          if success
2184             then do
2185                (alreadySet, nm) <-
2186                      recordBreak $ BreakLocation
2187                              { breakModule = mod
2188                              , breakLoc = span
2189                              , breakTick = tick
2190                              , onBreakCmd = ""
2191                              }
2192                printForUser $
2193                   text "Breakpoint " <> ppr nm <>
2194                   if alreadySet
2195                      then text " was already set at " <> ppr span
2196                      else text " activated at " <> ppr span
2197             else do
2198             printForUser $ text "Breakpoint could not be activated at"
2199                                  <+> ppr span
2200
2201 -- When a line number is specified, the current policy for choosing
2202 -- the best breakpoint is this:
2203 --    - the leftmost complete subexpression on the specified line, or
2204 --    - the leftmost subexpression starting on the specified line, or
2205 --    - the rightmost subexpression enclosing the specified line
2206 --
2207 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2208 findBreakByLine line arr
2209   | not (inRange (bounds arr) line) = Nothing
2210   | otherwise =
2211     listToMaybe (sortBy (leftmost_largest `on` snd)  complete)   `mplus`
2212     listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2213     listToMaybe (sortBy (rightmost `on` snd) ticks)
2214   where
2215         ticks = arr ! line
2216
2217         starts_here = [ tick | tick@(_,span) <- ticks,
2218                                GHC.srcSpanStartLine span == line ]
2219
2220         (complete,incomplete) = partition ends_here starts_here
2221             where ends_here (_,span) = GHC.srcSpanEndLine span == line
2222
2223 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2224                  -> Maybe (BreakIndex,SrcSpan)
2225 findBreakByCoord mb_file (line, col) arr
2226   | not (inRange (bounds arr) line) = Nothing
2227   | otherwise =
2228     listToMaybe (sortBy (rightmost `on` snd) contains ++
2229                  sortBy (leftmost_smallest `on` snd) after_here)
2230   where
2231         ticks = arr ! line
2232
2233         -- the ticks that span this coordinate
2234         contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2235                             is_correct_file span ]
2236
2237         is_correct_file span
2238                  | Just f <- mb_file = GHC.srcSpanFile span == f
2239                  | otherwise         = True
2240
2241         after_here = [ tick | tick@(_,span) <- ticks,
2242                               GHC.srcSpanStartLine span == line,
2243                               GHC.srcSpanStartCol span >= col ]
2244
2245 -- For now, use ANSI bold on terminals that we know support it.
2246 -- Otherwise, we add a line of carets under the active expression instead.
2247 -- In particular, on Windows and when running the testsuite (which sets
2248 -- TERM to vt100 for other reasons) we get carets.
2249 -- We really ought to use a proper termcap/terminfo library.
2250 do_bold :: Bool
2251 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2252     where mTerm = System.Environment.getEnv "TERM"
2253                   `catchIO` \_ -> return "TERM not set"
2254
2255 start_bold :: String
2256 start_bold = "\ESC[1m"
2257 end_bold :: String
2258 end_bold   = "\ESC[0m"
2259
2260 listCmd :: String -> InputT GHCi ()
2261 listCmd c = listCmd' c
2262
2263 listCmd' :: String -> InputT GHCi ()
2264 listCmd' "" = do
2265    mb_span <- lift getCurrentBreakSpan
2266    case mb_span of
2267       Nothing ->
2268           printForUser $ text "Not stopped at a breakpoint; nothing to list"
2269       Just span
2270        | GHC.isGoodSrcSpan span -> listAround span True
2271        | otherwise ->
2272           do resumes <- GHC.getResumeContext
2273              case resumes of
2274                  [] -> panic "No resumes"
2275                  (r:_) ->
2276                      do let traceIt = case GHC.resumeHistory r of
2277                                       [] -> text "rerunning with :trace,"
2278                                       _ -> empty
2279                             doWhat = traceIt <+> text ":back then :list"
2280                         printForUser (text "Unable to list source for" <+>
2281                                       ppr span
2282                                    $$ text "Try" <+> doWhat)
2283 listCmd' str = list2 (words str)
2284
2285 list2 :: [String] -> InputT GHCi ()
2286 list2 [arg] | all isDigit arg = do
2287     (toplevel, _) <- GHC.getContext
2288     case toplevel of
2289         [] -> liftIO $ putStrLn "No module to list"
2290         (mod : _) -> listModuleLine mod (read arg)
2291 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2292         mod <- wantInterpretedModule arg1
2293         listModuleLine mod (read arg2)
2294 list2 [arg] = do
2295         wantNameFromInterpretedModule noCanDo arg $ \name -> do
2296         let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2297         if GHC.isGoodSrcLoc loc
2298                then do
2299                   tickArray <- ASSERT( isExternalName name )
2300                                lift $ getTickArray (GHC.nameModule name)
2301                   let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2302                                         (GHC.srcLocLine loc, GHC.srcLocCol loc)
2303                                         tickArray
2304                   case mb_span of
2305                     Nothing       -> listAround (GHC.srcLocSpan loc) False
2306                     Just (_,span) -> listAround span False
2307                else
2308                   noCanDo name $ text "can't find its location: " <>
2309                                  ppr loc
2310     where
2311         noCanDo n why = printForUser $
2312             text "cannot list source code for " <> ppr n <> text ": " <> why
2313 list2  _other =
2314         liftIO $ putStrLn "syntax:  :list [<line> | <module> <line> | <identifier>]"
2315
2316 listModuleLine :: Module -> Int -> InputT GHCi ()
2317 listModuleLine modl line = do
2318    graph <- GHC.getModuleGraph
2319    let this = filter ((== modl) . GHC.ms_mod) graph
2320    case this of
2321      [] -> panic "listModuleLine"
2322      summ:_ -> do
2323            let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
2324                loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2325            listAround (GHC.srcLocSpan loc) False
2326
2327 -- | list a section of a source file around a particular SrcSpan.
2328 -- If the highlight flag is True, also highlight the span using
2329 -- start_bold\/end_bold.
2330
2331 -- GHC files are UTF-8, so we can implement this by:
2332 -- 1) read the file in as a BS and syntax highlight it as before
2333 -- 2) convert the BS to String using utf-string, and write it out.
2334 -- It would be better if we could convert directly between UTF-8 and the
2335 -- console encoding, of course.
2336 listAround :: MonadIO m => SrcSpan -> Bool -> InputT m ()
2337 listAround span do_highlight = do
2338       contents <- liftIO $ BS.readFile (unpackFS file)
2339       let
2340           lines = BS.split '\n' contents
2341           these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2342                         drop (line1 - 1 - pad_before) $ lines
2343           fst_line = max 1 (line1 - pad_before)
2344           line_nos = [ fst_line .. ]
2345
2346           highlighted | do_highlight = zipWith highlight line_nos these_lines
2347                       | otherwise    = [\p -> BS.concat[p,l] | l <- these_lines]
2348
2349           bs_line_nos = [ BS.pack (show l ++ "  ") | l <- line_nos ]
2350           prefixed = zipWith ($) highlighted bs_line_nos
2351       --
2352       let output = BS.intercalate (BS.pack "\n") prefixed
2353       utf8Decoded <- liftIO $ BS.useAsCStringLen output
2354                         $ \(p,n) -> utf8DecodeString (castPtr p) n
2355       liftIO $ putStrLn utf8Decoded
2356   where
2357         file  = GHC.srcSpanFile span
2358         line1 = GHC.srcSpanStartLine span
2359         col1  = GHC.srcSpanStartCol span - 1
2360         line2 = GHC.srcSpanEndLine span
2361         col2  = GHC.srcSpanEndCol span - 1
2362
2363         pad_before | line1 == 1 = 0
2364                    | otherwise  = 1
2365         pad_after = 1
2366
2367         highlight | do_bold   = highlight_bold
2368                   | otherwise = highlight_carets
2369
2370         highlight_bold no line prefix
2371           | no == line1 && no == line2
2372           = let (a,r) = BS.splitAt col1 line
2373                 (b,c) = BS.splitAt (col2-col1) r
2374             in
2375             BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2376           | no == line1
2377           = let (a,b) = BS.splitAt col1 line in
2378             BS.concat [prefix, a, BS.pack start_bold, b]
2379           | no == line2
2380           = let (a,b) = BS.splitAt col2 line in
2381             BS.concat [prefix, a, BS.pack end_bold, b]
2382           | otherwise   = BS.concat [prefix, line]
2383
2384         highlight_carets no line prefix
2385           | no == line1 && no == line2
2386           = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2387                                          BS.replicate (col2-col1) '^']
2388           | no == line1
2389           = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2390                                          prefix, line]
2391           | no == line2
2392           = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2393                                          BS.pack "^^"]
2394           | otherwise   = BS.concat [prefix, line]
2395          where
2396            indent = BS.pack ("  " ++ replicate (length (show no)) ' ')
2397            nl = BS.singleton '\n'
2398
2399 -- --------------------------------------------------------------------------
2400 -- Tick arrays
2401
2402 getTickArray :: Module -> GHCi TickArray
2403 getTickArray modl = do
2404    st <- getGHCiState
2405    let arrmap = tickarrays st
2406    case lookupModuleEnv arrmap modl of
2407       Just arr -> return arr
2408       Nothing  -> do
2409         (_breakArray, ticks) <- getModBreak modl
2410         let arr = mkTickArray (assocs ticks)
2411         setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2412         return arr
2413
2414 discardTickArrays :: GHCi ()
2415 discardTickArrays = do
2416    st <- getGHCiState
2417    setGHCiState st{tickarrays = emptyModuleEnv}
2418
2419 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2420 mkTickArray ticks
2421   = accumArray (flip (:)) [] (1, max_line)
2422         [ (line, (nm,span)) | (nm,span) <- ticks,
2423                               line <- srcSpanLines span ]
2424     where
2425         max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2426         srcSpanLines span = [ GHC.srcSpanStartLine span ..
2427                               GHC.srcSpanEndLine span ]
2428
2429 lookupModule :: GHC.GhcMonad m => String -> m Module
2430 lookupModule modName
2431    = GHC.lookupModule (GHC.mkModuleName modName) Nothing
2432
2433 -- don't reset the counter back to zero?
2434 discardActiveBreakPoints :: GHCi ()
2435 discardActiveBreakPoints = do
2436    st <- getGHCiState
2437    mapM_ (turnOffBreak.snd) (breaks st)
2438    setGHCiState $ st { breaks = [] }
2439
2440 deleteBreak :: Int -> GHCi ()
2441 deleteBreak identity = do
2442    st <- getGHCiState
2443    let oldLocations    = breaks st
2444        (this,rest)     = partition (\loc -> fst loc == identity) oldLocations
2445    if null this
2446       then printForUser (text "Breakpoint" <+> ppr identity <+>
2447                          text "does not exist")
2448       else do
2449            mapM_ (turnOffBreak.snd) this
2450            setGHCiState $ st { breaks = rest }
2451
2452 turnOffBreak :: BreakLocation -> GHCi Bool
2453 turnOffBreak loc = do
2454   (arr, _) <- getModBreak (breakModule loc)
2455   liftIO $ setBreakFlag False arr (breakTick loc)
2456
2457 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2458 getModBreak mod = do
2459    Just mod_info <- GHC.getModuleInfo mod
2460    let modBreaks  = GHC.modInfoModBreaks mod_info
2461    let array      = GHC.modBreaks_flags modBreaks
2462    let ticks      = GHC.modBreaks_locs  modBreaks
2463    return (array, ticks)
2464
2465 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2466 setBreakFlag toggle array index
2467    | toggle    = GHC.setBreakOn array index
2468    | otherwise = GHC.setBreakOff array index