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