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