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