compiler/ghci/InteractiveUI.hs

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