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