1 -----------------------------------------------------------------------------
2 -- $Id: InteractiveUI.hs,v 1.85 2001/08/13 15:49:37 simonmar 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
167 read_dot_files <- io (readIORef v_Read_DotGHCi)
169 when (read_dot_files) $ do
172 exists <- io (doesFileExist file)
174 dir_ok <- io (checkPerms ".")
175 file_ok <- io (checkPerms file)
176 when (dir_ok && file_ok) $ do
177 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
180 Right hdl -> fileLoop hdl False
182 when (read_dot_files) $ do
183 -- Read in $HOME/.ghci
184 either_dir <- io (IO.try (getEnv "HOME"))
188 cwd <- io (getCurrentDirectory)
189 when (dir /= cwd) $ do
190 let file = dir ++ "/.ghci"
191 ok <- io (checkPerms file)
193 either_hdl <- io (IO.try (openFile file ReadMode))
196 Right hdl -> fileLoop hdl False
198 -- read commands from stdin
199 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
206 io $ do putStrLn "Leaving GHCi."
209 -- NOTE: We only read .ghci files if they are owned by the current user,
210 -- and aren't world writable. Otherwise, we could be accidentally
211 -- running code planted by a malicious third party.
213 -- Furthermore, We only read ./.ghci if . is owned by the current user
214 -- and isn't writable by anyone else. I think this is sufficient: we
215 -- don't need to check .. and ../.. etc. because "." always refers to
216 -- the same directory while a process is running.
218 checkPerms :: String -> IO Bool
220 handle (\_ -> return False) $ do
221 #ifdef mingw32_TARGET_OS
224 st <- getFileStatus name
226 if fileOwner st /= me then do
227 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
230 let mode = fileMode st
231 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
232 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
234 putStrLn $ "*** WARNING: " ++ name ++
235 " is writable by someone else, IGNORING!"
240 fileLoop :: Handle -> Bool -> GHCi ()
241 fileLoop hdl prompt = do
243 mod <- io (cmGetContext (cmstate st))
244 when prompt (io (putStr (mod ++ "> ")))
245 l <- io (IO.try (hGetLine hdl))
247 Left e | isEOFError e -> return ()
248 | otherwise -> throw e
250 case remove_spaces l of
251 "" -> fileLoop hdl prompt
252 l -> do quit <- runCommand l
253 if quit then return () else fileLoop hdl prompt
255 stringLoop :: [String] -> GHCi ()
256 stringLoop [] = return ()
257 stringLoop (s:ss) = do
259 case remove_spaces s of
261 l -> do quit <- runCommand l
262 if quit then return () else stringLoop ss
264 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
265 readlineLoop :: GHCi ()
268 mod <- io (cmGetContext (cmstate st))
269 l <- io (readline (mod ++ "> "))
273 case remove_spaces l of
278 if quit then return () else readlineLoop
281 -- Top level exception handler, just prints out the exception
283 runCommand :: String -> GHCi Bool
285 ghciHandle ( \exception -> do
287 showException exception
292 showException (DynException dyn) =
293 case fromDynamic dyn of
295 io (putStrLn ("*** Exception: (unknown)"))
296 Just (PhaseFailed phase code) ->
297 io (putStrLn ("Phase " ++ phase ++ " failed (code "
298 ++ show code ++ ")"))
300 io (putStrLn "Interrupted.")
301 Just (CmdLineError s) ->
302 io (putStrLn s) -- omit the location for CmdLineError
304 io (putStrLn (show other_ghc_ex))
305 showException other_exception
306 = io (putStrLn ("*** Exception: " ++ show other_exception))
308 doCommand (':' : command) = specialCommand command
310 = do timeIt (do stuff <- runStmt stmt; finishEvalExpr stuff)
313 -- Returns True if the expr was successfully parsed, renamed and
315 runStmt :: String -> GHCi (Maybe [Name])
317 | null (filter (not.isSpace) stmt)
320 = do st <- getGHCiState
321 dflags <- io getDynFlags
322 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
323 (new_cmstate, names) <- io (cmRunStmt (cmstate st) dflags' stmt)
324 setGHCiState st{cmstate = new_cmstate}
327 -- possibly print the type and revert CAFs after evaluating an expression
328 finishEvalExpr Nothing = return False
329 finishEvalExpr (Just names)
330 = do b <- isOptionSet ShowType
332 when b (mapM_ (showTypeOfName (cmstate st)) names)
334 b <- isOptionSet RevertCAFs
335 io (when b revertCAFs)
339 showTypeOfName :: CmState -> Name -> GHCi ()
340 showTypeOfName cmstate n
341 = do maybe_str <- io (cmTypeOfName cmstate n)
344 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
346 flushEverything :: GHCi ()
348 = io $ do flush_so <- readIORef flush_stdout
350 flush_se <- readIORef flush_stdout
354 specialCommand :: String -> GHCi Bool
355 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
356 specialCommand str = do
357 let (cmd,rest) = break isSpace str
358 cmds <- io (readIORef commands)
359 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
360 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
361 ++ shortHelpText) >> return False)
362 [(_,f)] -> f (dropWhile isSpace rest)
363 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
364 " matches multiple commands (" ++
365 foldr1 (\a b -> a ++ ',':b) (map fst cs)
366 ++ ")") >> return False)
368 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
370 -----------------------------------------------------------------------------
373 help :: String -> GHCi ()
374 help _ = io (putStr helpText)
376 info :: String -> GHCi ()
377 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
381 let cmst = cmstate st
382 dflags <- io getDynFlags
383 things <- io (mapM (cmInfoThing cmst dflags) names)
384 let real_things = [ x | Just x <- things ]
385 let descs = map (`ifaceTyCls` []) real_things
386 let strings = map (showSDoc . ppr) descs
387 io (mapM_ putStr strings)
389 addModule :: String -> GHCi ()
391 let files = words str
392 state <- getGHCiState
393 dflags <- io (getDynFlags)
394 io (revertCAFs) -- always revert CAFs on load/add.
395 let new_targets = files ++ targets state
396 (cmstate1, ok, mods) <- io (cmLoadModule (cmstate state) new_targets)
397 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
398 modulesLoadedMsg ok mods
400 setContext :: String -> GHCi ()
402 = throwDyn (CmdLineError "syntax: `:m <module>'")
403 setContext m | not (isUpper (head m)) || not (all isAlphaNumEx (tail m))
404 = throwDyn (CmdLineError ("strange looking module name: `" ++ m ++ "'"))
406 isAlphaNumEx c = isAlphaNum c || c == '_'
408 = do st <- getGHCiState
409 new_cmstate <- io (cmSetContext (cmstate st) str)
410 setGHCiState st{cmstate=new_cmstate}
412 changeDirectory :: String -> GHCi ()
413 changeDirectory ('~':d) = do
414 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
415 io (setCurrentDirectory (tilde ++ '/':d))
416 changeDirectory d = io (setCurrentDirectory d)
418 defineMacro :: String -> GHCi ()
420 let (macro_name, definition) = break isSpace s
421 cmds <- io (readIORef commands)
423 then throwDyn (CmdLineError "invalid macro name")
425 if (macro_name `elem` map fst cmds)
426 then throwDyn (CmdLineError
427 ("command `" ++ macro_name ++ "' is already defined"))
430 -- give the expression a type signature, so we can be sure we're getting
431 -- something of the right type.
432 let new_expr = '(' : definition ++ ") :: String -> IO String"
434 -- compile the expression
436 dflags <- io getDynFlags
437 (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
438 setGHCiState st{cmstate = new_cmstate}
441 Just hv -> io (writeIORef commands --
442 ((macro_name, keepGoing (runMacro hv)) : cmds))
444 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
446 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
447 stringLoop (lines str)
449 undefineMacro :: String -> GHCi ()
450 undefineMacro macro_name = do
451 cmds <- io (readIORef commands)
452 if (macro_name `elem` map fst builtin_commands)
453 then throwDyn (CmdLineError
454 ("command `" ++ macro_name ++ "' cannot be undefined"))
456 if (macro_name `notElem` map fst cmds)
457 then throwDyn (CmdLineError
458 ("command `" ++ macro_name ++ "' not defined"))
460 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
462 loadModule :: String -> GHCi ()
463 loadModule str = timeIt (loadModule' str)
466 let files = words str
467 state <- getGHCiState
468 dflags <- io getDynFlags
469 cmstate1 <- io (cmUnload (cmstate state) dflags)
470 setGHCiState state{ cmstate = cmstate1, targets = [] }
471 io (revertCAFs) -- always revert CAFs on load.
472 (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 files)
473 setGHCiState state{ cmstate = cmstate2, targets = files }
474 modulesLoadedMsg ok mods
476 reloadModule :: String -> GHCi ()
478 state <- getGHCiState
479 case targets state of
480 [] -> io (putStr "no current target\n")
482 -> do io (revertCAFs) -- always revert CAFs on reload.
483 (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) paths)
484 setGHCiState state{ cmstate=new_cmstate }
485 modulesLoadedMsg ok mods
487 reloadModule _ = noArgs ":reload"
490 modulesLoadedMsg ok mods = do
492 | null mods = text "none."
494 punctuate comma (map text mods)) <> text "."
497 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
499 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
502 typeOfExpr :: String -> GHCi ()
504 = do st <- getGHCiState
505 dflags <- io getDynFlags
506 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
507 setGHCiState st{cmstate = new_cmstate}
510 Just tystr -> io (putStrLn tystr)
512 quit :: String -> GHCi Bool
515 shellEscape :: String -> GHCi Bool
516 shellEscape str = io (system str >> return False)
518 ----------------------------------------------------------------------------
521 -- set options in the interpreter. Syntax is exactly the same as the
522 -- ghc command line, except that certain options aren't available (-C,
525 -- This is pretty fragile: most options won't work as expected. ToDo:
526 -- figure out which ones & disallow them.
528 setOptions :: String -> GHCi ()
530 = do st <- getGHCiState
531 let opts = options st
532 io $ putStrLn (showSDoc (
533 text "options currently set: " <>
536 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
539 = do -- first, deal with the GHCi opts (+s, +t, etc.)
540 let (plus_opts, minus_opts) = partition isPlus (words str)
541 mapM setOpt plus_opts
543 -- now, the GHC flags
544 pkgs_before <- io (readIORef v_Packages)
545 leftovers <- io (processArgs static_flags minus_opts [])
546 pkgs_after <- io (readIORef v_Packages)
548 -- update things if the users wants more packages
549 when (pkgs_before /= pkgs_after) $
550 newPackages (pkgs_after \\ pkgs_before)
552 -- then, dynamic flags
555 leftovers <- processArgs dynamic_flags leftovers []
558 if (not (null leftovers))
559 then throwDyn (CmdLineError ("unrecognised flags: " ++
564 unsetOptions :: String -> GHCi ()
566 = do -- first, deal with the GHCi opts (+s, +t, etc.)
568 (minus_opts, rest1) = partition isMinus opts
569 (plus_opts, rest2) = partition isPlus rest1
571 if (not (null rest2))
572 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
575 mapM unsetOpt plus_opts
577 -- can't do GHC flags for now
578 if (not (null minus_opts))
579 then throwDyn (CmdLineError "can't unset GHC command-line flags")
582 isMinus ('-':s) = True
585 isPlus ('+':s) = True
589 = case strToGHCiOpt str of
590 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
591 Just o -> setOption o
594 = case strToGHCiOpt str of
595 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
596 Just o -> unsetOption o
598 strToGHCiOpt :: String -> (Maybe GHCiOption)
599 strToGHCiOpt "s" = Just ShowTiming
600 strToGHCiOpt "t" = Just ShowType
601 strToGHCiOpt "r" = Just RevertCAFs
602 strToGHCiOpt _ = Nothing
604 optToStr :: GHCiOption -> String
605 optToStr ShowTiming = "s"
606 optToStr ShowType = "t"
607 optToStr RevertCAFs = "r"
609 newPackages new_pkgs = do
610 state <- getGHCiState
611 dflags <- io getDynFlags
612 cmstate1 <- io (cmUnload (cmstate state) dflags)
613 setGHCiState state{ cmstate = cmstate1, targets = [] }
616 pkgs <- getPackageInfo
617 flushPackageCache pkgs
619 new_pkg_info <- getPackageDetails new_pkgs
620 mapM_ (linkPackage False) (reverse new_pkg_info)
622 -----------------------------------------------------------------------------
625 data GHCiState = GHCiState
627 targets :: [FilePath],
629 options :: [GHCiOption]
633 = ShowTiming -- show time/allocs after evaluation
634 | ShowType -- show the type of expressions
635 | RevertCAFs -- revert CAFs after every evaluation
638 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
639 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
641 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
643 startGHCi :: GHCi a -> GHCiState -> IO a
644 startGHCi g state = do ref <- newIORef state; unGHCi g ref
646 instance Monad GHCi where
647 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
648 return a = GHCi $ \s -> return a
650 getGHCiState = GHCi $ \r -> readIORef r
651 setGHCiState s = GHCi $ \r -> writeIORef r s
653 isOptionSet :: GHCiOption -> GHCi Bool
655 = do st <- getGHCiState
656 return (opt `elem` options st)
658 setOption :: GHCiOption -> GHCi ()
660 = do st <- getGHCiState
661 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
663 unsetOption :: GHCiOption -> GHCi ()
665 = do st <- getGHCiState
666 setGHCiState (st{ options = filter (/= opt) (options st) })
669 io m = GHCi { unGHCi = \s -> m >>= return }
671 -----------------------------------------------------------------------------
672 -- recursive exception handlers
674 -- Don't forget to unblock async exceptions in the handler, or if we're
675 -- in an exception loop (eg. let a = error a in a) the ^C exception
676 -- may never be delivered. Thanks to Marcin for pointing out the bug.
678 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
679 ghciHandle h (GHCi m) = GHCi $ \s ->
680 Exception.catch (m s)
681 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
683 ghciUnblock :: GHCi a -> GHCi a
684 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
686 -----------------------------------------------------------------------------
689 -- Left: full path name of a .o file, including trailing .o
690 -- Right: "unadorned" name of a .DLL/.so
691 -- e.g. On unix "qt" denotes "libqt.so"
692 -- On WinDoze "burble" denotes "burble.DLL"
693 -- addDLL is platform-specific and adds the lib/.so/.DLL
694 -- suffixes platform-dependently; we don't do that here.
696 -- For dynamic objects only, try to find the object file in all the
697 -- directories specified in v_Library_Paths before giving up.
700 = Either FilePath String
702 showLS (Left nm) = "(static) " ++ nm
703 showLS (Right nm) = "(dynamic) " ++ nm
705 linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO ()
706 linkPackages cmdline_lib_specs pkgs
707 = do sequence_ [ linkPackage (name p `elem` loaded) p | p <- reverse pkgs ]
708 lib_paths <- readIORef v_Library_paths
709 mapM_ (preloadLib lib_paths) cmdline_lib_specs
710 if (null cmdline_lib_specs)
712 else do putStr "final link ... "
714 if ok then putStrLn "done."
715 else throwDyn (InstallationError "linking extra libraries/objects failed")
717 -- Packages that are already linked into GHCi. For mingw32, we only
718 -- skip gmp and rts, since std and after need to load the msvcrt.dll
719 -- library which std depends on.
721 # ifndef mingw32_TARGET_OS
722 = [ "gmp", "rts", "std", "concurrent", "posix", "text", "util" ]
727 preloadLib :: [String] -> LibrarySpec -> IO ()
728 preloadLib lib_paths lib_spec
729 = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
732 -> do b <- preload_static lib_paths static_ish
733 putStrLn (if b then "done." else "not found")
735 -> -- We add "" to the set of paths to try, so that
736 -- if none of the real paths match, we force addDLL
737 -- to look in the default dynamic-link search paths.
738 do b <- preload_dynamic (lib_paths++[""]) dll_unadorned
739 when (not b) (cantFind lib_paths lib_spec)
742 cantFind :: [String] -> LibrarySpec -> IO ()
744 = do putStr ("failed.\nCan't find " ++ showLS spec
745 ++ " in directories:\n"
746 ++ unlines (map (" "++) paths) )
749 -- not interested in the paths in the static case.
750 preload_static paths name
751 = do b <- doesFileExist name
752 if not b then return False
753 else loadObj name >> return True
755 preload_dynamic [] name
757 preload_dynamic (path:paths) rootname
758 = do maybe_errmsg <- addDLL path rootname
759 if maybe_errmsg /= nullPtr
760 then preload_dynamic paths rootname
764 = (throwDyn . CmdLineError)
765 "user specified .o/.so/.DLL could not be loaded."
768 linkPackage :: Bool -> PackageConfig -> IO ()
769 -- ignore rts and gmp for now (ToDo; better?)
770 linkPackage loaded_in_ghci pkg
771 | name pkg `elem` ["rts", "gmp"]
774 = do putStr ("Loading package " ++ name pkg ++ " ... ")
775 -- For each obj, try obj.o and if that fails, obj.so.
776 -- Complication: all the .so's must be loaded before any of the .o's.
777 let dirs = library_dirs pkg
778 let objs = hs_libraries pkg ++ extra_libraries pkg
779 classifieds <- mapM (locateOneObj dirs) objs
781 -- Don't load the .so libs if this is a package GHCi is already
782 -- linked against, because we'll already have the .so linked in.
783 let (so_libs, obj_libs) = partition isRight classifieds
784 let sos_first | loaded_in_ghci = obj_libs
785 | otherwise = so_libs ++ obj_libs
787 mapM loadClassified sos_first
788 putStr "linking ... "
790 if ok then putStrLn "done."
791 else panic ("can't load package `" ++ name pkg ++ "'")
793 isRight (Right _) = True
794 isRight (Left _) = False
796 loadClassified :: LibrarySpec -> IO ()
797 loadClassified (Left obj_absolute_filename)
798 = do loadObj obj_absolute_filename
799 loadClassified (Right dll_unadorned)
800 = do maybe_errmsg <- addDLL "" dll_unadorned -- doesn't seem right to me
801 if maybe_errmsg == nullPtr
803 else do str <- peekCString maybe_errmsg
804 throwDyn (CmdLineError ("can't load .so/.DLL for: "
805 ++ dll_unadorned ++ " (" ++ str ++ ")" ))
807 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
809 = return (Right obj) -- we assume
810 locateOneObj (d:ds) obj
811 = do let path = d ++ '/':obj ++ ".o"
812 b <- doesFileExist path
813 if b then return (Left path) else locateOneObj ds obj
815 -----------------------------------------------------------------------------
816 -- timing & statistics
818 timeIt :: GHCi a -> GHCi a
820 = do b <- isOptionSet ShowTiming
823 else do allocs1 <- io $ getAllocations
824 time1 <- io $ getCPUTime
826 allocs2 <- io $ getAllocations
827 time2 <- io $ getCPUTime
828 io $ printTimes (allocs2 - allocs1) (time2 - time1)
831 foreign import "getAllocations" getAllocations :: IO Int
833 printTimes :: Int -> Integer -> IO ()
834 printTimes allocs psecs
835 = do let secs = (fromIntegral psecs / (10^12)) :: Float
836 secs_str = showFFloat (Just 2) secs
838 parens (text (secs_str "") <+> text "secs" <> comma <+>
839 int allocs <+> text "bytes")))
841 -----------------------------------------------------------------------------
844 foreign import revertCAFs :: IO () -- make it "safe", just in case