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