ghc/compiler/ghci/InteractiveUI.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: InteractiveUI.hs,v 1.37 2001/02/09 15:33:51 simonmar Exp $
   3 --
   4 -- GHC Interactive User Interface
   5 --
   6 -- (c) The GHC Team 2000
   7 --
   8 -----------------------------------------------------------------------------
   9
  10 module InteractiveUI (interactiveUI) where
  11
  12 #include "HsVersions.h"
  13
  14 import CompManager
  15 import CmStaticInfo
  16 import ByteCodeLink
  17 import DriverFlags
  18 import DriverState
  19 import DriverUtil
  20 import Type
  21 import Linker
  22 import Finder
  23 import Module
  24 import Outputable
  25 import Util
  26 import PprType          {- instance Outputable Type; do not delete -}
  27 import Panic            ( GhcException(..) )
  28
  29 import Exception
  30 import Dynamic
  31 #ifndef NO_READLINE
  32 import Readline
  33 #endif
  34 import IOExts
  35
  36 import Numeric
  37 import List
  38 import System
  39 import CPUTime
  40 import Directory
  41 import IO
  42 import Char
  43 import Monad ( when )
  44
  45
  46 -----------------------------------------------------------------------------
  47
  48 ghciWelcomeMsg = "\
  49 \   ___         ___ _                                                        \n\
  50 \  / _ \\ /\\  /\\/ __(_)      GHC Interactive, version 5.00, For Haskell 98.   \n\
  51 \ / /_\\// /_/ / /  | |      http://www.haskell.org/ghc                       \n\
  52 \/ /_\\\\/ __  / /___| |      Bug reports to: glasgow-haskell-bugs@haskell.org \n\
  53 \\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
  54
  55 commands :: [(String, String -> GHCi Bool)]
  56 commands = [
  57   ("add",       keepGoing addModule),
  58   ("cd",        keepGoing changeDirectory),
  59   ("help",      keepGoing help),
  60   ("?",         keepGoing help),
  61   ("load",      keepGoing loadModule),
  62   ("module",    keepGoing setContext),
  63   ("reload",    keepGoing reloadModule),
  64   ("set",       keepGoing setOptions),
  65   ("type",      keepGoing typeOfExpr),
  66   ("unset",     keepGoing unsetOptions),
  67   ("quit",      quit)
  68   ]
  69
  70 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
  71 keepGoing a str = a str >> return False
  72
  73 shortHelpText = "use :? for help.\n"
  74
  75 helpText = "\
  76 \ Commands available from the prompt:\n\
  77 \\
  78 \   <expr>              evaluate <expr>\n\
  79 \   :add <filename>     add a module to the current set\n\
  80 \   :cd <dir>           change directory to <dir>\n\
  81 \   :help, :?           display this list of commands\n\
  82 \   :load <filename>    load a module (and it dependents)\n\
  83 \   :module <mod>       set the context for expression evaluation to <mod>\n\
  84 \   :reload             reload the current module set\n\
  85 \   :set <option> ...   set options\n\
  86 \   :unset <option> ... unset options\n\
  87 \   :type <expr>        show the type of <expr>\n\
  88 \   :quit               exit GHCi\n\
  89 \   :!<command>         run the shell command <command>\n\
  90 \\
  91 \ Options for `:set' and `:unset':\n\
  92 \\
  93 \    +s                 print timing/memory stats after each evaluation\n\
  94 \    +t                 print type after evaluation\n\
  95 \    +r                 revert top-level expressions after each evaluation\n\
  96 \    -<flags>           most GHC command line flags can also be set here\n\
  97 \                         (eg. -v2, -fglasgow-exts, etc.)\n\
  98 \"
  99
 100 interactiveUI :: CmState -> Maybe FilePath -> IO ()
 101 interactiveUI cmstate mod = do
 102    hPutStrLn stdout ghciWelcomeMsg
 103    hFlush stdout
 104    hSetBuffering stdout NoBuffering
 105
 106    -- link in the available packages
 107    pkgs <- getPackageInfo
 108    linkPackages (reverse pkgs)
 109
 110    (cmstate, ok, mods) <-
 111         case mod of
 112              Nothing  -> return (cmstate, True, [])
 113              Just m -> cmLoadModule cmstate m
 114
 115 #ifndef NO_READLINE
 116    Readline.initialize
 117 #endif
 118
 119    prel <- moduleNameToModule defaultCurrentModuleName
 120    writeIORef defaultCurrentModule prel
 121
 122    dflags <- getDynFlags
 123
 124    (cmstate, maybe_stuff) <- cmGetExpr cmstate dflags False prel
 125                                 "PrelHandle.hFlush PrelHandle.stdout"
 126    case maybe_stuff of
 127         Nothing -> return ()
 128         Just (hv,_,_) -> writeIORef flush_stdout hv
 129
 130    (cmstate, maybe_stuff) <- cmGetExpr cmstate dflags False prel
 131                                 "PrelHandle.hFlush PrelHandle.stdout"
 132    case maybe_stuff of
 133         Nothing -> return ()
 134         Just (hv,_,_) -> writeIORef flush_stderr hv
 135
 136    let this_mod = case mods of
 137                       []   -> prel
 138                       m:ms -> m
 139
 140    (unGHCi runGHCi) GHCiState{ modules = mods,
 141                               current_module = this_mod,
 142                               target = mod,
 143                               cmstate = cmstate,
 144                               options = [ShowTiming],
 145                               last_expr = Nothing}
 146    return ()
 147
 148
 149 runGHCi :: GHCi ()
 150 runGHCi = do
 151   -- read in ./.ghci
 152   dot_ghci <- io (IO.try (openFile "./.ghci" ReadMode))
 153   case dot_ghci of
 154         Left e -> return ()
 155         Right hdl -> fileLoop hdl False
 156
 157   -- read in ~/.ghci
 158   home <- io (IO.try (getEnv "HOME"))
 159   case home of
 160    Left e  -> return ()
 161    Right dir -> do
 162         dot_ghci <- io (IO.try (openFile (dir ++ "/.ghci") ReadMode))
 163         case dot_ghci of
 164            Left e -> return ()
 165            Right hdl -> fileLoop hdl False
 166
 167   -- read commands from stdin
 168 #ifndef NO_READLINE
 169   readlineLoop
 170 #else
 171   fileLoop stdin True
 172 #endif
 173
 174   -- and finally, exit
 175   io $ do putStrLn "Leaving GHCi."
 176
 177
 178 fileLoop :: Handle -> Bool -> GHCi ()
 179 fileLoop hdl prompt = do
 180    st <- getGHCiState
 181    when prompt (io (hPutStr hdl (moduleUserString (current_module st) ++ "> ")))
 182    l <- io (IO.try (hGetLine hdl))
 183    case l of
 184         Left e | isEOFError e -> return ()
 185                | otherwise    -> throw e
 186         Right l ->
 187           case remove_spaces l of
 188             "" -> fileLoop hdl prompt
 189             l  -> do quit <- runCommand l
 190                      if quit then return () else fileLoop hdl prompt
 191
 192 #ifndef NO_READLINE
 193 readlineLoop :: GHCi ()
 194 readlineLoop = do
 195    st <- getGHCiState
 196    l <- io (readline (moduleUserString (current_module st) ++ "> "))
 197    case l of
 198         Nothing -> return ()
 199         Just l  ->
 200           case remove_spaces l of
 201             "" -> readlineLoop
 202             l  -> do
 203                   io (addHistory l)
 204                   quit <- runCommand l
 205                   if quit then return () else readlineLoop
 206 #endif
 207
 208 -- Top level exception handler, just prints out the exception
 209 -- and carries on.
 210 runCommand :: String -> GHCi Bool
 211 runCommand c =
 212   ghciHandle ( \exception ->
 213         (case exception of
 214            DynException dyn ->
 215               case fromDynamic dyn of
 216                 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
 217                 Just ghc_ex ->
 218                   case ghc_ex of
 219                     PhaseFailed phase code ->
 220                         io ( putStrLn ("Phase " ++ phase ++ " failed (code "
 221                                         ++ show code ++ ")"))
 222                     Interrupted -> io (putStrLn "Interrupted.")
 223                     other -> io (putStrLn (show (ghc_ex :: GhcException)))
 224
 225            other -> io (putStrLn ("*** Exception: " ++ show exception))
 226
 227         ) >> return False
 228      ) $
 229
 230    doCommand c
 231
 232 doCommand (':' : command) = specialCommand command
 233 doCommand ('-':'-':_) = return False    -- comments, useful in scripts
 234 doCommand expr
 235    = do expr_expanded <- expandExpr expr
 236         -- io (putStrLn ( "Before: " ++ expr ++ "\nAfter:  " ++ expr_expanded))
 237         expr_ok <- timeIt (do stuff <- evalExpr expr_expanded
 238                               finishEvalExpr stuff)
 239         when expr_ok (rememberExpr expr_expanded)
 240         return False
 241
 242 -- possibly print the type and revert CAFs after evaluating an expression
 243 finishEvalExpr Nothing = return False
 244 finishEvalExpr (Just (unqual,ty))
 245  = do b <- isOptionSet ShowType
 246       io (when b (printForUser stdout unqual (text "::" <+> ppr ty)))
 247       b <- isOptionSet RevertCAFs
 248       io (when b revertCAFs)
 249       return True
 250
 251 -- Returned Bool indicates whether or not the expr was successfully
 252 -- parsed, renamed and typechecked.
 253 evalExpr :: String -> GHCi (Maybe (PrintUnqualified,Type))
 254 evalExpr expr
 255  | null (filter (not.isSpace) expr)
 256  = return Nothing
 257  | otherwise
 258  = do st <- getGHCiState
 259       dflags <- io (getDynFlags)
 260       (new_cmstate, maybe_stuff) <-
 261          io (cmGetExpr (cmstate st) dflags True (current_module st) expr)
 262       setGHCiState st{cmstate = new_cmstate}
 263       case maybe_stuff of
 264          Nothing -> return Nothing
 265          Just (hv, unqual, ty) -> do io (cmRunExpr hv)
 266                                      flushEverything
 267                                      return (Just (unqual,ty))
 268
 269 flushEverything :: GHCi ()
 270 flushEverything
 271    = io $ do flush_so <- readIORef flush_stdout
 272              cmRunExpr flush_so
 273              flush_se <- readIORef flush_stdout
 274              cmRunExpr flush_se
 275
 276 specialCommand :: String -> GHCi Bool
 277 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 278 specialCommand str = do
 279   let (cmd,rest) = break isSpace str
 280   case [ (s,f) | (s,f) <- commands, prefixMatch cmd s ] of
 281      []      -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
 282                                     ++ shortHelpText) >> return False)
 283      [(_,f)] -> f (dropWhile isSpace rest)
 284      cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++
 285                                       " matches multiple commands (" ++
 286                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
 287                                          ++ ")") >> return False)
 288
 289 noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments"))
 290
 291 -----------------------------------------------------------------------------
 292 -- Commands
 293
 294 help :: String -> GHCi ()
 295 help _ = io (putStr helpText)
 296
 297 addModule :: String -> GHCi ()
 298 addModule _ = throwDyn (OtherError ":add not implemented")
 299
 300 setContext :: String -> GHCi ()
 301 setContext ""
 302   = throwDyn (OtherError "syntax: `:m <module>'")
 303 setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
 304   = throwDyn (OtherError ("strange looking module name: `" ++ m ++ "'"))
 305 setContext mn
 306   = do m <- io (moduleNameToModule (mkModuleName mn))
 307        st <- getGHCiState
 308        if (isHomeModule m && m `notElem` modules st)
 309           then throwDyn (OtherError (showSDoc (quotes (ppr (moduleName m))
 310                                 <+> text "is not currently loaded, use :load")))
 311           else setGHCiState st{current_module = m}
 312
 313 moduleNameToModule :: ModuleName -> IO Module
 314 moduleNameToModule mn
 315  = do maybe_stuff <- findModule mn
 316       case maybe_stuff of
 317          Nothing -> throwDyn (OtherError ("can't find module `"
 318                                             ++ moduleNameUserString mn ++ "'"))
 319          Just (m,_) -> return m
 320
 321 changeDirectory :: String -> GHCi ()
 322 changeDirectory d = io (setCurrentDirectory d)
 323
 324 loadModule :: String -> GHCi ()
 325 loadModule path = timeIt (loadModule' path)
 326
 327 loadModule' path = do
 328   state <- getGHCiState
 329   cmstate1 <- io (cmUnload (cmstate state))
 330   io (revertCAFs)                       -- always revert CAFs on load.
 331   (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
 332
 333   def_mod <- io (readIORef defaultCurrentModule)
 334
 335   let new_state = state{
 336                         cmstate = cmstate2,
 337                         modules = mods,
 338                         current_module = case mods of
 339                                            [] -> def_mod
 340                                            xs -> head xs,
 341                         target = Just path
 342                    }
 343   setGHCiState new_state
 344
 345   let mod_commas
 346         | null mods = text "none."
 347         | otherwise = hsep (
 348             punctuate comma (map (text.moduleUserString) mods)) <> text "."
 349   case ok of
 350     False ->
 351        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 352     True  ->
 353        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 354
 355 reloadModule :: String -> GHCi ()
 356 reloadModule "" = do
 357   state <- getGHCiState
 358   case target state of
 359    Nothing -> io (putStr "no current target\n")
 360    Just path
 361       -> do io (revertCAFs)             -- always revert CAFs on reload.
 362             (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
 363             def_mod <- io (readIORef defaultCurrentModule)
 364             setGHCiState
 365                state{cmstate=new_cmstate,
 366                      modules = mods,
 367                      current_module = case mods of
 368                                          [] -> def_mod
 369                                          xs -> head xs
 370                     }
 371
 372 reloadModule _ = noArgs ":reload"
 373
 374 typeOfExpr :: String -> GHCi ()
 375 typeOfExpr str
 376   = do st <- getGHCiState
 377        dflags <- io (getDynFlags)
 378        (new_cmstate, maybe_ty) <- io (cmGetExpr (cmstate st) dflags False
 379                                          (current_module st) str)
 380        setGHCiState st{cmstate = new_cmstate}
 381        case maybe_ty of
 382          Nothing -> return ()
 383          Just (_, unqual, ty) -> io (printForUser stdout unqual (ppr ty))
 384
 385 quit :: String -> GHCi Bool
 386 quit _ = return True
 387
 388 shellEscape :: String -> GHCi Bool
 389 shellEscape str = io (system str >> return False)
 390
 391 ----------------------------------------------------------------------------
 392 -- Code for `:set'
 393
 394 -- set options in the interpreter.  Syntax is exactly the same as the
 395 -- ghc command line, except that certain options aren't available (-C,
 396 -- -E etc.)
 397 --
 398 -- This is pretty fragile: most options won't work as expected.  ToDo:
 399 -- figure out which ones & disallow them.
 400
 401 setOptions :: String -> GHCi ()
 402 setOptions ""
 403   = do st <- getGHCiState
 404        let opts = options st
 405        io $ putStrLn (showSDoc (
 406               text "options currently set: " <>
 407               if null opts
 408                    then text "none."
 409                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 410            ))
 411 setOptions str
 412   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 413        let opts = words str
 414            (minus_opts, rest1) = partition isMinus opts
 415            (plus_opts, rest2)  = partition isPlus rest1
 416
 417        if (not (null rest2))
 418           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 419           else do
 420
 421        mapM setOpt plus_opts
 422
 423        -- now, the GHC flags
 424        io (do -- first, static flags
 425               leftovers <- processArgs static_flags minus_opts []
 426
 427               -- then, dynamic flags
 428               dyn_flags <- readIORef v_InitDynFlags
 429               writeIORef v_DynFlags dyn_flags
 430               leftovers <- processArgs dynamic_flags leftovers []
 431               dyn_flags <- readIORef v_DynFlags
 432               writeIORef v_InitDynFlags dyn_flags
 433
 434               if (not (null leftovers))
 435                  then throwDyn (OtherError ("unrecognised flags: " ++
 436                                                 unwords leftovers))
 437                  else return ()
 438          )
 439
 440 unsetOptions :: String -> GHCi ()
 441 unsetOptions str
 442   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 443        let opts = words str
 444            (minus_opts, rest1) = partition isMinus opts
 445            (plus_opts, rest2)  = partition isPlus rest1
 446
 447        if (not (null rest2))
 448           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 449           else do
 450
 451        mapM unsetOpt plus_opts
 452
 453        -- can't do GHC flags for now
 454        if (not (null minus_opts))
 455           then throwDyn (OtherError "can't unset GHC command-line flags")
 456           else return ()
 457
 458 isMinus ('-':s) = True
 459 isMinus _ = False
 460
 461 isPlus ('+':s) = True
 462 isPlus _ = False
 463
 464 setOpt ('+':str)
 465   = case strToGHCiOpt str of
 466         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 467         Just o  -> setOption o
 468
 469 unsetOpt ('+':str)
 470   = case strToGHCiOpt str of
 471         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 472         Just o  -> unsetOption o
 473
 474 strToGHCiOpt :: String -> (Maybe GHCiOption)
 475 strToGHCiOpt "s" = Just ShowTiming
 476 strToGHCiOpt "t" = Just ShowType
 477 strToGHCiOpt "r" = Just RevertCAFs
 478 strToGHCiOpt _   = Nothing
 479
 480 optToStr :: GHCiOption -> String
 481 optToStr ShowTiming = "s"
 482 optToStr ShowType   = "t"
 483 optToStr RevertCAFs = "r"
 484
 485 -----------------------------------------------------------------------------
 486 -- Code to do last-expression-entered stuff.  (a.k.a the $$ facility)
 487
 488 -- Take a string and replace $$s in it with the last expr, if any.
 489 expandExpr :: String -> GHCi String
 490 expandExpr str
 491    = do mle <- getLastExpr
 492         return (outside mle str)
 493      where
 494         outside mle ('$':'$':cs)
 495            = case mle of
 496                 Just le -> " (" ++ le ++ ") " ++ outside mle cs
 497                 Nothing -> outside mle cs
 498
 499         outside mle []           = []
 500         outside mle ('"':str)    = '"' : inside2 mle str   -- "
 501         outside mle ('\'':str)   = '\'' : inside1 mle str   -- '
 502         outside mle (c:cs)       = c : outside mle cs
 503
 504         inside2 mle ('"':cs)  = '"' : outside mle cs   -- "
 505         inside2 mle (c:cs)    = c : inside2 mle cs
 506         inside2 mle []        = []
 507
 508         inside1 mle ('\'':cs) = '\'': outside mle cs
 509         inside1 mle (c:cs)    = c : inside1 mle cs
 510         inside1 mle []        = []
 511
 512
 513 rememberExpr :: String -> GHCi ()
 514 rememberExpr str
 515    = do let cleaned = (clean . reverse . clean . reverse) str
 516         let forget_me_not | null cleaned = Nothing
 517                           | otherwise    = Just cleaned
 518         setLastExpr forget_me_not
 519      where
 520         clean = dropWhile isSpace
 521
 522
 523 -----------------------------------------------------------------------------
 524 -- GHCi monad
 525
 526 data GHCiState = GHCiState
 527      {
 528         modules        :: [Module],
 529         current_module :: Module,
 530         target         :: Maybe FilePath,
 531         cmstate        :: CmState,
 532         options        :: [GHCiOption],
 533         last_expr      :: Maybe String
 534      }
 535
 536 data GHCiOption
 537         = ShowTiming            -- show time/allocs after evaluation
 538         | ShowType              -- show the type of expressions
 539         | RevertCAFs            -- revert CAFs after every evaluation
 540         deriving Eq
 541
 542 defaultCurrentModuleName = mkModuleName "Prelude"
 543 GLOBAL_VAR(defaultCurrentModule, error "no defaultCurrentModule", Module)
 544
 545 GLOBAL_VAR(flush_stdout, error "no flush_stdout", HValue)
 546 GLOBAL_VAR(flush_stderr, error "no flush_stdout", HValue)
 547
 548 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
 549
 550 instance Monad GHCi where
 551   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
 552   return a  = GHCi $ \s -> return (s,a)
 553
 554 getGHCiState   = GHCi $ \s -> return (s,s)
 555 setGHCiState s = GHCi $ \_ -> return (s,())
 556
 557 isOptionSet :: GHCiOption -> GHCi Bool
 558 isOptionSet opt
 559  = do st <- getGHCiState
 560       return (opt `elem` options st)
 561
 562 setOption :: GHCiOption -> GHCi ()
 563 setOption opt
 564  = do st <- getGHCiState
 565       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 566
 567 unsetOption :: GHCiOption -> GHCi ()
 568 unsetOption opt
 569  = do st <- getGHCiState
 570       setGHCiState (st{ options = filter (/= opt) (options st) })
 571
 572 getLastExpr :: GHCi (Maybe String)
 573 getLastExpr
 574  = do st <- getGHCiState ; return (last_expr st)
 575
 576 setLastExpr :: Maybe String -> GHCi ()
 577 setLastExpr last_expr
 578  = do st <- getGHCiState ; setGHCiState (st{last_expr = last_expr})
 579
 580 io m = GHCi $ \s -> m >>= \a -> return (s,a)
 581
 582 -----------------------------------------------------------------------------
 583 -- recursive exception handlers
 584
 585 -- Don't forget to unblock async exceptions in the handler, or if we're
 586 -- in an exception loop (eg. let a = error a in a) the ^C exception
 587 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
 588
 589 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
 590 ghciHandle h (GHCi m) = GHCi $ \s ->
 591    Exception.catch (m s)
 592         (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
 593
 594 ghciUnblock :: GHCi a -> GHCi a
 595 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
 596
 597 -----------------------------------------------------------------------------
 598 -- package loader
 599
 600 linkPackages :: [Package] -> IO ()
 601 linkPackages pkgs = mapM_ linkPackage pkgs
 602
 603 linkPackage :: Package -> IO ()
 604 -- ignore rts and gmp for now (ToDo; better?)
 605 linkPackage pkg | name pkg `elem` ["rts", "gmp"] = return ()
 606 linkPackage pkg = do
 607   putStr ("Loading package " ++ name pkg ++ " ... ")
 608   let dirs = library_dirs pkg
 609   let objs = map (++".o") (hs_libraries pkg ++ extra_libraries pkg)
 610   mapM (linkOneObj dirs) objs
 611   putStr "resolving ... "
 612   resolveObjs
 613   putStrLn "done."
 614
 615 linkOneObj dirs obj = do
 616   filename <- findFile dirs obj
 617   loadObj filename
 618
 619 findFile [] obj = throwDyn (OtherError ("can't find " ++ obj))
 620 findFile (d:ds) obj = do
 621   let path = d ++ '/':obj
 622   b <- doesFileExist path
 623   if b then return path else findFile ds obj
 624
 625 -----------------------------------------------------------------------------
 626 -- timing & statistics
 627
 628 timeIt :: GHCi a -> GHCi a
 629 timeIt action
 630   = do b <- isOptionSet ShowTiming
 631        if not b
 632           then action
 633           else do allocs1 <- io $ getAllocations
 634                   time1   <- io $ getCPUTime
 635                   a <- action
 636                   allocs2 <- io $ getAllocations
 637                   time2   <- io $ getCPUTime
 638                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
 639                   return a
 640
 641 foreign import "getAllocations" getAllocations :: IO Int
 642
 643 printTimes :: Int -> Integer -> IO ()
 644 printTimes allocs psecs
 645    = do let secs = (fromIntegral psecs / (10^12)) :: Float
 646             secs_str = showFFloat (Just 2) secs
 647         putStrLn (showSDoc (
 648                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 649                          int allocs <+> text "bytes")))
 650
 651 -----------------------------------------------------------------------------
 652 -- reverting CAFs
 653
 654 foreign import revertCAFs :: IO ()      -- make it "safe", just in case