compiler/ghci/InteractiveUI.hs

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