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