1 -----------------------------------------------------------------------------
2 -- $Id: InteractiveUI.hs,v 1.78 2001/06/27 11:17:47 simonmar Exp $
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2000
8 -----------------------------------------------------------------------------
10 {-# OPTIONS -#include "Linker.h" #-}
11 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
13 #include "../includes/config.h"
14 #include "HsVersions.h"
18 import HscTypes ( GhciMode(..) )
24 import Finder ( flushPackageCache )
28 import CmdLineOpts ( DynFlag(..), getDynFlags, saveDynFlags, restoreDynFlags, dopt_unset )
29 import Panic ( GhcException(..) )
32 #ifndef mingw32_TARGET_OS
38 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
52 import PrelGHC ( unsafeCoerce# )
53 import Foreign ( nullPtr )
54 import CString ( peekCString )
56 -----------------------------------------------------------------------------
60 \ / _ \\ /\\ /\\/ __(_)\n\
61 \ / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
62 \/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n\
63 \\\____/\\/ /_/\\____/|_| Type :? for help.\n"
65 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
67 builtin_commands :: [(String, String -> GHCi Bool)]
69 ("add", keepGoing addModule),
70 ("cd", keepGoing changeDirectory),
71 ("def", keepGoing defineMacro),
72 ("help", keepGoing help),
73 ("?", keepGoing help),
74 ("load", keepGoing loadModule),
75 ("module", keepGoing setContext),
76 ("reload", keepGoing reloadModule),
77 ("set", keepGoing setOptions),
78 ("type", keepGoing typeOfExpr),
79 ("unset", keepGoing unsetOptions),
80 ("undef", keepGoing undefineMacro),
84 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
85 keepGoing a str = a str >> return False
87 shortHelpText = "use :? for help.\n"
90 \ Commands available from the prompt:\n\
92 \ <stmt> evaluate/run <stmt>\n\
93 \ :cd <dir> change directory to <dir>\n\
94 \ :def <cmd> <expr> define a command :<cmd>\n\
95 \ :help, :? display this list of commands\n\
96 \ :load <filename> load a module (and its dependents)\n\
97 \ :module <mod> set the context for expression evaluation to <mod>\n\
98 \ :reload reload the current module set\n\
99 \ :set <option> ... set options\n\
100 \ :undef <cmd> undefine user-defined command :<cmd>\n\
101 \ :type <expr> show the type of <expr>\n\
102 \ :unset <option> ... unset options\n\
104 \ :!<command> run the shell command <command>\n\
106 \ Options for `:set' and `:unset':\n\
108 \ +r revert top-level expressions after each evaluation\n\
109 \ +s print timing/memory stats after each evaluation\n\
110 \ +t print type after evaluation\n\
111 \ -<flags> most GHC command line flags can also be set here\n\
112 \ (eg. -v2, -fglasgow-exts, etc.)\n\
114 --ToDo :add <filename> add a module to the current set\n\
116 interactiveUI :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
117 interactiveUI cmstate paths cmdline_libs = do
119 hSetBuffering stdout NoBuffering
121 -- link in the available packages
122 pkgs <- getPackageInfo
124 linkPackages cmdline_libs pkgs
126 (cmstate, ok, mods) <-
128 [] -> return (cmstate, True, [])
129 _ -> cmLoadModule cmstate paths
131 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
135 dflags <- getDynFlags
137 (cmstate, maybe_hval)
138 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stderr"
140 Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
141 _ -> panic "interactiveUI:stderr"
143 (cmstate, maybe_hval)
144 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stdout"
146 Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
147 _ -> panic "interactiveUI:stdout"
149 startGHCi runGHCi GHCiState{ targets = paths,
159 exists <- io (doesFileExist file)
161 dir_ok <- io (checkPerms ".")
162 file_ok <- io (checkPerms file)
163 when (dir_ok && file_ok) $ do
164 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
167 Right hdl -> fileLoop hdl False
169 -- Read in $HOME/.ghci
170 either_dir <- io (IO.try (getEnv "HOME"))
174 cwd <- io (getCurrentDirectory)
175 when (dir /= cwd) $ do
176 let file = dir ++ "/.ghci"
177 ok <- io (checkPerms file)
178 either_hdl <- io (IO.try (openFile file ReadMode))
181 Right hdl -> fileLoop hdl False
183 -- read commands from stdin
184 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
191 io $ do putStrLn "Leaving GHCi."
194 -- NOTE: We only read .ghci files if they are owned by the current user,
195 -- and aren't world writable. Otherwise, we could be accidentally
196 -- running code planted by a malicious third party.
198 -- Furthermore, We only read ./.ghci if both . and ./.ghci are
199 -- owned by the current user and aren't writable by anyone else. I
200 -- think this is sufficient: we don't need to check .. and
201 -- ../.. etc. because "." always refers to the same directory while a
202 -- process is running.
204 checkPerms :: String -> IO Bool
206 handle (\_ -> return False) $ do
207 #ifdef mingw32_TARGET_OS
210 st <- getFileStatus name
212 if fileOwner st /= me then do
213 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
216 let mode = fileMode st
217 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
218 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
220 putStrLn $ "*** WARNING: " ++ name ++
221 " is writable by someone else, IGNORING!"
226 fileLoop :: Handle -> Bool -> GHCi ()
227 fileLoop hdl prompt = do
229 mod <- io (cmGetContext (cmstate st))
230 when prompt (io (putStr (mod ++ "> ")))
231 l <- io (IO.try (hGetLine hdl))
233 Left e | isEOFError e -> return ()
234 | otherwise -> throw e
236 case remove_spaces l of
237 "" -> fileLoop hdl prompt
238 l -> do quit <- runCommand l
239 if quit then return () else fileLoop hdl prompt
241 stringLoop :: [String] -> GHCi ()
242 stringLoop [] = return ()
243 stringLoop (s:ss) = do
245 case remove_spaces s of
247 l -> do quit <- runCommand l
248 if quit then return () else stringLoop ss
250 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
251 readlineLoop :: GHCi ()
254 mod <- io (cmGetContext (cmstate st))
255 l <- io (readline (mod ++ "> "))
259 case remove_spaces l of
264 if quit then return () else readlineLoop
267 -- Top level exception handler, just prints out the exception
269 runCommand :: String -> GHCi Bool
271 ghciHandle ( \exception -> do
273 showException exception
278 showException (DynException dyn) =
279 case fromDynamic dyn of
281 io (putStrLn ("*** Exception: (unknown)"))
282 Just (PhaseFailed phase code) ->
283 io (putStrLn ("Phase " ++ phase ++ " failed (code "
284 ++ show code ++ ")"))
286 io (putStrLn "Interrupted.")
287 Just (CmdLineError s) ->
288 io (putStrLn s) -- omit the location for CmdLineError
290 io (putStrLn (show other_ghc_ex))
291 showException other_exception
292 = io (putStrLn ("*** Exception: " ++ show other_exception))
294 doCommand (':' : command) = specialCommand command
296 = do timeIt (do stuff <- runStmt stmt; finishEvalExpr stuff)
299 -- Returns True if the expr was successfully parsed, renamed and
301 runStmt :: String -> GHCi (Maybe [Name])
303 | null (filter (not.isSpace) stmt)
306 = do st <- getGHCiState
307 dflags <- io getDynFlags
308 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
309 (new_cmstate, names) <- io (cmRunStmt (cmstate st) dflags' stmt)
310 setGHCiState st{cmstate = new_cmstate}
313 -- possibly print the type and revert CAFs after evaluating an expression
314 finishEvalExpr Nothing = return False
315 finishEvalExpr (Just names)
316 = do b <- isOptionSet ShowType
318 when b (mapM_ (showTypeOfName (cmstate st)) names)
320 b <- isOptionSet RevertCAFs
321 io (when b revertCAFs)
325 showTypeOfName :: CmState -> Name -> GHCi ()
326 showTypeOfName cmstate n
327 = do maybe_str <- io (cmTypeOfName cmstate n)
330 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
332 flushEverything :: GHCi ()
334 = io $ do flush_so <- readIORef flush_stdout
336 flush_se <- readIORef flush_stdout
340 specialCommand :: String -> GHCi Bool
341 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
342 specialCommand str = do
343 let (cmd,rest) = break isSpace str
344 cmds <- io (readIORef commands)
345 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
346 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
347 ++ shortHelpText) >> return False)
348 [(_,f)] -> f (dropWhile isSpace rest)
349 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
350 " matches multiple commands (" ++
351 foldr1 (\a b -> a ++ ',':b) (map fst cs)
352 ++ ")") >> return False)
354 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
356 -----------------------------------------------------------------------------
359 help :: String -> GHCi ()
360 help _ = io (putStr helpText)
362 addModule :: String -> GHCi ()
364 state <- getGHCiState
365 dflags <- io (getDynFlags)
366 io (revertCAFs) -- always revert CAFs on load/add.
367 let new_targets = path : targets state
368 (cmstate1, ok, mods) <- io (cmLoadModule (cmstate state) new_targets)
369 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
370 modulesLoadedMsg ok mods
372 setContext :: String -> GHCi ()
374 = throwDyn (CmdLineError "syntax: `:m <module>'")
375 setContext m | not (isUpper (head m)) || not (all isAlphaNumEx (tail m))
376 = throwDyn (CmdLineError ("strange looking module name: `" ++ m ++ "'"))
378 isAlphaNumEx c = isAlphaNum c || c == '_'
380 = do st <- getGHCiState
381 new_cmstate <- io (cmSetContext (cmstate st) str)
382 setGHCiState st{cmstate=new_cmstate}
384 changeDirectory :: String -> GHCi ()
385 changeDirectory ('~':d) = do
386 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
387 io (setCurrentDirectory (tilde ++ '/':d))
388 changeDirectory d = io (setCurrentDirectory d)
390 defineMacro :: String -> GHCi ()
392 let (macro_name, definition) = break isSpace s
393 cmds <- io (readIORef commands)
395 then throwDyn (CmdLineError "invalid macro name")
397 if (macro_name `elem` map fst cmds)
398 then throwDyn (CmdLineError
399 ("command `" ++ macro_name ++ "' is already defined"))
402 -- give the expression a type signature, so we can be sure we're getting
403 -- something of the right type.
404 let new_expr = '(' : definition ++ ") :: String -> IO String"
406 -- compile the expression
408 dflags <- io getDynFlags
409 (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
410 setGHCiState st{cmstate = new_cmstate}
413 Just hv -> io (writeIORef commands --
414 ((macro_name, keepGoing (runMacro hv)) : cmds))
416 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
418 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
419 stringLoop (lines str)
421 undefineMacro :: String -> GHCi ()
422 undefineMacro macro_name = do
423 cmds <- io (readIORef commands)
424 if (macro_name `elem` map fst builtin_commands)
425 then throwDyn (CmdLineError
426 ("command `" ++ macro_name ++ "' cannot be undefined"))
428 if (macro_name `notElem` map fst cmds)
429 then throwDyn (CmdLineError
430 ("command `" ++ macro_name ++ "' not defined"))
432 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
434 loadModule :: String -> GHCi ()
435 loadModule path = timeIt (loadModule' path)
437 loadModule' path = do
438 state <- getGHCiState
439 dflags <- io getDynFlags
440 cmstate1 <- io (cmUnload (cmstate state) dflags)
441 setGHCiState state{ cmstate = cmstate1, targets = [] }
442 io (revertCAFs) -- always revert CAFs on load.
443 (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 [path])
444 setGHCiState state{ cmstate = cmstate2, targets = [path] }
445 modulesLoadedMsg ok mods
447 reloadModule :: String -> GHCi ()
449 state <- getGHCiState
450 case targets state of
451 [] -> io (putStr "no current target\n")
453 -> do io (revertCAFs) -- always revert CAFs on reload.
454 (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) paths)
455 setGHCiState state{ cmstate=new_cmstate }
456 modulesLoadedMsg ok mods
458 reloadModule _ = noArgs ":reload"
461 modulesLoadedMsg ok mods = do
463 | null mods = text "none."
465 punctuate comma (map text mods)) <> text "."
468 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
470 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
473 typeOfExpr :: String -> GHCi ()
475 = do st <- getGHCiState
476 dflags <- io getDynFlags
477 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
478 setGHCiState st{cmstate = new_cmstate}
481 Just tystr -> io (putStrLn tystr)
483 quit :: String -> GHCi Bool
486 shellEscape :: String -> GHCi Bool
487 shellEscape str = io (system str >> return False)
489 ----------------------------------------------------------------------------
492 -- set options in the interpreter. Syntax is exactly the same as the
493 -- ghc command line, except that certain options aren't available (-C,
496 -- This is pretty fragile: most options won't work as expected. ToDo:
497 -- figure out which ones & disallow them.
499 setOptions :: String -> GHCi ()
501 = do st <- getGHCiState
502 let opts = options st
503 io $ putStrLn (showSDoc (
504 text "options currently set: " <>
507 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
510 = do -- first, deal with the GHCi opts (+s, +t, etc.)
511 let (plus_opts, minus_opts) = partition isPlus (words str)
512 mapM setOpt plus_opts
514 -- now, the GHC flags
515 pkgs_before <- io (readIORef v_Packages)
516 leftovers <- io (processArgs static_flags minus_opts [])
517 pkgs_after <- io (readIORef v_Packages)
519 -- update things if the users wants more packages
520 when (pkgs_before /= pkgs_after) $
521 newPackages (pkgs_after \\ pkgs_before)
523 -- then, dynamic flags
526 leftovers <- processArgs dynamic_flags leftovers []
529 if (not (null leftovers))
530 then throwDyn (CmdLineError ("unrecognised flags: " ++
535 unsetOptions :: String -> GHCi ()
537 = do -- first, deal with the GHCi opts (+s, +t, etc.)
539 (minus_opts, rest1) = partition isMinus opts
540 (plus_opts, rest2) = partition isPlus rest1
542 if (not (null rest2))
543 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
546 mapM unsetOpt plus_opts
548 -- can't do GHC flags for now
549 if (not (null minus_opts))
550 then throwDyn (CmdLineError "can't unset GHC command-line flags")
553 isMinus ('-':s) = True
556 isPlus ('+':s) = True
560 = case strToGHCiOpt str of
561 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
562 Just o -> setOption o
565 = case strToGHCiOpt str of
566 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
567 Just o -> unsetOption o
569 strToGHCiOpt :: String -> (Maybe GHCiOption)
570 strToGHCiOpt "s" = Just ShowTiming
571 strToGHCiOpt "t" = Just ShowType
572 strToGHCiOpt "r" = Just RevertCAFs
573 strToGHCiOpt _ = Nothing
575 optToStr :: GHCiOption -> String
576 optToStr ShowTiming = "s"
577 optToStr ShowType = "t"
578 optToStr RevertCAFs = "r"
580 newPackages new_pkgs = do
581 state <- getGHCiState
582 dflags <- io getDynFlags
583 cmstate1 <- io (cmUnload (cmstate state) dflags)
584 setGHCiState state{ cmstate = cmstate1, targets = [] }
587 pkgs <- getPackageInfo
588 flushPackageCache pkgs
590 new_pkg_info <- getPackageDetails new_pkgs
591 mapM_ (linkPackage False) (reverse new_pkg_info)
593 -----------------------------------------------------------------------------
596 data GHCiState = GHCiState
598 targets :: [FilePath],
600 options :: [GHCiOption]
604 = ShowTiming -- show time/allocs after evaluation
605 | ShowType -- show the type of expressions
606 | RevertCAFs -- revert CAFs after every evaluation
609 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
610 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
612 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
614 startGHCi :: GHCi a -> GHCiState -> IO a
615 startGHCi g state = do ref <- newIORef state; unGHCi g ref
617 instance Monad GHCi where
618 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
619 return a = GHCi $ \s -> return a
621 getGHCiState = GHCi $ \r -> readIORef r
622 setGHCiState s = GHCi $ \r -> writeIORef r s
624 isOptionSet :: GHCiOption -> GHCi Bool
626 = do st <- getGHCiState
627 return (opt `elem` options st)
629 setOption :: GHCiOption -> GHCi ()
631 = do st <- getGHCiState
632 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
634 unsetOption :: GHCiOption -> GHCi ()
636 = do st <- getGHCiState
637 setGHCiState (st{ options = filter (/= opt) (options st) })
639 io m = GHCi $ \s -> m >>= \a -> return a
641 -----------------------------------------------------------------------------
642 -- recursive exception handlers
644 -- Don't forget to unblock async exceptions in the handler, or if we're
645 -- in an exception loop (eg. let a = error a in a) the ^C exception
646 -- may never be delivered. Thanks to Marcin for pointing out the bug.
648 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
649 ghciHandle h (GHCi m) = GHCi $ \s ->
650 Exception.catch (m s)
651 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
653 ghciUnblock :: GHCi a -> GHCi a
654 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
656 -----------------------------------------------------------------------------
659 -- Left: full path name of a .o file, including trailing .o
660 -- Right: "unadorned" name of a .DLL/.so
661 -- e.g. On unix "qt" denotes "libqt.so"
662 -- On WinDoze "burble" denotes "burble.DLL"
663 -- addDLL is platform-specific and adds the lib/.so/.DLL
664 -- suffixes platform-dependently; we don't do that here.
666 -- For dynamic objects only, try to find the object file in all the
667 -- directories specified in v_Library_Paths before giving up.
670 = Either FilePath String
672 showLS (Left nm) = "(static) " ++ nm
673 showLS (Right nm) = "(dynamic) " ++ nm
675 linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO ()
676 linkPackages cmdline_lib_specs pkgs
677 = do sequence_ [ linkPackage (name p `elem` loaded) p | p <- reverse pkgs ]
678 lib_paths <- readIORef v_Library_paths
679 mapM_ (preloadLib lib_paths) cmdline_lib_specs
681 -- packages that are already linked into GHCi
682 loaded = [ "gmp", "rts", "std", "concurrent", "posix", "text", "util" ]
684 preloadLib :: [String] -> LibrarySpec -> IO ()
685 preloadLib lib_paths lib_spec
686 = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
689 -> do b <- preload_static lib_paths static_ish
690 putStrLn (if b then "done" else "not found")
692 -> -- We add "" to the set of paths to try, so that
693 -- if none of the real paths match, we force addDLL
694 -- to look in the default dynamic-link search paths.
695 do b <- preload_dynamic (lib_paths++[""]) dll_unadorned
696 when (not b) (cantFind lib_paths lib_spec)
699 cantFind :: [String] -> LibrarySpec -> IO ()
701 = do putStr ("failed.\nCan't find " ++ showLS spec
702 ++ " in directories:\n"
703 ++ unlines (map (" "++) paths) )
706 -- not interested in the paths in the static case.
707 preload_static paths name
708 = do b <- doesFileExist name
709 if not b then return False
710 else loadObj name >> return True
712 preload_dynamic [] name
714 preload_dynamic (path:paths) rootname
715 = do maybe_errmsg <- addDLL path rootname
716 if maybe_errmsg /= nullPtr
717 then preload_dynamic paths rootname
721 = (throwDyn . CmdLineError)
722 "user specified .o/.so/.DLL could not be loaded."
725 linkPackage :: Bool -> PackageConfig -> IO ()
726 -- ignore rts and gmp for now (ToDo; better?)
727 linkPackage loaded_in_ghci pkg
728 | name pkg `elem` ["rts", "gmp"]
731 = do putStr ("Loading package " ++ name pkg ++ " ... ")
732 -- For each obj, try obj.o and if that fails, obj.so.
733 -- Complication: all the .so's must be loaded before any of the .o's.
734 let dirs = library_dirs pkg
735 let objs = hs_libraries pkg ++ extra_libraries pkg
736 classifieds <- mapM (locateOneObj dirs) objs
738 -- Don't load the .so libs if this is a package GHCi is already
739 -- linked against, because we'll already have the .so linked in.
740 let (so_libs, obj_libs) = partition isRight classifieds
741 let sos_first | loaded_in_ghci = obj_libs
742 | otherwise = so_libs ++ obj_libs
744 mapM loadClassified sos_first
745 putStr "linking ... "
749 isRight (Right _) = True
750 isRight (Left _) = False
752 loadClassified :: LibrarySpec -> IO ()
753 loadClassified (Left obj_absolute_filename)
754 = do loadObj obj_absolute_filename
755 loadClassified (Right dll_unadorned)
756 = do maybe_errmsg <- addDLL "" dll_unadorned -- doesn't seem right to me
757 if maybe_errmsg == nullPtr
759 else do str <- peekCString maybe_errmsg
760 throwDyn (CmdLineError ("can't load .so/.DLL for: "
761 ++ dll_unadorned ++ " (" ++ str ++ ")" ))
763 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
765 = return (Right obj) -- we assume
766 locateOneObj (d:ds) obj
767 = do let path = d ++ '/':obj ++ ".o"
768 b <- doesFileExist path
769 if b then return (Left path) else locateOneObj ds obj
771 -----------------------------------------------------------------------------
772 -- timing & statistics
774 timeIt :: GHCi a -> GHCi a
776 = do b <- isOptionSet ShowTiming
779 else do allocs1 <- io $ getAllocations
780 time1 <- io $ getCPUTime
782 allocs2 <- io $ getAllocations
783 time2 <- io $ getCPUTime
784 io $ printTimes (allocs2 - allocs1) (time2 - time1)
787 foreign import "getAllocations" getAllocations :: IO Int
789 printTimes :: Int -> Integer -> IO ()
790 printTimes allocs psecs
791 = do let secs = (fromIntegral psecs / (10^12)) :: Float
792 secs_str = showFFloat (Just 2) secs
794 parens (text (secs_str "") <+> text "secs" <> comma <+>
795 int allocs <+> text "bytes")))
797 -----------------------------------------------------------------------------
800 foreign import revertCAFs :: IO () -- make it "safe", just in case