ghc/compiler/ghci/InteractiveUI.hs

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