compiler/ghci/InteractiveUI.hs

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