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