compiler/ghci/InteractiveUI.hs

   1 {-# OPTIONS -#include "Linker.h" #-}
   2 -----------------------------------------------------------------------------
   3 --
   4 -- GHC Interactive User Interface
   5 --
   6 -- (c) The GHC Team 2005-2006
   7 --
   8 -----------------------------------------------------------------------------
   9 module InteractiveUI (
  10         interactiveUI,
  11         ghciWelcomeMsg
  12    ) where
  13
  14 #include "HsVersions.h"
  15
  16 import GhciMonad
  17
  18 -- The GHC interface
  19 import qualified GHC
  20 import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
  21                           Type, Module, ModuleName, TyThing(..), Phase )
  22 import DynFlags
  23 import Packages
  24 import PackageConfig
  25 import UniqFM
  26 import PprTyThing
  27 import Outputable
  28
  29 -- for createtags
  30 import Name
  31 import OccName
  32 import SrcLoc
  33
  34 -- Other random utilities
  35 import Digraph
  36 import BasicTypes hiding (isTopLevel)
  37 import Panic      hiding (showException)
  38 import Config
  39 import StaticFlags
  40 import Linker
  41 import Util
  42
  43 -- The debugger
  44 import Debugger
  45 import HscTypes
  46 import Id
  47 import Var       ( globaliseId )
  48 import IdInfo
  49 import NameEnv
  50 import RdrName
  51 import Module
  52 import Type
  53 import TcType
  54
  55 #ifndef mingw32_HOST_OS
  56 import System.Posix
  57 #if __GLASGOW_HASKELL__ > 504
  58         hiding (getEnv)
  59 #endif
  60 #else
  61 import GHC.ConsoleHandler ( flushConsole )
  62 import System.Win32       ( setConsoleCP, setConsoleOutputCP )
  63 import qualified System.Win32
  64 #endif
  65
  66 #ifdef USE_READLINE
  67 import Control.Concurrent       ( yield )       -- Used in readline loop
  68 import System.Console.Readline as Readline
  69 #endif
  70
  71 --import SystemExts
  72
  73 import Control.Exception as Exception
  74 -- import Control.Concurrent
  75
  76 import Data.List
  77 import Data.Maybe       ( isJust, isNothing, fromMaybe, catMaybes )
  78 import System.Cmd
  79 import System.Environment
  80 import System.Exit      ( exitWith, ExitCode(..) )
  81 import System.Directory
  82 import System.IO
  83 import System.IO.Error as IO
  84 import Data.Char
  85 import Data.Dynamic
  86 import Data.Array
  87 import Control.Monad as Monad
  88 import Foreign.StablePtr        ( StablePtr, newStablePtr, deRefStablePtr, freeStablePtr )
  89
  90 import GHC.Exts         ( unsafeCoerce# )
  91 import GHC.IOBase       ( IOErrorType(InvalidArgument), IO(IO) )
  92
  93 import Data.IORef       ( IORef, readIORef, writeIORef )
  94
  95 import System.Posix.Internals ( setNonBlockingFD )
  96
  97 -- these are needed by the new ghci debugger
  98 import ByteCodeLink (HValue)
  99 import ByteCodeInstr (BreakInfo (..))
 100 import BreakArray
 101 import TickTree
 102
 103 -----------------------------------------------------------------------------
 104
 105 ghciWelcomeMsg =
 106  "   ___         ___ _\n"++
 107  "  / _ \\ /\\  /\\/ __(_)\n"++
 108  " / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
 109  "/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n"++
 110  "\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
 111
 112 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
 113 cmdName (n,_,_,_) = n
 114
 115 GLOBAL_VAR(commands, builtin_commands, [Command])
 116
 117 builtin_commands :: [Command]
 118 builtin_commands = [
 119         -- Hugs users are accustomed to :e, so make sure it doesn't overlap
 120   ("?",         keepGoing help,                 False, completeNone),
 121   ("add",       tlC$ keepGoingPaths addModule,  False, completeFilename),
 122   ("break",     breakCmd, False, completeNone),
 123   ("browse",    keepGoing browseCmd,            False, completeModule),
 124   ("cd",        tlC$ keepGoing changeDirectory, False, completeFilename),
 125   ("check",     keepGoing checkModule,          False, completeHomeModule),
 126   ("continue",  continueCmd, False, completeNone),
 127   ("ctags",     keepGoing createCTagsFileCmd,   False, completeFilename),
 128   ("def",       keepGoing defineMacro,          False, completeIdentifier),
 129   ("delete",    deleteCmd, False, completeNone),
 130   ("e",         keepGoing editFile,             False, completeFilename),
 131   ("edit",      keepGoing editFile,             False, completeFilename),
 132   ("etags",     keepGoing createETagsFileCmd,   False, completeFilename),
 133   ("force",     keepGoing (pprintClosureCommand False True), False, completeIdentifier),
 134   ("help",      keepGoing help,                 False, completeNone),
 135   ("info",      keepGoing info,                 False, completeIdentifier),
 136   ("kind",      keepGoing kindOfType,           False, completeIdentifier),
 137   ("load",      tlC$ keepGoingPaths loadModule_,False, completeHomeModuleOrFile),
 138   ("module",    keepGoing setContext,           False, completeModule),
 139   ("main",      tlC$ keepGoing runMain,         False, completeIdentifier),
 140   ("print",     keepGoing (pprintClosureCommand True False), False, completeIdentifier),
 141   ("quit",      quit,                           False, completeNone),
 142   ("reload",    tlC$ keepGoing reloadModule,    False, completeNone),
 143   ("set",       keepGoing setCmd,               True,  completeSetOptions),
 144   ("show",      keepGoing showCmd,              False, completeNone),
 145   ("sprint",    keepGoing (pprintClosureCommand False False),False, completeIdentifier),
 146   ("step",      stepCmd, False, completeNone),
 147   ("type",      keepGoing typeOfExpr,           False, completeIdentifier),
 148   ("undef",     keepGoing undefineMacro,        False, completeMacro),
 149   ("unset",     keepGoing unsetOptions,         True,  completeSetOptions)
 150   ]
 151
 152 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 153 keepGoing a str = a str >> return False
 154
 155 -- tlC: Top Level Command, not allowed in inferior sessions
 156 tlC ::  (String -> GHCi Bool) -> (String -> GHCi Bool)
 157 tlC a str = do
 158     top_level <- isTopLevel
 159     if not top_level
 160        then throwDyn (CmdLineError "Command only allowed at Top Level")
 161        else a str
 162
 163 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
 164 keepGoingPaths a str = a (toArgs str) >> return False
 165
 166 shortHelpText = "use :? for help.\n"
 167
 168 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
 169 helpText =
 170  " Commands available from the prompt:\n" ++
 171  "\n" ++
 172  "   <stmt>                      evaluate/run <stmt>\n" ++
 173  "   :add <filename> ...         add module(s) to the current target set\n" ++
 174  "   :browse [*]<module>         display the names defined by <module>\n" ++
 175  "   :cd <dir>                   change directory to <dir>\n" ++
 176  "   :def <cmd> <expr>           define a command :<cmd>\n" ++
 177  "   :edit <file>                edit file\n" ++
 178  "   :edit                       edit last module\n" ++
 179  "   :help, :?                   display this list of commands\n" ++
 180  "   :info [<name> ...]          display information about the given names\n" ++
 181  "   :print [<name> ...]         prints a value without forcing its computation\n" ++
 182  "   :sprint [<name> ...]        simplified version of :print\n" ++
 183  "   :load <filename> ...        load module(s) and their dependents\n" ++
 184  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
 185  "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
 186  "   :reload                     reload the current module set\n" ++
 187  "\n" ++
 188  "   :set <option> ...           set options\n" ++
 189  "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
 190  "   :set prog <progname>        set the value returned by System.getProgName\n" ++
 191  "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
 192  "   :set editor <cmd>           set the command used for :edit\n" ++
 193  "\n" ++
 194  "   :show modules               show the currently loaded modules\n" ++
 195  "   :show bindings              show the current bindings made at the prompt\n" ++
 196  "\n" ++
 197  "   :ctags [<file>]             create tags file for Vi (default: \"tags\")\n" ++
 198  "   :etags [<file>]             create tags file for Emacs (default: \"TAGS\")\n" ++
 199  "   :type <expr>                show the type of <expr>\n" ++
 200  "   :kind <type>                show the kind of <type>\n" ++
 201  "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
 202  "   :unset <option> ...         unset options\n" ++
 203  "   :quit                       exit GHCi\n" ++
 204  "   :!<command>                 run the shell command <command>\n" ++
 205  "\n" ++
 206  " Options for ':set' and ':unset':\n" ++
 207  "\n" ++
 208  "    +r            revert top-level expressions after each evaluation\n" ++
 209  "    +s            print timing/memory stats after each evaluation\n" ++
 210  "    +t            print type after evaluation\n" ++
 211  "    -<flags>      most GHC command line flags can also be set here\n" ++
 212  "                         (eg. -v2, -fglasgow-exts, etc.)\n" ++
 213  "\n"
 214 -- Todo: add help for breakpoint commands here
 215
 216 findEditor = do
 217   getEnv "EDITOR"
 218     `IO.catch` \_ -> do
 219 #if mingw32_HOST_OS
 220         win <- System.Win32.getWindowsDirectory
 221         return (win `joinFileName` "notepad.exe")
 222 #else
 223         return ""
 224 #endif
 225
 226 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
 227 interactiveUI session srcs maybe_expr = do
 228    -- HACK! If we happen to get into an infinite loop (eg the user
 229    -- types 'let x=x in x' at the prompt), then the thread will block
 230    -- on a blackhole, and become unreachable during GC.  The GC will
 231    -- detect that it is unreachable and send it the NonTermination
 232    -- exception.  However, since the thread is unreachable, everything
 233    -- it refers to might be finalized, including the standard Handles.
 234    -- This sounds like a bug, but we don't have a good solution right
 235    -- now.
 236    newStablePtr stdin
 237    newStablePtr stdout
 238    newStablePtr stderr
 239
 240         -- Initialise buffering for the *interpreted* I/O system
 241    initInterpBuffering session
 242
 243    when (isNothing maybe_expr) $ do
 244         -- Only for GHCi (not runghc and ghc -e):
 245         -- Turn buffering off for the compiled program's stdout/stderr
 246         turnOffBuffering
 247         -- Turn buffering off for GHCi's stdout
 248         hFlush stdout
 249         hSetBuffering stdout NoBuffering
 250         -- We don't want the cmd line to buffer any input that might be
 251         -- intended for the program, so unbuffer stdin.
 252         hSetBuffering stdin NoBuffering
 253
 254         -- initial context is just the Prelude
 255    prel_mod <- GHC.findModule session prel_name (Just basePackageId)
 256    GHC.setContext session [] [prel_mod]
 257
 258 #ifdef USE_READLINE
 259    Readline.initialize
 260    Readline.setAttemptedCompletionFunction (Just completeWord)
 261    --Readline.parseAndBind "set show-all-if-ambiguous 1"
 262
 263    let symbols = "!#$%&*+/<=>?@\\^|-~"
 264        specials = "(),;[]`{}"
 265        spaces = " \t\n"
 266        word_break_chars = spaces ++ specials ++ symbols
 267
 268    Readline.setBasicWordBreakCharacters word_break_chars
 269    Readline.setCompleterWordBreakCharacters word_break_chars
 270 #endif
 271
 272    default_editor <- findEditor
 273
 274    startGHCi (runGHCi srcs maybe_expr)
 275         GHCiState{ progname = "<interactive>",
 276                    args = [],
 277                    prompt = "%s> ",
 278                    editor = default_editor,
 279                    session = session,
 280                    options = [],
 281                    prelude = prel_mod,
 282                    topLevel = True,
 283                    resume = [],
 284                    breaks = emptyActiveBreakPoints
 285                  }
 286
 287 #ifdef USE_READLINE
 288    Readline.resetTerminal Nothing
 289 #endif
 290
 291    return ()
 292
 293 prel_name = GHC.mkModuleName "Prelude"
 294
 295 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
 296 runGHCi paths maybe_expr = do
 297   let read_dot_files = not opt_IgnoreDotGhci
 298
 299   when (read_dot_files) $ do
 300     -- Read in ./.ghci.
 301     let file = "./.ghci"
 302     exists <- io (doesFileExist file)
 303     when exists $ do
 304        dir_ok  <- io (checkPerms ".")
 305        file_ok <- io (checkPerms file)
 306        when (dir_ok && file_ok) $ do
 307           either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
 308           case either_hdl of
 309              Left e    -> return ()
 310              Right hdl -> fileLoop hdl False
 311
 312   when (read_dot_files) $ do
 313     -- Read in $HOME/.ghci
 314     either_dir <- io (IO.try (getEnv "HOME"))
 315     case either_dir of
 316        Left e -> return ()
 317        Right dir -> do
 318           cwd <- io (getCurrentDirectory)
 319           when (dir /= cwd) $ do
 320              let file = dir ++ "/.ghci"
 321              ok <- io (checkPerms file)
 322              when ok $ do
 323                either_hdl <- io (IO.try (openFile file ReadMode))
 324                case either_hdl of
 325                   Left e    -> return ()
 326                   Right hdl -> fileLoop hdl False
 327
 328   -- Perform a :load for files given on the GHCi command line
 329   -- When in -e mode, if the load fails then we want to stop
 330   -- immediately rather than going on to evaluate the expression.
 331   when (not (null paths)) $ do
 332      ok <- ghciHandle (\e -> do showException e; return Failed) $
 333                 loadModule paths
 334      when (isJust maybe_expr && failed ok) $
 335         io (exitWith (ExitFailure 1))
 336
 337   -- if verbosity is greater than 0, or we are connected to a
 338   -- terminal, display the prompt in the interactive loop.
 339   is_tty <- io (hIsTerminalDevice stdin)
 340   dflags <- getDynFlags
 341   let show_prompt = verbosity dflags > 0 || is_tty
 342
 343   case maybe_expr of
 344         Nothing ->
 345           do
 346 #if defined(mingw32_HOST_OS)
 347             -- The win32 Console API mutates the first character of
 348             -- type-ahead when reading from it in a non-buffered manner. Work
 349             -- around this by flushing the input buffer of type-ahead characters,
 350             -- but only if stdin is available.
 351             flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
 352             case flushed of
 353              Left err | isDoesNotExistError err -> return ()
 354                       | otherwise -> io (ioError err)
 355              Right () -> return ()
 356 #endif
 357             -- initialise the console if necessary
 358             io setUpConsole
 359
 360             -- enter the interactive loop
 361             interactiveLoop is_tty show_prompt
 362         Just expr -> do
 363             -- just evaluate the expression we were given
 364             runCommandEval expr
 365             return ()
 366
 367   -- and finally, exit
 368   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
 369
 370
 371 interactiveLoop is_tty show_prompt =
 372   -- Ignore ^C exceptions caught here
 373   ghciHandleDyn (\e -> case e of
 374                         Interrupted -> do
 375 #if defined(mingw32_HOST_OS)
 376                                 io (putStrLn "")
 377 #endif
 378                                 interactiveLoop is_tty show_prompt
 379                         _other      -> return ()) $
 380
 381   ghciUnblock $ do -- unblock necessary if we recursed from the
 382                    -- exception handler above.
 383
 384   -- read commands from stdin
 385 #ifdef USE_READLINE
 386   if (is_tty)
 387         then readlineLoop
 388         else fileLoop stdin show_prompt
 389 #else
 390   fileLoop stdin show_prompt
 391 #endif
 392
 393
 394 -- NOTE: We only read .ghci files if they are owned by the current user,
 395 -- and aren't world writable.  Otherwise, we could be accidentally
 396 -- running code planted by a malicious third party.
 397
 398 -- Furthermore, We only read ./.ghci if . is owned by the current user
 399 -- and isn't writable by anyone else.  I think this is sufficient: we
 400 -- don't need to check .. and ../.. etc. because "."  always refers to
 401 -- the same directory while a process is running.
 402
 403 checkPerms :: String -> IO Bool
 404 checkPerms name =
 405 #ifdef mingw32_HOST_OS
 406   return True
 407 #else
 408   Util.handle (\_ -> return False) $ do
 409      st <- getFileStatus name
 410      me <- getRealUserID
 411      if fileOwner st /= me then do
 412         putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
 413         return False
 414       else do
 415         let mode =  fileMode st
 416         if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
 417            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
 418            then do
 419                putStrLn $ "*** WARNING: " ++ name ++
 420                           " is writable by someone else, IGNORING!"
 421                return False
 422           else return True
 423 #endif
 424
 425 fileLoop :: Handle -> Bool -> GHCi ()
 426 fileLoop hdl show_prompt = do
 427    session <- getSession
 428    (mod,imports) <- io (GHC.getContext session)
 429    st <- getGHCiState
 430    when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
 431    l <- io (IO.try (hGetLine hdl))
 432    case l of
 433         Left e | isEOFError e              -> return ()
 434                | InvalidArgument <- etype  -> return ()
 435                | otherwise                 -> io (ioError e)
 436                 where etype = ioeGetErrorType e
 437                 -- treat InvalidArgument in the same way as EOF:
 438                 -- this can happen if the user closed stdin, or
 439                 -- perhaps did getContents which closes stdin at
 440                 -- EOF.
 441         Right l ->
 442           case removeSpaces l of
 443             "" -> fileLoop hdl show_prompt
 444             l  -> do quit <- runCommand l
 445                      if quit then return () else fileLoop hdl show_prompt
 446
 447 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
 448 stringLoop [] = return False
 449 stringLoop (s:ss) = do
 450    case removeSpaces s of
 451         "" -> stringLoop ss
 452         l  -> do quit <- runCommand l
 453                  if quit then return True else stringLoop ss
 454
 455 mkPrompt toplevs exports prompt
 456   = showSDoc $ f prompt
 457     where
 458         f ('%':'s':xs) = perc_s <> f xs
 459         f ('%':'%':xs) = char '%' <> f xs
 460         f (x:xs) = char x <> f xs
 461         f [] = empty
 462
 463         perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
 464                  hsep (map (ppr . GHC.moduleName) exports)
 465
 466
 467 #ifdef USE_READLINE
 468 readlineLoop :: GHCi ()
 469 readlineLoop = do
 470    session <- getSession
 471    (mod,imports) <- io (GHC.getContext session)
 472    io yield
 473    saveSession -- for use by completion
 474    st <- getGHCiState
 475    l <- io (readline (mkPrompt mod imports (prompt st))
 476                 `finally` setNonBlockingFD 0)
 477                 -- readline sometimes puts stdin into blocking mode,
 478                 -- so we need to put it back for the IO library
 479    splatSavedSession
 480    case l of
 481         Nothing -> return ()
 482         Just l  ->
 483           case removeSpaces l of
 484             "" -> readlineLoop
 485             l  -> do
 486                   io (addHistory l)
 487                   quit <- runCommand l
 488                   if quit then return () else readlineLoop
 489 #endif
 490
 491 runCommand :: String -> GHCi Bool
 492 runCommand c = ghciHandle handler (doCommand c)
 493   where
 494     doCommand (':' : command) = specialCommand command
 495     doCommand stmt
 496        = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
 497             return False
 498
 499 -- This version is for the GHC command-line option -e.  The only difference
 500 -- from runCommand is that it catches the ExitException exception and
 501 -- exits, rather than printing out the exception.
 502 runCommandEval c = ghciHandle handleEval (doCommand c)
 503   where
 504     handleEval (ExitException code) = io (exitWith code)
 505     handleEval e                    = do handler e
 506                                          io (exitWith (ExitFailure 1))
 507
 508     doCommand (':' : command) = specialCommand command
 509     doCommand stmt
 510        = do nms <- runStmt stmt
 511             case nms of
 512                 Nothing -> io (exitWith (ExitFailure 1))
 513                   -- failure to run the command causes exit(1) for ghc -e.
 514                 _       -> finishEvalExpr nms
 515
 516 runStmt :: String -> GHCi (Maybe [Name])
 517 runStmt stmt
 518  | null (filter (not.isSpace) stmt) = return (Just [])
 519  | otherwise
 520  = do st <- getGHCiState
 521       session <- getSession
 522       result <- io $ withProgName (progname st) $ withArgs (args st) $
 523                      GHC.runStmt session stmt
 524       switchOnRunResult result
 525
 526 switchOnRunResult :: GHC.RunResult -> GHCi (Maybe [Name])
 527 switchOnRunResult GHC.RunFailed = return Nothing
 528 switchOnRunResult (GHC.RunException e) = throw e
 529 switchOnRunResult (GHC.RunOk names) = return $ Just names
 530 switchOnRunResult (GHC.RunBreak apStack _threadId info resume) = do  -- Todo: we don't use threadID, perhaps delete?
 531    session <- getSession
 532    Just mod_info <- io $ GHC.getModuleInfo session (breakInfo_module info)
 533    let modBreaks  = GHC.modInfoModBreaks mod_info
 534    let ticks      = modBreaks_ticks modBreaks
 535    io $ displayBreakInfo session ticks info
 536    io $ extendEnvironment session apStack (breakInfo_vars info)
 537    pushResume resume
 538    return Nothing
 539
 540 displayBreakInfo :: Session -> Array Int SrcSpan -> BreakInfo -> IO ()
 541 displayBreakInfo session ticks info = do
 542    unqual <- GHC.getPrintUnqual session
 543    let location = ticks ! breakInfo_number info
 544    printForUser stdout unqual $
 545       ptext SLIT("Stopped at") <+> ppr location $$ localsMsg
 546    where
 547    vars = map fst $ breakInfo_vars info
 548    localsMsg = if null vars
 549                   then text "No locals in scope."
 550                   else text "Locals:" <+> (pprWithCommas showId vars)
 551    showId id = ppr (idName id) <+> dcolon <+> ppr (idType id)
 552
 553 -- Todo: turn this into a primop, and provide special version(s) for unboxed things
 554 foreign import ccall "rts_getApStackVal" getApStackVal :: StablePtr a -> Int -> IO (StablePtr b)
 555
 556 getIdValFromApStack :: a -> (Id, Int) -> IO (Id, HValue)
 557 getIdValFromApStack apStack (identifier, stackDepth) = do
 558    -- ToDo: check the type of the identifer and decide whether it is unboxed or not
 559    apSptr <- newStablePtr apStack
 560    resultSptr <- getApStackVal apSptr (stackDepth - 1)
 561    result <- deRefStablePtr resultSptr
 562    freeStablePtr apSptr
 563    freeStablePtr resultSptr
 564    return (identifier, unsafeCoerce# result)
 565
 566 extendEnvironment :: Session -> a -> [(Id, Int)] -> IO ()
 567 extendEnvironment s@(Session ref) apStack idsOffsets = do
 568    idsVals <- mapM (getIdValFromApStack apStack) idsOffsets
 569    let (ids, hValues) = unzip idsVals
 570    let names = map idName ids
 571    let global_ids = map globaliseAndTidy ids
 572    typed_ids  <- mapM instantiateIdType global_ids
 573    hsc_env <- readIORef ref
 574    let ictxt = hsc_IC hsc_env
 575        rn_env   = ic_rn_local_env ictxt
 576        type_env = ic_type_env ictxt
 577        bound_names = map idName typed_ids
 578        new_rn_env  = extendLocalRdrEnv rn_env bound_names
 579        -- Remove any shadowed bindings from the type_env;
 580        -- they are inaccessible but might, I suppose, cause
 581        -- a space leak if we leave them there
 582        shadowed = [ n | name <- bound_names,
 583                     let rdr_name = mkRdrUnqual (nameOccName name),
 584                     Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
 585        filtered_type_env = delListFromNameEnv type_env shadowed
 586        new_type_env = extendTypeEnvWithIds filtered_type_env (typed_ids)
 587        new_ic = ictxt { ic_rn_local_env = new_rn_env,
 588                         ic_type_env     = new_type_env }
 589    writeIORef ref (hsc_env { hsc_IC = new_ic })
 590    extendLinkEnv (zip names hValues) -- ToDo: we must remember to restore the old env after we finish a breakpoint
 591    where
 592    globaliseAndTidy :: Id -> Id
 593    globaliseAndTidy id
 594       = let tidied_type = tidyTopType$ idType id
 595         in setIdType (globaliseId VanillaGlobal id) tidied_type
 596
 597    -- | Instantiate the tyVars with GHC.Base.Unknown
 598    instantiateIdType :: Id -> IO Id
 599    instantiateIdType id = do
 600       instantiatedType <- instantiateTyVarsToUnknown s (idType id)
 601       return$ setIdType id instantiatedType
 602
 603 -- possibly print the type and revert CAFs after evaluating an expression
 604 finishEvalExpr mb_names
 605  = do b <- isOptionSet ShowType
 606       session <- getSession
 607       case mb_names of
 608         Nothing    -> return ()
 609         Just names -> when b (mapM_ (showTypeOfName session) names)
 610
 611       flushInterpBuffers
 612       io installSignalHandlers
 613       b <- isOptionSet RevertCAFs
 614       io (when b revertCAFs)
 615       return True
 616
 617 showTypeOfName :: Session -> Name -> GHCi ()
 618 showTypeOfName session n
 619    = do maybe_tything <- io (GHC.lookupName session n)
 620         case maybe_tything of
 621           Nothing    -> return ()
 622           Just thing -> showTyThing thing
 623
 624 specialCommand :: String -> GHCi Bool
 625 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 626 specialCommand str = do
 627   let (cmd,rest) = break isSpace str
 628   maybe_cmd <- io (lookupCommand cmd)
 629   case maybe_cmd of
 630     Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
 631                                     ++ shortHelpText) >> return False)
 632     Just (_,f,_,_) -> f (dropWhile isSpace rest)
 633
 634 lookupCommand :: String -> IO (Maybe Command)
 635 lookupCommand str = do
 636   cmds <- readIORef commands
 637   -- look for exact match first, then the first prefix match
 638   case [ c | c <- cmds, str == cmdName c ] of
 639      c:_ -> return (Just c)
 640      [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
 641                 [] -> return Nothing
 642                 c:_ -> return (Just c)
 643
 644 -----------------------------------------------------------------------------
 645 -- Commands
 646
 647 help :: String -> GHCi ()
 648 help _ = io (putStr helpText)
 649
 650 info :: String -> GHCi ()
 651 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
 652 info s  = do { let names = words s
 653              ; session <- getSession
 654              ; dflags <- getDynFlags
 655              ; let exts = dopt Opt_GlasgowExts dflags
 656              ; mapM_ (infoThing exts session) names }
 657   where
 658     infoThing exts session str = io $ do
 659         names <- GHC.parseName session str
 660         let filtered = filterOutChildren names
 661         mb_stuffs <- mapM (GHC.getInfo session) filtered
 662         unqual <- GHC.getPrintUnqual session
 663         putStrLn (showSDocForUser unqual $
 664                    vcat (intersperse (text "") $
 665                    [ pprInfo exts stuff | Just stuff <-  mb_stuffs ]))
 666
 667   -- Filter out names whose parent is also there Good
 668   -- example is '[]', which is both a type and data
 669   -- constructor in the same type
 670 filterOutChildren :: [Name] -> [Name]
 671 filterOutChildren names = filter (not . parent_is_there) names
 672  where parent_is_there n
 673 --       | Just p <- GHC.nameParent_maybe n = p `elem` names
 674 -- ToDo!!
 675          | otherwise                       = False
 676
 677 pprInfo exts (thing, fixity, insts)
 678   =  pprTyThingInContextLoc exts thing
 679   $$ show_fixity fixity
 680   $$ vcat (map GHC.pprInstance insts)
 681   where
 682     show_fixity fix
 683         | fix == GHC.defaultFixity = empty
 684         | otherwise                = ppr fix <+> ppr (GHC.getName thing)
 685
 686 -----------------------------------------------------------------------------
 687 -- Commands
 688
 689 runMain :: String -> GHCi ()
 690 runMain args = do
 691   let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
 692   runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
 693   return ()
 694
 695 addModule :: [FilePath] -> GHCi ()
 696 addModule files = do
 697   io (revertCAFs)                       -- always revert CAFs on load/add.
 698   files <- mapM expandPath files
 699   targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
 700   session <- getSession
 701   io (mapM_ (GHC.addTarget session) targets)
 702   ok <- io (GHC.load session LoadAllTargets)
 703   afterLoad ok session
 704
 705 changeDirectory :: String -> GHCi ()
 706 changeDirectory dir = do
 707   session <- getSession
 708   graph <- io (GHC.getModuleGraph session)
 709   when (not (null graph)) $
 710         io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
 711   io (GHC.setTargets session [])
 712   io (GHC.load session LoadAllTargets)
 713   setContextAfterLoad session []
 714   io (GHC.workingDirectoryChanged session)
 715   dir <- expandPath dir
 716   io (setCurrentDirectory dir)
 717
 718 editFile :: String -> GHCi ()
 719 editFile str
 720   | null str  = do
 721         -- find the name of the "topmost" file loaded
 722      session <- getSession
 723      graph0 <- io (GHC.getModuleGraph session)
 724      graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
 725      let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
 726      case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
 727         Just file -> do_edit file
 728         Nothing   -> throwDyn (CmdLineError "unknown file name")
 729   | otherwise = do_edit str
 730   where
 731         do_edit file = do
 732            st <- getGHCiState
 733            let cmd = editor st
 734            when (null cmd) $
 735                 throwDyn (CmdLineError "editor not set, use :set editor")
 736            io $ system (cmd ++ ' ':file)
 737            return ()
 738
 739 defineMacro :: String -> GHCi ()
 740 defineMacro s = do
 741   let (macro_name, definition) = break isSpace s
 742   cmds <- io (readIORef commands)
 743   if (null macro_name)
 744         then throwDyn (CmdLineError "invalid macro name")
 745         else do
 746   if (macro_name `elem` map cmdName cmds)
 747         then throwDyn (CmdLineError
 748                 ("command '" ++ macro_name ++ "' is already defined"))
 749         else do
 750
 751   -- give the expression a type signature, so we can be sure we're getting
 752   -- something of the right type.
 753   let new_expr = '(' : definition ++ ") :: String -> IO String"
 754
 755   -- compile the expression
 756   cms <- getSession
 757   maybe_hv <- io (GHC.compileExpr cms new_expr)
 758   case maybe_hv of
 759      Nothing -> return ()
 760      Just hv -> io (writeIORef commands --
 761                     (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
 762
 763 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
 764 runMacro fun s = do
 765   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 766   stringLoop (lines str)
 767
 768 undefineMacro :: String -> GHCi ()
 769 undefineMacro macro_name = do
 770   cmds <- io (readIORef commands)
 771   if (macro_name `elem` map cmdName builtin_commands)
 772         then throwDyn (CmdLineError
 773                 ("command '" ++ macro_name ++ "' cannot be undefined"))
 774         else do
 775   if (macro_name `notElem` map cmdName cmds)
 776         then throwDyn (CmdLineError
 777                 ("command '" ++ macro_name ++ "' not defined"))
 778         else do
 779   io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
 780
 781
 782 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 783 loadModule fs = timeIt (loadModule' fs)
 784
 785 loadModule_ :: [FilePath] -> GHCi ()
 786 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
 787
 788 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 789 loadModule' files = do
 790   session <- getSession
 791
 792   -- unload first
 793   io (GHC.setTargets session [])
 794   io (GHC.load session LoadAllTargets)
 795
 796   -- expand tildes
 797   let (filenames, phases) = unzip files
 798   exp_filenames <- mapM expandPath filenames
 799   let files' = zip exp_filenames phases
 800   targets <- io (mapM (uncurry GHC.guessTarget) files')
 801
 802   -- NOTE: we used to do the dependency anal first, so that if it
 803   -- fails we didn't throw away the current set of modules.  This would
 804   -- require some re-working of the GHC interface, so we'll leave it
 805   -- as a ToDo for now.
 806
 807   io (GHC.setTargets session targets)
 808   ok <- io (GHC.load session LoadAllTargets)
 809   afterLoad ok session
 810   return ok
 811
 812 checkModule :: String -> GHCi ()
 813 checkModule m = do
 814   let modl = GHC.mkModuleName m
 815   session <- getSession
 816   result <- io (GHC.checkModule session modl)
 817   case result of
 818     Nothing -> io $ putStrLn "Nothing"
 819     Just r  -> io $ putStrLn (showSDoc (
 820         case GHC.checkedModuleInfo r of
 821            Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
 822                 let
 823                     (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
 824                 in
 825                         (text "global names: " <+> ppr global) $$
 826                         (text "local  names: " <+> ppr local)
 827            _ -> empty))
 828   afterLoad (successIf (isJust result)) session
 829
 830 reloadModule :: String -> GHCi ()
 831 reloadModule "" = do
 832   io (revertCAFs)               -- always revert CAFs on reload.
 833   session <- getSession
 834   ok <- io (GHC.load session LoadAllTargets)
 835   afterLoad ok session
 836 reloadModule m = do
 837   io (revertCAFs)               -- always revert CAFs on reload.
 838   session <- getSession
 839   ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
 840   afterLoad ok session
 841
 842 afterLoad ok session = do
 843   io (revertCAFs)  -- always revert CAFs on load.
 844   graph <- io (GHC.getModuleGraph session)
 845   graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
 846   setContextAfterLoad session graph'
 847   modulesLoadedMsg ok (map GHC.ms_mod_name graph')
 848
 849 setContextAfterLoad session [] = do
 850   prel_mod <- getPrelude
 851   io (GHC.setContext session [] [prel_mod])
 852 setContextAfterLoad session ms = do
 853   -- load a target if one is available, otherwise load the topmost module.
 854   targets <- io (GHC.getTargets session)
 855   case [ m | Just m <- map (findTarget ms) targets ] of
 856         []    ->
 857           let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
 858           load_this (last graph')
 859         (m:_) ->
 860           load_this m
 861  where
 862    findTarget ms t
 863     = case filter (`matches` t) ms of
 864         []    -> Nothing
 865         (m:_) -> Just m
 866
 867    summary `matches` Target (TargetModule m) _
 868         = GHC.ms_mod_name summary == m
 869    summary `matches` Target (TargetFile f _) _
 870         | Just f' <- GHC.ml_hs_file (GHC.ms_location summary)   = f == f'
 871    summary `matches` target
 872         = False
 873
 874    load_this summary | m <- GHC.ms_mod summary = do
 875         b <- io (GHC.moduleIsInterpreted session m)
 876         if b then io (GHC.setContext session [m] [])
 877              else do
 878                    prel_mod <- getPrelude
 879                    io (GHC.setContext session []  [prel_mod,m])
 880
 881
 882 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
 883 modulesLoadedMsg ok mods = do
 884   dflags <- getDynFlags
 885   when (verbosity dflags > 0) $ do
 886    let mod_commas
 887         | null mods = text "none."
 888         | otherwise = hsep (
 889             punctuate comma (map ppr mods)) <> text "."
 890    case ok of
 891     Failed ->
 892        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 893     Succeeded  ->
 894        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 895
 896
 897 typeOfExpr :: String -> GHCi ()
 898 typeOfExpr str
 899   = do cms <- getSession
 900        maybe_ty <- io (GHC.exprType cms str)
 901        case maybe_ty of
 902           Nothing -> return ()
 903           Just ty -> do ty' <- cleanType ty
 904                         tystr <- showForUser (ppr ty')
 905                         io (putStrLn (str ++ " :: " ++ tystr))
 906
 907 kindOfType :: String -> GHCi ()
 908 kindOfType str
 909   = do cms <- getSession
 910        maybe_ty <- io (GHC.typeKind cms str)
 911        case maybe_ty of
 912           Nothing    -> return ()
 913           Just ty    -> do tystr <- showForUser (ppr ty)
 914                            io (putStrLn (str ++ " :: " ++ tystr))
 915
 916 quit :: String -> GHCi Bool
 917 quit _ = return True
 918
 919 shellEscape :: String -> GHCi Bool
 920 shellEscape str = io (system str >> return False)
 921
 922 -----------------------------------------------------------------------------
 923 -- create tags file for currently loaded modules.
 924
 925 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
 926
 927 createCTagsFileCmd ""   = ghciCreateTagsFile CTags "tags"
 928 createCTagsFileCmd file = ghciCreateTagsFile CTags file
 929
 930 createETagsFileCmd ""    = ghciCreateTagsFile ETags "TAGS"
 931 createETagsFileCmd file  = ghciCreateTagsFile ETags file
 932
 933 data TagsKind = ETags | CTags
 934
 935 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
 936 ghciCreateTagsFile kind file = do
 937   session <- getSession
 938   io $ createTagsFile session kind file
 939
 940 -- ToDo:
 941 --      - remove restriction that all modules must be interpreted
 942 --        (problem: we don't know source locations for entities unless
 943 --        we compiled the module.
 944 --
 945 --      - extract createTagsFile so it can be used from the command-line
 946 --        (probably need to fix first problem before this is useful).
 947 --
 948 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
 949 createTagsFile session tagskind tagFile = do
 950   graph <- GHC.getModuleGraph session
 951   let ms = map GHC.ms_mod graph
 952       tagModule m = do
 953         is_interpreted <- GHC.moduleIsInterpreted session m
 954         -- should we just skip these?
 955         when (not is_interpreted) $
 956           throwDyn (CmdLineError ("module '"
 957                                 ++ GHC.moduleNameString (GHC.moduleName m)
 958                                 ++ "' is not interpreted"))
 959         mbModInfo <- GHC.getModuleInfo session m
 960         let unqual
 961               | Just modinfo <- mbModInfo,
 962                 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
 963               | otherwise = GHC.alwaysQualify
 964
 965         case mbModInfo of
 966           Just modInfo -> return $! listTags unqual modInfo
 967           _            -> return []
 968
 969   mtags <- mapM tagModule ms
 970   either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
 971   case either_res of
 972     Left e  -> hPutStrLn stderr $ ioeGetErrorString e
 973     Right _ -> return ()
 974
 975 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
 976 listTags unqual modInfo =
 977            [ tagInfo unqual name loc
 978            | name <- GHC.modInfoExports modInfo
 979            , let loc = nameSrcLoc name
 980            , isGoodSrcLoc loc
 981            ]
 982
 983 type TagInfo = (String -- tag name
 984                ,String -- file name
 985                ,Int    -- line number
 986                ,Int    -- column number
 987                )
 988
 989 -- get tag info, for later translation into Vim or Emacs style
 990 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
 991 tagInfo unqual name loc
 992     = ( showSDocForUser unqual $ pprOccName (nameOccName name)
 993       , showSDocForUser unqual $ ftext (srcLocFile loc)
 994       , srcLocLine loc
 995       , srcLocCol loc
 996       )
 997
 998 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
 999 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
1000   let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
1001   IO.try (writeFile file tags)
1002 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
1003   let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
1004       groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
1005   tagGroups <- mapM tagFileGroup groups
1006   IO.try (writeFile file $ concat tagGroups)
1007   where
1008     tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
1009     tagFileGroup group@((_,fileName,_,_):_) = do
1010       file <- readFile fileName -- need to get additional info from sources..
1011       let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
1012           sortedGroup = sortLe byLine group
1013           tags = unlines $ perFile sortedGroup 1 0 $ lines file
1014       return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
1015     perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
1016       perFile (tagInfo:tags) (count+1) (pos+length line) lines
1017     perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
1018       showETag tagInfo line pos : perFile tags count pos lines
1019     perFile tags count pos lines = []
1020
1021 -- simple ctags format, for Vim et al
1022 showTag :: TagInfo -> String
1023 showTag (tag,file,lineNo,colNo)
1024     =  tag ++ "\t" ++ file ++ "\t" ++ show lineNo
1025
1026 -- etags format, for Emacs/XEmacs
1027 showETag :: TagInfo -> String -> Int -> String
1028 showETag (tag,file,lineNo,colNo) line charPos
1029     =  take colNo line ++ tag
1030     ++ "\x7f" ++ tag
1031     ++ "\x01" ++ show lineNo
1032     ++ "," ++ show charPos
1033
1034 -----------------------------------------------------------------------------
1035 -- Browsing a module's contents
1036
1037 browseCmd :: String -> GHCi ()
1038 browseCmd m =
1039   case words m of
1040     ['*':m] | looksLikeModuleName m -> browseModule m False
1041     [m]     | looksLikeModuleName m -> browseModule m True
1042     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
1043
1044 browseModule m exports_only = do
1045   s <- getSession
1046   modl <- io $ GHC.findModule s (GHC.mkModuleName m) Nothing
1047   is_interpreted <- io (GHC.moduleIsInterpreted s modl)
1048   when (not is_interpreted && not exports_only) $
1049         throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
1050
1051   -- Temporarily set the context to the module we're interested in,
1052   -- just so we can get an appropriate PrintUnqualified
1053   (as,bs) <- io (GHC.getContext s)
1054   prel_mod <- getPrelude
1055   io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1056                       else GHC.setContext s [modl] [])
1057   unqual <- io (GHC.getPrintUnqual s)
1058   io (GHC.setContext s as bs)
1059
1060   mb_mod_info <- io $ GHC.getModuleInfo s modl
1061   case mb_mod_info of
1062     Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1063     Just mod_info -> do
1064         let names
1065                | exports_only = GHC.modInfoExports mod_info
1066                | otherwise    = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
1067
1068             filtered = filterOutChildren names
1069
1070         things <- io $ mapM (GHC.lookupName s) filtered
1071
1072         dflags <- getDynFlags
1073         let exts = dopt Opt_GlasgowExts dflags
1074         io (putStrLn (showSDocForUser unqual (
1075                 vcat (map (pprTyThingInContext exts) (catMaybes things))
1076            )))
1077         -- ToDo: modInfoInstances currently throws an exception for
1078         -- package modules.  When it works, we can do this:
1079         --      $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1080
1081 -----------------------------------------------------------------------------
1082 -- Setting the module context
1083
1084 setContext str
1085   | all sensible mods = fn mods
1086   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
1087   where
1088     (fn, mods) = case str of
1089                         '+':stuff -> (addToContext,      words stuff)
1090                         '-':stuff -> (removeFromContext, words stuff)
1091                         stuff     -> (newContext,        words stuff)
1092
1093     sensible ('*':m) = looksLikeModuleName m
1094     sensible m       = looksLikeModuleName m
1095
1096 separate :: Session -> [String] -> [Module] -> [Module]
1097         -> GHCi ([Module],[Module])
1098 separate session []           as bs = return (as,bs)
1099 separate session (('*':str):ms) as bs = do
1100    m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1101    b <- io $ GHC.moduleIsInterpreted session m
1102    if b then separate session ms (m:as) bs
1103         else throwDyn (CmdLineError ("module '"
1104                         ++ GHC.moduleNameString (GHC.moduleName m)
1105                         ++ "' is not interpreted"))
1106 separate session (str:ms) as bs = do
1107   m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1108   separate session ms as (m:bs)
1109
1110 newContext :: [String] -> GHCi ()
1111 newContext strs = do
1112   s <- getSession
1113   (as,bs) <- separate s strs [] []
1114   prel_mod <- getPrelude
1115   let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1116   io $ GHC.setContext s as bs'
1117
1118
1119 addToContext :: [String] -> GHCi ()
1120 addToContext strs = do
1121   s <- getSession
1122   (as,bs) <- io $ GHC.getContext s
1123
1124   (new_as,new_bs) <- separate s strs [] []
1125
1126   let as_to_add = new_as \\ (as ++ bs)
1127       bs_to_add = new_bs \\ (as ++ bs)
1128
1129   io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1130
1131
1132 removeFromContext :: [String] -> GHCi ()
1133 removeFromContext strs = do
1134   s <- getSession
1135   (as,bs) <- io $ GHC.getContext s
1136
1137   (as_to_remove,bs_to_remove) <- separate s strs [] []
1138
1139   let as' = as \\ (as_to_remove ++ bs_to_remove)
1140       bs' = bs \\ (as_to_remove ++ bs_to_remove)
1141
1142   io $ GHC.setContext s as' bs'
1143
1144 ----------------------------------------------------------------------------
1145 -- Code for `:set'
1146
1147 -- set options in the interpreter.  Syntax is exactly the same as the
1148 -- ghc command line, except that certain options aren't available (-C,
1149 -- -E etc.)
1150 --
1151 -- This is pretty fragile: most options won't work as expected.  ToDo:
1152 -- figure out which ones & disallow them.
1153
1154 setCmd :: String -> GHCi ()
1155 setCmd ""
1156   = do st <- getGHCiState
1157        let opts = options st
1158        io $ putStrLn (showSDoc (
1159               text "options currently set: " <>
1160               if null opts
1161                    then text "none."
1162                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1163            ))
1164 setCmd str
1165   = case toArgs str of
1166         ("args":args) -> setArgs args
1167         ("prog":prog) -> setProg prog
1168         ("prompt":prompt) -> setPrompt (after 6)
1169         ("editor":cmd) -> setEditor (after 6)
1170         wds -> setOptions wds
1171    where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1172
1173 setArgs args = do
1174   st <- getGHCiState
1175   setGHCiState st{ args = args }
1176
1177 setProg [prog] = do
1178   st <- getGHCiState
1179   setGHCiState st{ progname = prog }
1180 setProg _ = do
1181   io (hPutStrLn stderr "syntax: :set prog <progname>")
1182
1183 setEditor cmd = do
1184   st <- getGHCiState
1185   setGHCiState st{ editor = cmd }
1186
1187 setPrompt value = do
1188   st <- getGHCiState
1189   if null value
1190       then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1191       else setGHCiState st{ prompt = remQuotes value }
1192   where
1193      remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1194      remQuotes x = x
1195
1196 setOptions wds =
1197    do -- first, deal with the GHCi opts (+s, +t, etc.)
1198       let (plus_opts, minus_opts)  = partition isPlus wds
1199       mapM_ setOpt plus_opts
1200
1201       -- then, dynamic flags
1202       dflags <- getDynFlags
1203       let pkg_flags = packageFlags dflags
1204       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1205
1206       if (not (null leftovers))
1207                 then throwDyn (CmdLineError ("unrecognised flags: " ++
1208                                                 unwords leftovers))
1209                 else return ()
1210
1211       new_pkgs <- setDynFlags dflags'
1212
1213       -- if the package flags changed, we should reset the context
1214       -- and link the new packages.
1215       dflags <- getDynFlags
1216       when (packageFlags dflags /= pkg_flags) $ do
1217         io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1218         session <- getSession
1219         io (GHC.setTargets session [])
1220         io (GHC.load session LoadAllTargets)
1221         io (linkPackages dflags new_pkgs)
1222         setContextAfterLoad session []
1223       return ()
1224
1225
1226 unsetOptions :: String -> GHCi ()
1227 unsetOptions str
1228   = do -- first, deal with the GHCi opts (+s, +t, etc.)
1229        let opts = words str
1230            (minus_opts, rest1) = partition isMinus opts
1231            (plus_opts, rest2)  = partition isPlus rest1
1232
1233        if (not (null rest2))
1234           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1235           else do
1236
1237        mapM_ unsetOpt plus_opts
1238
1239        -- can't do GHC flags for now
1240        if (not (null minus_opts))
1241           then throwDyn (CmdLineError "can't unset GHC command-line flags")
1242           else return ()
1243
1244 isMinus ('-':s) = True
1245 isMinus _ = False
1246
1247 isPlus ('+':s) = True
1248 isPlus _ = False
1249
1250 setOpt ('+':str)
1251   = case strToGHCiOpt str of
1252         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1253         Just o  -> setOption o
1254
1255 unsetOpt ('+':str)
1256   = case strToGHCiOpt str of
1257         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1258         Just o  -> unsetOption o
1259
1260 strToGHCiOpt :: String -> (Maybe GHCiOption)
1261 strToGHCiOpt "s" = Just ShowTiming
1262 strToGHCiOpt "t" = Just ShowType
1263 strToGHCiOpt "r" = Just RevertCAFs
1264 strToGHCiOpt _   = Nothing
1265
1266 optToStr :: GHCiOption -> String
1267 optToStr ShowTiming = "s"
1268 optToStr ShowType   = "t"
1269 optToStr RevertCAFs = "r"
1270
1271 -- ---------------------------------------------------------------------------
1272 -- code for `:show'
1273
1274 showCmd str =
1275   case words str of
1276         ["modules" ] -> showModules
1277         ["bindings"] -> showBindings
1278         ["linker"]   -> io showLinkerState
1279         ["breaks"] -> showBkptTable
1280         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
1281
1282 showModules = do
1283   session <- getSession
1284   let show_one ms = do m <- io (GHC.showModule session ms)
1285                        io (putStrLn m)
1286   graph <- io (GHC.getModuleGraph session)
1287   mapM_ show_one graph
1288
1289 showBindings = do
1290   s <- getSession
1291   unqual <- io (GHC.getPrintUnqual s)
1292   bindings <- io (GHC.getBindings s)
1293   mapM_ showTyThing bindings
1294   return ()
1295
1296 showTyThing (AnId id) = do
1297   ty' <- cleanType (GHC.idType id)
1298   str <- showForUser (ppr id <> text " :: " <> ppr ty')
1299   io (putStrLn str)
1300 showTyThing _  = return ()
1301
1302 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1303 cleanType :: Type -> GHCi Type
1304 cleanType ty = do
1305   dflags <- getDynFlags
1306   if dopt Opt_GlasgowExts dflags
1307         then return ty
1308         else return $! GHC.dropForAlls ty
1309
1310 showBkptTable :: GHCi ()
1311 showBkptTable = do
1312    activeBreaks <- getActiveBreakPoints
1313    str <- showForUser $ ppr activeBreaks
1314    io $ putStrLn str
1315
1316 -- -----------------------------------------------------------------------------
1317 -- Completion
1318
1319 completeNone :: String -> IO [String]
1320 completeNone w = return []
1321
1322 #ifdef USE_READLINE
1323 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1324 completeWord w start end = do
1325   line <- Readline.getLineBuffer
1326   case w of
1327      ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1328      _other
1329         | Just c <- is_cmd line -> do
1330            maybe_cmd <- lookupCommand c
1331            let (n,w') = selectWord (words' 0 line)
1332            case maybe_cmd of
1333              Nothing -> return Nothing
1334              Just (_,_,False,complete) -> wrapCompleter complete w
1335              Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1336                                                               return (map (drop n) rets)
1337                                          in wrapCompleter complete' w'
1338         | otherwise     -> do
1339                 --printf "complete %s, start = %d, end = %d\n" w start end
1340                 wrapCompleter completeIdentifier w
1341     where words' _ [] = []
1342           words' n str = let (w,r) = break isSpace str
1343                              (s,r') = span isSpace r
1344                          in (n,w):words' (n+length w+length s) r'
1345           -- In a Haskell expression we want to parse 'a-b' as three words
1346           -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1347           -- only be a single word.
1348           selectWord [] = (0,w)
1349           selectWord ((offset,x):xs)
1350               | offset+length x >= start = (start-offset,take (end-offset) x)
1351               | otherwise = selectWord xs
1352
1353 is_cmd line
1354  | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1355  | otherwise = Nothing
1356
1357 completeCmd w = do
1358   cmds <- readIORef commands
1359   return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1360
1361 completeMacro w = do
1362   cmds <- readIORef commands
1363   let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1364   return (filter (w `isPrefixOf`) cmds')
1365
1366 completeIdentifier w = do
1367   s <- restoreSession
1368   rdrs <- GHC.getRdrNamesInScope s
1369   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1370
1371 completeModule w = do
1372   s <- restoreSession
1373   dflags <- GHC.getSessionDynFlags s
1374   let pkg_mods = allExposedModules dflags
1375   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1376
1377 completeHomeModule w = do
1378   s <- restoreSession
1379   g <- GHC.getModuleGraph s
1380   let home_mods = map GHC.ms_mod_name g
1381   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1382
1383 completeSetOptions w = do
1384   return (filter (w `isPrefixOf`) options)
1385     where options = "args":"prog":allFlags
1386
1387 completeFilename = Readline.filenameCompletionFunction
1388
1389 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1390
1391 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1392 unionComplete f1 f2 w = do
1393   s1 <- f1 w
1394   s2 <- f2 w
1395   return (s1 ++ s2)
1396
1397 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1398 wrapCompleter fun w =  do
1399   strs <- fun w
1400   case strs of
1401     []  -> return Nothing
1402     [x] -> return (Just (x,[]))
1403     xs  -> case getCommonPrefix xs of
1404                 ""   -> return (Just ("",xs))
1405                 pref -> return (Just (pref,xs))
1406
1407 getCommonPrefix :: [String] -> String
1408 getCommonPrefix [] = ""
1409 getCommonPrefix (s:ss) = foldl common s ss
1410   where common s "" = ""
1411         common "" s = ""
1412         common (c:cs) (d:ds)
1413            | c == d = c : common cs ds
1414            | otherwise = ""
1415
1416 allExposedModules :: DynFlags -> [ModuleName]
1417 allExposedModules dflags
1418  = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1419  where
1420   pkg_db = pkgIdMap (pkgState dflags)
1421 #else
1422 completeCmd        = completeNone
1423 completeMacro      = completeNone
1424 completeIdentifier = completeNone
1425 completeModule     = completeNone
1426 completeHomeModule = completeNone
1427 completeSetOptions = completeNone
1428 completeFilename   = completeNone
1429 completeHomeModuleOrFile=completeNone
1430 completeBkpt       = completeNone
1431 #endif
1432
1433 -- ---------------------------------------------------------------------------
1434 -- User code exception handling
1435
1436 -- This is the exception handler for exceptions generated by the
1437 -- user's code and exceptions coming from children sessions;
1438 -- it normally just prints out the exception.  The
1439 -- handler must be recursive, in case showing the exception causes
1440 -- more exceptions to be raised.
1441 --
1442 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1443 -- raising another exception.  We therefore don't put the recursive
1444 -- handler arond the flushing operation, so if stderr is closed
1445 -- GHCi will just die gracefully rather than going into an infinite loop.
1446 handler :: Exception -> GHCi Bool
1447
1448 handler exception = do
1449   flushInterpBuffers
1450   io installSignalHandlers
1451   ghciHandle handler (showException exception >> return False)
1452
1453 showException (DynException dyn) =
1454   case fromDynamic dyn of
1455     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
1456     Just Interrupted      -> io (putStrLn "Interrupted.")
1457     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
1458     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1459     Just other_ghc_ex     -> io (print other_ghc_ex)
1460
1461 showException other_exception
1462   = io (putStrLn ("*** Exception: " ++ show other_exception))
1463
1464 -----------------------------------------------------------------------------
1465 -- recursive exception handlers
1466
1467 -- Don't forget to unblock async exceptions in the handler, or if we're
1468 -- in an exception loop (eg. let a = error a in a) the ^C exception
1469 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1470
1471 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1472 ghciHandle h (GHCi m) = GHCi $ \s ->
1473    Exception.catch (m s)
1474         (\e -> unGHCi (ghciUnblock (h e)) s)
1475
1476 ghciUnblock :: GHCi a -> GHCi a
1477 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1478
1479
1480 -- ----------------------------------------------------------------------------
1481 -- Utils
1482
1483 expandPath :: String -> GHCi String
1484 expandPath path =
1485   case dropWhile isSpace path of
1486    ('~':d) -> do
1487         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1488         return (tilde ++ '/':d)
1489    other ->
1490         return other
1491
1492 -- ----------------------------------------------------------------------------
1493 -- Windows console setup
1494
1495 setUpConsole :: IO ()
1496 setUpConsole = do
1497 #ifdef mingw32_HOST_OS
1498         -- On Windows we need to set a known code page, otherwise the characters
1499         -- we read from the console will be be in some strange encoding, and
1500         -- similarly for characters we write to the console.
1501         --
1502         -- At the moment, GHCi pretends all input is Latin-1.  In the
1503         -- future we should support UTF-8, but for now we set the code pages
1504         -- to Latin-1.
1505         --
1506         -- It seems you have to set the font in the console window to
1507         -- a Unicode font in order for output to work properly,
1508         -- otherwise non-ASCII characters are mapped wrongly.  sigh.
1509         -- (see MSDN for SetConsoleOutputCP()).
1510         --
1511         setConsoleCP 28591       -- ISO Latin-1
1512         setConsoleOutputCP 28591 -- ISO Latin-1
1513 #endif
1514         return ()
1515
1516 -- commands for debugger
1517 foreign import ccall "rts_setStepFlag" setStepFlag :: IO ()
1518
1519 stepCmd :: String -> GHCi Bool
1520 stepCmd [] = doContinue setStepFlag
1521 stepCmd expression = do
1522    io $ setStepFlag
1523    runCommand expression
1524
1525 continueCmd :: String -> GHCi Bool
1526 continueCmd [] = doContinue $ return ()
1527 continueCmd other = do
1528    io $ putStrLn "The continue command accepts no arguments."
1529    return False
1530
1531 doContinue :: IO () -> GHCi Bool
1532 doContinue actionBeforeCont = do
1533    resumeAction <- getResume
1534    popResume
1535    case resumeAction of
1536       Nothing -> do
1537          io $ putStrLn "There is no computation running."
1538          return False
1539       Just action -> do
1540          io $ actionBeforeCont
1541          runResult <- io action
1542          names <- switchOnRunResult runResult
1543          finishEvalExpr names
1544          return False
1545
1546 deleteCmd :: String -> GHCi Bool
1547 deleteCmd argLine = do
1548    deleteSwitch $ words argLine
1549    return False
1550    where
1551    deleteSwitch :: [String] -> GHCi ()
1552    deleteSwitch [] =
1553       io $ putStrLn "The delete command requires at least one argument."
1554    -- delete all break points
1555    deleteSwitch ("*":_rest) = clearActiveBreakPoints
1556    deleteSwitch idents = do
1557       mapM_ deleteOneBreak idents
1558       where
1559       deleteOneBreak :: String -> GHCi ()
1560       deleteOneBreak str
1561          | all isDigit str = deleteBreak (read str)
1562          | otherwise = return ()
1563
1564 -- handle the "break" command
1565 breakCmd :: String -> GHCi Bool
1566 breakCmd argLine = do
1567    session <- getSession
1568    breakSwitch session $ words argLine
1569
1570 breakSwitch :: Session -> [String] -> GHCi Bool
1571 breakSwitch _session [] = do
1572    io $ putStrLn "The break command requires at least one argument."
1573    return False
1574 breakSwitch session args@(arg1:rest)
1575    | looksLikeModule arg1 = do
1576         mod     <- lookupModule session arg1
1577         breakByModule mod rest
1578         return False
1579    | otherwise = do
1580         (toplevel, _) <- io $ GHC.getContext session
1581         case toplevel of
1582            (mod : _) -> breakByModule mod args
1583            [] -> do
1584               io $ putStrLn "Cannot find default module for breakpoint."
1585               io $ putStrLn "Perhaps no modules are loaded for debugging?"
1586         return False
1587    where
1588    -- Todo there may be a nicer way to test this
1589    looksLikeModule :: String -> Bool
1590    looksLikeModule []    = False
1591    looksLikeModule (x:_) = isUpper x
1592
1593 breakByModule :: Module -> [String] -> GHCi ()
1594 breakByModule mod args@(arg1:rest)
1595    | all isDigit arg1 = do  -- looks like a line number
1596         breakByModuleLine mod (read arg1) rest
1597    | looksLikeVar arg1 = do
1598         -- break by a function definition
1599         io $ putStrLn "Break by function definition not implemented."
1600    | otherwise = io $ putStrLn "Invalid arguments to break command."
1601    where
1602    -- Todo there may be a nicer way to test this
1603    looksLikeVar :: String -> Bool
1604    looksLikeVar [] = False
1605    looksLikeVar (x:_) = isLower x || x `elem` "~!@#$%^&*-+"
1606
1607 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1608 breakByModuleLine mod line args
1609    | [] <- args = findBreakAndSet mod $ lookupTickTreeLine line
1610    | [col] <- args, all isDigit col =
1611         findBreakAndSet mod $ lookupTickTreeCoord (line, read col)
1612    | otherwise = io $ putStrLn "Invalid arguments to break command."
1613
1614 findBreakAndSet :: Module -> (TickTree -> Maybe (Int, SrcSpan)) -> GHCi ()
1615 findBreakAndSet mod lookupTickTree = do
1616    (breakArray, ticks) <- getModBreak mod
1617    let tickTree   = tickTreeFromList (assocs ticks)
1618    case lookupTickTree tickTree of
1619       Nothing  -> io $ putStrLn $ "No breakpoints found at that location."
1620       Just (tick, span) -> do
1621          success <- io $ setBreakFlag True breakArray tick
1622          session <- getSession
1623          unqual  <- io $ GHC.getPrintUnqual session
1624          if success
1625             then do
1626                (alreadySet, nm) <-
1627                      recordBreak $ BreakLocation
1628                              { breakModule = mod
1629                              , breakLoc = span
1630                              , breakTick = tick
1631                              }
1632                io $ printForUser stdout unqual $
1633                   text "Breakpoint " <> ppr nm <>
1634                   if alreadySet
1635                      then text " was already set at " <> ppr span
1636                      else text " activated at " <> ppr span
1637             else do
1638             str <- showForUser $ text "Breakpoint could not be activated at"
1639                                  <+> ppr span
1640             io $ putStrLn str
1641
1642 getModBreak :: Module -> GHCi (BreakArray, Array Int SrcSpan)
1643 getModBreak mod = do
1644    session <- getSession
1645    Just mod_info <- io $ GHC.getModuleInfo session mod
1646    let modBreaks  = GHC.modInfoModBreaks mod_info
1647    let array      = modBreaks_array modBreaks
1648    let ticks      = modBreaks_ticks modBreaks
1649    return (array, ticks)
1650
1651 lookupModule :: Session -> String -> GHCi Module
1652 lookupModule session modName
1653    = io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1654
1655 setBreakFlag :: Bool -> BreakArray -> Int -> IO Bool
1656 setBreakFlag toggle array index
1657    | toggle    = setBreakOn array index
1658    | otherwise = setBreakOff array index
1659
1660
1661 {- these should probably go to the GHC API at some point -}
1662 enableBreakPoint  :: Session -> Module -> Int -> IO ()
1663 enableBreakPoint session mod index = return ()
1664
1665 disableBreakPoint :: Session -> Module -> Int -> IO ()
1666 disableBreakPoint session mod index = return ()
1667
1668 activeBreakPoints :: Session -> IO [(Module,Int)]
1669 activeBreakPoints session = return []
1670
1671 enableSingleStep  :: Session -> IO ()
1672 enableSingleStep session = return ()
1673
1674 disableSingleStep :: Session -> IO ()
1675 disableSingleStep session = return ()