1 -----------------------------------------------------------------------------
2 -- $Id: InteractiveUI.hs,v 1.84 2001/08/09 10:55:53 sewardj Exp $
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2000
8 -----------------------------------------------------------------------------
10 {-# OPTIONS -#include "Linker.h" #-}
11 {-# OPTIONS -#include "SchedAPI.h" #-}
12 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
14 #include "../includes/config.h"
15 #include "HsVersions.h"
19 import HscTypes ( GhciMode(..) )
20 import MkIface ( ifaceTyCls )
26 import Finder ( flushPackageCache )
30 import CmdLineOpts ( DynFlag(..), getDynFlags, saveDynFlags, restoreDynFlags, dopt_unset )
31 import Panic ( GhcException(..) )
34 #ifndef mingw32_TARGET_OS
40 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
54 import PrelGHC ( unsafeCoerce# )
55 import Foreign ( nullPtr )
56 import CString ( peekCString )
58 -----------------------------------------------------------------------------
62 \ / _ \\ /\\ /\\/ __(_)\n\
63 \ / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
64 \/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n\
65 \\\____/\\/ /_/\\____/|_| Type :? for help.\n"
67 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
69 builtin_commands :: [(String, String -> GHCi Bool)]
71 ("add", keepGoing addModule),
72 ("cd", keepGoing changeDirectory),
73 ("def", keepGoing defineMacro),
74 ("help", keepGoing help),
75 ("?", keepGoing help),
76 ("info", keepGoing info),
77 ("load", keepGoing loadModule),
78 ("module", keepGoing setContext),
79 ("reload", keepGoing reloadModule),
80 ("set", keepGoing setOptions),
81 ("type", keepGoing typeOfExpr),
82 ("unset", keepGoing unsetOptions),
83 ("undef", keepGoing undefineMacro),
87 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
88 keepGoing a str = a str >> return False
90 shortHelpText = "use :? for help.\n"
93 \ Commands available from the prompt:\n\
95 \ <stmt> evaluate/run <stmt>\n\
96 \ :add <filename> ... add module(s) to the current target set\n\
97 \ :cd <dir> change directory to <dir>\n\
98 \ :def <cmd> <expr> define a command :<cmd>\n\
99 \ :help, :? display this list of commands\n\
100 \ :info [<name> ...] display information about the given names, or\n\
101 \ about currently loaded files if no names given\n\
102 \ :load <filename> ... load module(s) and their dependents\n\
103 \ :module <mod> set the context for expression evaluation to <mod>\n\
104 \ :reload reload the current module set\n\
105 \ :set <option> ... set options\n\
106 \ :undef <cmd> undefine user-defined command :<cmd>\n\
107 \ :type <expr> show the type of <expr>\n\
108 \ :unset <option> ... unset options\n\
110 \ :!<command> run the shell command <command>\n\
112 \ Options for `:set' and `:unset':\n\
114 \ +r revert top-level expressions after each evaluation\n\
115 \ +s print timing/memory stats after each evaluation\n\
116 \ +t print type after evaluation\n\
117 \ -<flags> most GHC command line flags can also be set here\n\
118 \ (eg. -v2, -fglasgow-exts, etc.)\n\
121 interactiveUI :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
122 interactiveUI cmstate paths cmdline_libs = do
124 hSetBuffering stdout NoBuffering
126 -- link in the available packages
127 pkgs <- getPackageInfo
129 linkPackages cmdline_libs pkgs
131 (cmstate, ok, mods) <-
133 [] -> return (cmstate, True, [])
134 _ -> cmLoadModule cmstate paths
136 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
140 dflags <- getDynFlags
142 (cmstate, maybe_hval)
143 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stderr"
145 Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
146 _ -> panic "interactiveUI:stderr"
148 (cmstate, maybe_hval)
149 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stdout"
151 Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
152 _ -> panic "interactiveUI:stdout"
154 startGHCi runGHCi GHCiState{ targets = paths,
158 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
159 Readline.resetTerminal Nothing
169 exists <- io (doesFileExist file)
171 dir_ok <- io (checkPerms ".")
172 file_ok <- io (checkPerms file)
173 when (dir_ok && file_ok) $ do
174 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
177 Right hdl -> fileLoop hdl False
179 -- Read in $HOME/.ghci
180 either_dir <- io (IO.try (getEnv "HOME"))
184 cwd <- io (getCurrentDirectory)
185 when (dir /= cwd) $ do
186 let file = dir ++ "/.ghci"
187 ok <- io (checkPerms file)
188 either_hdl <- io (IO.try (openFile file ReadMode))
191 Right hdl -> fileLoop hdl False
193 -- read commands from stdin
194 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
201 io $ do putStrLn "Leaving GHCi."
204 -- NOTE: We only read .ghci files if they are owned by the current user,
205 -- and aren't world writable. Otherwise, we could be accidentally
206 -- running code planted by a malicious third party.
208 -- Furthermore, We only read ./.ghci if . is owned by the current user
209 -- and isn't writable by anyone else. I think this is sufficient: we
210 -- don't need to check .. and ../.. etc. because "." always refers to
211 -- the same directory while a process is running.
213 checkPerms :: String -> IO Bool
215 handle (\_ -> return False) $ do
216 #ifdef mingw32_TARGET_OS
219 st <- getFileStatus name
221 if fileOwner st /= me then do
222 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
225 let mode = fileMode st
226 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
227 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
229 putStrLn $ "*** WARNING: " ++ name ++
230 " is writable by someone else, IGNORING!"
235 fileLoop :: Handle -> Bool -> GHCi ()
236 fileLoop hdl prompt = do
238 mod <- io (cmGetContext (cmstate st))
239 when prompt (io (putStr (mod ++ "> ")))
240 l <- io (IO.try (hGetLine hdl))
242 Left e | isEOFError e -> return ()
243 | otherwise -> throw e
245 case remove_spaces l of
246 "" -> fileLoop hdl prompt
247 l -> do quit <- runCommand l
248 if quit then return () else fileLoop hdl prompt
250 stringLoop :: [String] -> GHCi ()
251 stringLoop [] = return ()
252 stringLoop (s:ss) = do
254 case remove_spaces s of
256 l -> do quit <- runCommand l
257 if quit then return () else stringLoop ss
259 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
260 readlineLoop :: GHCi ()
263 mod <- io (cmGetContext (cmstate st))
264 l <- io (readline (mod ++ "> "))
268 case remove_spaces l of
273 if quit then return () else readlineLoop
276 -- Top level exception handler, just prints out the exception
278 runCommand :: String -> GHCi Bool
280 ghciHandle ( \exception -> do
282 showException exception
287 showException (DynException dyn) =
288 case fromDynamic dyn of
290 io (putStrLn ("*** Exception: (unknown)"))
291 Just (PhaseFailed phase code) ->
292 io (putStrLn ("Phase " ++ phase ++ " failed (code "
293 ++ show code ++ ")"))
295 io (putStrLn "Interrupted.")
296 Just (CmdLineError s) ->
297 io (putStrLn s) -- omit the location for CmdLineError
299 io (putStrLn (show other_ghc_ex))
300 showException other_exception
301 = io (putStrLn ("*** Exception: " ++ show other_exception))
303 doCommand (':' : command) = specialCommand command
305 = do timeIt (do stuff <- runStmt stmt; finishEvalExpr stuff)
308 -- Returns True if the expr was successfully parsed, renamed and
310 runStmt :: String -> GHCi (Maybe [Name])
312 | null (filter (not.isSpace) stmt)
315 = do st <- getGHCiState
316 dflags <- io getDynFlags
317 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
318 (new_cmstate, names) <- io (cmRunStmt (cmstate st) dflags' stmt)
319 setGHCiState st{cmstate = new_cmstate}
322 -- possibly print the type and revert CAFs after evaluating an expression
323 finishEvalExpr Nothing = return False
324 finishEvalExpr (Just names)
325 = do b <- isOptionSet ShowType
327 when b (mapM_ (showTypeOfName (cmstate st)) names)
329 b <- isOptionSet RevertCAFs
330 io (when b revertCAFs)
334 showTypeOfName :: CmState -> Name -> GHCi ()
335 showTypeOfName cmstate n
336 = do maybe_str <- io (cmTypeOfName cmstate n)
339 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
341 flushEverything :: GHCi ()
343 = io $ do flush_so <- readIORef flush_stdout
345 flush_se <- readIORef flush_stdout
349 specialCommand :: String -> GHCi Bool
350 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
351 specialCommand str = do
352 let (cmd,rest) = break isSpace str
353 cmds <- io (readIORef commands)
354 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
355 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
356 ++ shortHelpText) >> return False)
357 [(_,f)] -> f (dropWhile isSpace rest)
358 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
359 " matches multiple commands (" ++
360 foldr1 (\a b -> a ++ ',':b) (map fst cs)
361 ++ ")") >> return False)
363 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
365 -----------------------------------------------------------------------------
368 help :: String -> GHCi ()
369 help _ = io (putStr helpText)
371 info :: String -> GHCi ()
372 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
376 let cmst = cmstate st
377 dflags <- io getDynFlags
378 things <- io (mapM (cmInfoThing cmst dflags) names)
379 let real_things = [ x | Just x <- things ]
380 let descs = map (`ifaceTyCls` []) real_things
381 let strings = map (showSDoc . ppr) descs
382 io (mapM_ putStr strings)
384 addModule :: String -> GHCi ()
386 let files = words str
387 state <- getGHCiState
388 dflags <- io (getDynFlags)
389 io (revertCAFs) -- always revert CAFs on load/add.
390 let new_targets = files ++ targets state
391 (cmstate1, ok, mods) <- io (cmLoadModule (cmstate state) new_targets)
392 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
393 modulesLoadedMsg ok mods
395 setContext :: String -> GHCi ()
397 = throwDyn (CmdLineError "syntax: `:m <module>'")
398 setContext m | not (isUpper (head m)) || not (all isAlphaNumEx (tail m))
399 = throwDyn (CmdLineError ("strange looking module name: `" ++ m ++ "'"))
401 isAlphaNumEx c = isAlphaNum c || c == '_'
403 = do st <- getGHCiState
404 new_cmstate <- io (cmSetContext (cmstate st) str)
405 setGHCiState st{cmstate=new_cmstate}
407 changeDirectory :: String -> GHCi ()
408 changeDirectory ('~':d) = do
409 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
410 io (setCurrentDirectory (tilde ++ '/':d))
411 changeDirectory d = io (setCurrentDirectory d)
413 defineMacro :: String -> GHCi ()
415 let (macro_name, definition) = break isSpace s
416 cmds <- io (readIORef commands)
418 then throwDyn (CmdLineError "invalid macro name")
420 if (macro_name `elem` map fst cmds)
421 then throwDyn (CmdLineError
422 ("command `" ++ macro_name ++ "' is already defined"))
425 -- give the expression a type signature, so we can be sure we're getting
426 -- something of the right type.
427 let new_expr = '(' : definition ++ ") :: String -> IO String"
429 -- compile the expression
431 dflags <- io getDynFlags
432 (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
433 setGHCiState st{cmstate = new_cmstate}
436 Just hv -> io (writeIORef commands --
437 ((macro_name, keepGoing (runMacro hv)) : cmds))
439 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
441 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
442 stringLoop (lines str)
444 undefineMacro :: String -> GHCi ()
445 undefineMacro macro_name = do
446 cmds <- io (readIORef commands)
447 if (macro_name `elem` map fst builtin_commands)
448 then throwDyn (CmdLineError
449 ("command `" ++ macro_name ++ "' cannot be undefined"))
451 if (macro_name `notElem` map fst cmds)
452 then throwDyn (CmdLineError
453 ("command `" ++ macro_name ++ "' not defined"))
455 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
457 loadModule :: String -> GHCi ()
458 loadModule str = timeIt (loadModule' str)
461 let files = words str
462 state <- getGHCiState
463 dflags <- io getDynFlags
464 cmstate1 <- io (cmUnload (cmstate state) dflags)
465 setGHCiState state{ cmstate = cmstate1, targets = [] }
466 io (revertCAFs) -- always revert CAFs on load.
467 (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 files)
468 setGHCiState state{ cmstate = cmstate2, targets = files }
469 modulesLoadedMsg ok mods
471 reloadModule :: String -> GHCi ()
473 state <- getGHCiState
474 case targets state of
475 [] -> io (putStr "no current target\n")
477 -> do io (revertCAFs) -- always revert CAFs on reload.
478 (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) paths)
479 setGHCiState state{ cmstate=new_cmstate }
480 modulesLoadedMsg ok mods
482 reloadModule _ = noArgs ":reload"
485 modulesLoadedMsg ok mods = do
487 | null mods = text "none."
489 punctuate comma (map text mods)) <> text "."
492 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
494 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
497 typeOfExpr :: String -> GHCi ()
499 = do st <- getGHCiState
500 dflags <- io getDynFlags
501 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
502 setGHCiState st{cmstate = new_cmstate}
505 Just tystr -> io (putStrLn tystr)
507 quit :: String -> GHCi Bool
510 shellEscape :: String -> GHCi Bool
511 shellEscape str = io (system str >> return False)
513 ----------------------------------------------------------------------------
516 -- set options in the interpreter. Syntax is exactly the same as the
517 -- ghc command line, except that certain options aren't available (-C,
520 -- This is pretty fragile: most options won't work as expected. ToDo:
521 -- figure out which ones & disallow them.
523 setOptions :: String -> GHCi ()
525 = do st <- getGHCiState
526 let opts = options st
527 io $ putStrLn (showSDoc (
528 text "options currently set: " <>
531 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
534 = do -- first, deal with the GHCi opts (+s, +t, etc.)
535 let (plus_opts, minus_opts) = partition isPlus (words str)
536 mapM setOpt plus_opts
538 -- now, the GHC flags
539 pkgs_before <- io (readIORef v_Packages)
540 leftovers <- io (processArgs static_flags minus_opts [])
541 pkgs_after <- io (readIORef v_Packages)
543 -- update things if the users wants more packages
544 when (pkgs_before /= pkgs_after) $
545 newPackages (pkgs_after \\ pkgs_before)
547 -- then, dynamic flags
550 leftovers <- processArgs dynamic_flags leftovers []
553 if (not (null leftovers))
554 then throwDyn (CmdLineError ("unrecognised flags: " ++
559 unsetOptions :: String -> GHCi ()
561 = do -- first, deal with the GHCi opts (+s, +t, etc.)
563 (minus_opts, rest1) = partition isMinus opts
564 (plus_opts, rest2) = partition isPlus rest1
566 if (not (null rest2))
567 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
570 mapM unsetOpt plus_opts
572 -- can't do GHC flags for now
573 if (not (null minus_opts))
574 then throwDyn (CmdLineError "can't unset GHC command-line flags")
577 isMinus ('-':s) = True
580 isPlus ('+':s) = True
584 = case strToGHCiOpt str of
585 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
586 Just o -> setOption o
589 = case strToGHCiOpt str of
590 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
591 Just o -> unsetOption o
593 strToGHCiOpt :: String -> (Maybe GHCiOption)
594 strToGHCiOpt "s" = Just ShowTiming
595 strToGHCiOpt "t" = Just ShowType
596 strToGHCiOpt "r" = Just RevertCAFs
597 strToGHCiOpt _ = Nothing
599 optToStr :: GHCiOption -> String
600 optToStr ShowTiming = "s"
601 optToStr ShowType = "t"
602 optToStr RevertCAFs = "r"
604 newPackages new_pkgs = do
605 state <- getGHCiState
606 dflags <- io getDynFlags
607 cmstate1 <- io (cmUnload (cmstate state) dflags)
608 setGHCiState state{ cmstate = cmstate1, targets = [] }
611 pkgs <- getPackageInfo
612 flushPackageCache pkgs
614 new_pkg_info <- getPackageDetails new_pkgs
615 mapM_ (linkPackage False) (reverse new_pkg_info)
617 -----------------------------------------------------------------------------
620 data GHCiState = GHCiState
622 targets :: [FilePath],
624 options :: [GHCiOption]
628 = ShowTiming -- show time/allocs after evaluation
629 | ShowType -- show the type of expressions
630 | RevertCAFs -- revert CAFs after every evaluation
633 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
634 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
636 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
638 startGHCi :: GHCi a -> GHCiState -> IO a
639 startGHCi g state = do ref <- newIORef state; unGHCi g ref
641 instance Monad GHCi where
642 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
643 return a = GHCi $ \s -> return a
645 getGHCiState = GHCi $ \r -> readIORef r
646 setGHCiState s = GHCi $ \r -> writeIORef r s
648 isOptionSet :: GHCiOption -> GHCi Bool
650 = do st <- getGHCiState
651 return (opt `elem` options st)
653 setOption :: GHCiOption -> GHCi ()
655 = do st <- getGHCiState
656 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
658 unsetOption :: GHCiOption -> GHCi ()
660 = do st <- getGHCiState
661 setGHCiState (st{ options = filter (/= opt) (options st) })
664 io m = GHCi { unGHCi = \s -> m >>= return }
666 -----------------------------------------------------------------------------
667 -- recursive exception handlers
669 -- Don't forget to unblock async exceptions in the handler, or if we're
670 -- in an exception loop (eg. let a = error a in a) the ^C exception
671 -- may never be delivered. Thanks to Marcin for pointing out the bug.
673 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
674 ghciHandle h (GHCi m) = GHCi $ \s ->
675 Exception.catch (m s)
676 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
678 ghciUnblock :: GHCi a -> GHCi a
679 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
681 -----------------------------------------------------------------------------
684 -- Left: full path name of a .o file, including trailing .o
685 -- Right: "unadorned" name of a .DLL/.so
686 -- e.g. On unix "qt" denotes "libqt.so"
687 -- On WinDoze "burble" denotes "burble.DLL"
688 -- addDLL is platform-specific and adds the lib/.so/.DLL
689 -- suffixes platform-dependently; we don't do that here.
691 -- For dynamic objects only, try to find the object file in all the
692 -- directories specified in v_Library_Paths before giving up.
695 = Either FilePath String
697 showLS (Left nm) = "(static) " ++ nm
698 showLS (Right nm) = "(dynamic) " ++ nm
700 linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO ()
701 linkPackages cmdline_lib_specs pkgs
702 = do sequence_ [ linkPackage (name p `elem` loaded) p | p <- reverse pkgs ]
703 lib_paths <- readIORef v_Library_paths
704 mapM_ (preloadLib lib_paths) cmdline_lib_specs
706 -- Packages that are already linked into GHCi. For mingw32, we only
707 -- skip gmp and rts, since std and after need to load the msvcrt.dll
708 -- library which std depends on.
710 # ifndef mingw32_TARGET_OS
711 = [ "gmp", "rts", "std", "concurrent", "posix", "text", "util" ]
716 preloadLib :: [String] -> LibrarySpec -> IO ()
717 preloadLib lib_paths lib_spec
718 = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
721 -> do b <- preload_static lib_paths static_ish
722 putStrLn (if b then "done" else "not found")
724 -> -- We add "" to the set of paths to try, so that
725 -- if none of the real paths match, we force addDLL
726 -- to look in the default dynamic-link search paths.
727 do b <- preload_dynamic (lib_paths++[""]) dll_unadorned
728 when (not b) (cantFind lib_paths lib_spec)
731 cantFind :: [String] -> LibrarySpec -> IO ()
733 = do putStr ("failed.\nCan't find " ++ showLS spec
734 ++ " in directories:\n"
735 ++ unlines (map (" "++) paths) )
738 -- not interested in the paths in the static case.
739 preload_static paths name
740 = do b <- doesFileExist name
741 if not b then return False
742 else loadObj name >> return True
744 preload_dynamic [] name
746 preload_dynamic (path:paths) rootname
747 = do maybe_errmsg <- addDLL path rootname
748 if maybe_errmsg /= nullPtr
749 then preload_dynamic paths rootname
753 = (throwDyn . CmdLineError)
754 "user specified .o/.so/.DLL could not be loaded."
757 linkPackage :: Bool -> PackageConfig -> IO ()
758 -- ignore rts and gmp for now (ToDo; better?)
759 linkPackage loaded_in_ghci pkg
760 | name pkg `elem` ["rts", "gmp"]
763 = do putStr ("Loading package " ++ name pkg ++ " ... ")
764 -- For each obj, try obj.o and if that fails, obj.so.
765 -- Complication: all the .so's must be loaded before any of the .o's.
766 let dirs = library_dirs pkg
767 let objs = hs_libraries pkg ++ extra_libraries pkg
768 classifieds <- mapM (locateOneObj dirs) objs
770 -- Don't load the .so libs if this is a package GHCi is already
771 -- linked against, because we'll already have the .so linked in.
772 let (so_libs, obj_libs) = partition isRight classifieds
773 let sos_first | loaded_in_ghci = obj_libs
774 | otherwise = so_libs ++ obj_libs
776 mapM loadClassified sos_first
777 putStr "linking ... "
781 isRight (Right _) = True
782 isRight (Left _) = False
784 loadClassified :: LibrarySpec -> IO ()
785 loadClassified (Left obj_absolute_filename)
786 = do loadObj obj_absolute_filename
787 loadClassified (Right dll_unadorned)
788 = do maybe_errmsg <- addDLL "" dll_unadorned -- doesn't seem right to me
789 if maybe_errmsg == nullPtr
791 else do str <- peekCString maybe_errmsg
792 throwDyn (CmdLineError ("can't load .so/.DLL for: "
793 ++ dll_unadorned ++ " (" ++ str ++ ")" ))
795 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
797 = return (Right obj) -- we assume
798 locateOneObj (d:ds) obj
799 = do let path = d ++ '/':obj ++ ".o"
800 b <- doesFileExist path
801 if b then return (Left path) else locateOneObj ds obj
803 -----------------------------------------------------------------------------
804 -- timing & statistics
806 timeIt :: GHCi a -> GHCi a
808 = do b <- isOptionSet ShowTiming
811 else do allocs1 <- io $ getAllocations
812 time1 <- io $ getCPUTime
814 allocs2 <- io $ getAllocations
815 time2 <- io $ getCPUTime
816 io $ printTimes (allocs2 - allocs1) (time2 - time1)
819 foreign import "getAllocations" getAllocations :: IO Int
821 printTimes :: Int -> Integer -> IO ()
822 printTimes allocs psecs
823 = do let secs = (fromIntegral psecs / (10^12)) :: Float
824 secs_str = showFFloat (Just 2) secs
826 parens (text (secs_str "") <+> text "secs" <> comma <+>
827 int allocs <+> text "bytes")))
829 -----------------------------------------------------------------------------
832 foreign import revertCAFs :: IO () -- make it "safe", just in case