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