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