1 -----------------------------------------------------------------------------
2 -- $Id: InteractiveUI.hs,v 1.92 2001/10/15 15:05:17 simonpj 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(..), TyThing(..) )
20 import MkIface ( ifaceTyCls )
26 import Finder ( flushPackageCache )
28 import Id ( isRecordSelector, recordSelectorFieldLabel,
29 isDataConWrapId, idName )
30 import Class ( className )
31 import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon )
32 import FieldLabel ( fieldLabelTyCon )
33 import SrcLoc ( isGoodSrcLoc )
34 import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName,
36 import OccName ( isSymOcc )
37 import BasicTypes ( defaultFixity )
39 import CmdLineOpts ( DynFlag(..), getDynFlags, saveDynFlags, restoreDynFlags, dopt_unset )
40 import Panic ( GhcException(..) )
43 #ifndef mingw32_TARGET_OS
49 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
63 import PrelGHC ( unsafeCoerce# )
64 import Foreign ( nullPtr )
65 import CString ( peekCString )
67 -----------------------------------------------------------------------------
71 \ / _ \\ /\\ /\\/ __(_)\n\
72 \ / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
73 \/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n\
74 \\\____/\\/ /_/\\____/|_| Type :? for help.\n"
76 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
78 builtin_commands :: [(String, String -> GHCi Bool)]
80 ("add", keepGoing addModule),
81 ("cd", keepGoing changeDirectory),
82 ("def", keepGoing defineMacro),
83 ("help", keepGoing help),
84 ("?", keepGoing help),
85 ("info", keepGoing info),
86 ("load", keepGoing loadModule),
87 ("module", keepGoing setContext),
88 ("reload", keepGoing reloadModule),
89 ("set", keepGoing setOptions),
90 ("type", keepGoing typeOfExpr),
91 ("unset", keepGoing unsetOptions),
92 ("undef", keepGoing undefineMacro),
96 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
97 keepGoing a str = a str >> return False
99 shortHelpText = "use :? for help.\n"
102 \ Commands available from the prompt:\n\
104 \ <stmt> evaluate/run <stmt>\n\
105 \ :add <filename> ... add module(s) to the current target set\n\
106 \ :cd <dir> change directory to <dir>\n\
107 \ :def <cmd> <expr> define a command :<cmd>\n\
108 \ :help, :? display this list of commands\n\
109 \ :info [<name> ...] display information about the given names\n\
110 \ :load <filename> ... load module(s) and their dependents\n\
111 \ :module <mod> set the context for expression evaluation to <mod>\n\
112 \ :reload reload the current module set\n\
113 \ :set <option> ... set options\n\
114 \ :undef <cmd> undefine user-defined command :<cmd>\n\
115 \ :type <expr> show the type of <expr>\n\
116 \ :unset <option> ... unset options\n\
118 \ :!<command> run the shell command <command>\n\
120 \ Options for `:set' and `:unset':\n\
122 \ +r revert top-level expressions after each evaluation\n\
123 \ +s print timing/memory stats after each evaluation\n\
124 \ +t print type after evaluation\n\
125 \ -<flags> most GHC command line flags can also be set here\n\
126 \ (eg. -v2, -fglasgow-exts, etc.)\n\
129 interactiveUI :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
130 interactiveUI cmstate paths cmdline_libs = do
132 hSetBuffering stdout NoBuffering
134 -- link in the available packages
135 pkgs <- getPackageInfo
137 linkPackages cmdline_libs pkgs
139 (cmstate, ok, mods) <-
141 [] -> return (cmstate, True, [])
142 _ -> cmLoadModule cmstate paths
144 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
148 dflags <- getDynFlags
150 (cmstate, maybe_hval)
151 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stderr"
153 Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
154 _ -> panic "interactiveUI:stderr"
156 (cmstate, maybe_hval)
157 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stdout"
159 Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
160 _ -> panic "interactiveUI:stdout"
162 startGHCi runGHCi GHCiState{ targets = paths,
166 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
167 Readline.resetTerminal Nothing
175 read_dot_files <- io (readIORef v_Read_DotGHCi)
177 when (read_dot_files) $ do
180 exists <- io (doesFileExist file)
182 dir_ok <- io (checkPerms ".")
183 file_ok <- io (checkPerms file)
184 when (dir_ok && file_ok) $ do
185 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
188 Right hdl -> fileLoop hdl False
190 when (read_dot_files) $ do
191 -- Read in $HOME/.ghci
192 either_dir <- io (IO.try (getEnv "HOME"))
196 cwd <- io (getCurrentDirectory)
197 when (dir /= cwd) $ do
198 let file = dir ++ "/.ghci"
199 ok <- io (checkPerms file)
201 either_hdl <- io (IO.try (openFile file ReadMode))
204 Right hdl -> fileLoop hdl False
206 -- read commands from stdin
207 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
214 io $ do putStrLn "Leaving GHCi."
217 -- NOTE: We only read .ghci files if they are owned by the current user,
218 -- and aren't world writable. Otherwise, we could be accidentally
219 -- running code planted by a malicious third party.
221 -- Furthermore, We only read ./.ghci if . is owned by the current user
222 -- and isn't writable by anyone else. I think this is sufficient: we
223 -- don't need to check .. and ../.. etc. because "." always refers to
224 -- the same directory while a process is running.
226 checkPerms :: String -> IO Bool
228 handle (\_ -> return False) $ do
229 #ifdef mingw32_TARGET_OS
232 st <- getFileStatus name
234 if fileOwner st /= me then do
235 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
238 let mode = fileMode st
239 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
240 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
242 putStrLn $ "*** WARNING: " ++ name ++
243 " is writable by someone else, IGNORING!"
248 fileLoop :: Handle -> Bool -> GHCi ()
249 fileLoop hdl prompt = do
251 mod <- io (cmGetContext (cmstate st))
252 when prompt (io (putStr (mod ++ "> ")))
253 l <- io (IO.try (hGetLine hdl))
255 Left e | isEOFError e -> return ()
256 | otherwise -> throw e
258 case remove_spaces l of
259 "" -> fileLoop hdl prompt
260 l -> do quit <- runCommand l
261 if quit then return () else fileLoop hdl prompt
263 stringLoop :: [String] -> GHCi ()
264 stringLoop [] = return ()
265 stringLoop (s:ss) = do
267 case remove_spaces s of
269 l -> do quit <- runCommand l
270 if quit then return () else stringLoop ss
272 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
273 readlineLoop :: GHCi ()
276 mod <- io (cmGetContext (cmstate st))
277 l <- io (readline (mod ++ "> "))
281 case remove_spaces l of
286 if quit then return () else readlineLoop
289 -- Top level exception handler, just prints out the exception
291 runCommand :: String -> GHCi Bool
293 ghciHandle ( \exception -> do
295 showException exception
300 showException (DynException dyn) =
301 case fromDynamic dyn of
303 io (putStrLn ("*** Exception: (unknown)"))
304 Just (PhaseFailed phase code) ->
305 io (putStrLn ("Phase " ++ phase ++ " failed (code "
306 ++ show code ++ ")"))
308 io (putStrLn "Interrupted.")
309 Just (CmdLineError s) ->
310 io (putStrLn s) -- omit the location for CmdLineError
312 io (putStrLn (show other_ghc_ex))
313 showException other_exception
314 = io (putStrLn ("*** Exception: " ++ show other_exception))
316 doCommand (':' : command) = specialCommand command
318 = do timeIt (do stuff <- runStmt stmt; finishEvalExpr stuff)
321 -- Returns True if the expr was successfully parsed, renamed and
323 runStmt :: String -> GHCi (Maybe [Name])
325 | null (filter (not.isSpace) stmt)
328 = do st <- getGHCiState
329 dflags <- io getDynFlags
330 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
331 (new_cmstate, names) <- io (cmRunStmt (cmstate st) dflags' stmt)
332 setGHCiState st{cmstate = new_cmstate}
335 -- possibly print the type and revert CAFs after evaluating an expression
336 finishEvalExpr Nothing = return False
337 finishEvalExpr (Just names)
338 = do b <- isOptionSet ShowType
340 when b (mapM_ (showTypeOfName (cmstate st)) names)
342 b <- isOptionSet RevertCAFs
343 io (when b revertCAFs)
347 showTypeOfName :: CmState -> Name -> GHCi ()
348 showTypeOfName cmstate n
349 = do maybe_str <- io (cmTypeOfName cmstate n)
352 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
354 flushEverything :: GHCi ()
356 = io $ do flush_so <- readIORef flush_stdout
358 flush_se <- readIORef flush_stdout
362 specialCommand :: String -> GHCi Bool
363 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
364 specialCommand str = do
365 let (cmd,rest) = break isSpace str
366 cmds <- io (readIORef commands)
367 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
368 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
369 ++ shortHelpText) >> return False)
370 [(_,f)] -> f (dropWhile isSpace rest)
371 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
372 " matches multiple commands (" ++
373 foldr1 (\a b -> a ++ ',':b) (map fst cs)
374 ++ ")") >> return False)
376 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
378 -----------------------------------------------------------------------------
381 help :: String -> GHCi ()
382 help _ = io (putStr helpText)
384 info :: String -> GHCi ()
385 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
388 state <- getGHCiState
389 dflags <- io getDynFlags
391 infoThings cms [] = return cms
392 infoThings cms (name:names) = do
393 (cms, unqual, stuff) <- io (cmInfoThing cms dflags name)
394 io (putStrLn (showSDocForUser unqual (
395 vcat (intersperse (text "") (map showThing stuff))))
399 showThing (ty_thing, fixity)
400 = vcat [ text "-- " <> showTyThing ty_thing,
401 showFixity fixity (getName ty_thing),
402 ppr (ifaceTyThing ty_thing) ]
405 | fix == defaultFixity = empty
406 | otherwise = ppr fix <+>
407 (if isSymOcc (nameOccName name)
409 else char '`' <> ppr name <> char '`')
411 showTyThing (AClass cl)
412 = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
413 showTyThing (ATyCon ty)
415 = hcat [ppr ty, text " is a primitive type constructor"]
417 = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
418 showTyThing (AnId id)
419 = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
422 | isRecordSelector id =
423 case tyConClass_maybe (fieldLabelTyCon (
424 recordSelectorFieldLabel id)) of
425 Nothing -> text "record selector"
426 Just c -> text "method in class " <> ppr c
427 | isDataConWrapId id = text "data constructor"
428 | otherwise = text "variable"
430 -- also print out the source location for home things
432 | isHomePackageName name && isGoodSrcLoc loc
433 = hsep [ text ", defined at", ppr loc ]
436 where loc = nameSrcLoc name
438 cms <- infoThings (cmstate state) names
439 setGHCiState state{ cmstate = cms }
443 addModule :: String -> GHCi ()
445 let files = words str
446 state <- getGHCiState
447 dflags <- io (getDynFlags)
448 io (revertCAFs) -- always revert CAFs on load/add.
449 let new_targets = files ++ targets state
450 (cmstate1, ok, mods) <- io (cmLoadModule (cmstate state) new_targets)
451 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
452 modulesLoadedMsg ok mods
454 setContext :: String -> GHCi ()
456 = throwDyn (CmdLineError "syntax: `:m <module>'")
457 setContext m | not (isUpper (head m)) || not (all isAlphaNumEx (tail m))
458 = throwDyn (CmdLineError ("strange looking module name: `" ++ m ++ "'"))
460 isAlphaNumEx c = isAlphaNum c || c == '_'
462 = do st <- getGHCiState
463 new_cmstate <- io (cmSetContext (cmstate st) str)
464 setGHCiState st{cmstate=new_cmstate}
466 changeDirectory :: String -> GHCi ()
467 changeDirectory ('~':d) = do
468 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
469 io (setCurrentDirectory (tilde ++ '/':d))
470 changeDirectory d = io (setCurrentDirectory d)
472 defineMacro :: String -> GHCi ()
474 let (macro_name, definition) = break isSpace s
475 cmds <- io (readIORef commands)
477 then throwDyn (CmdLineError "invalid macro name")
479 if (macro_name `elem` map fst cmds)
480 then throwDyn (CmdLineError
481 ("command `" ++ macro_name ++ "' is already defined"))
484 -- give the expression a type signature, so we can be sure we're getting
485 -- something of the right type.
486 let new_expr = '(' : definition ++ ") :: String -> IO String"
488 -- compile the expression
490 dflags <- io getDynFlags
491 (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
492 setGHCiState st{cmstate = new_cmstate}
495 Just hv -> io (writeIORef commands --
496 ((macro_name, keepGoing (runMacro hv)) : cmds))
498 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
500 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
501 stringLoop (lines str)
503 undefineMacro :: String -> GHCi ()
504 undefineMacro macro_name = do
505 cmds <- io (readIORef commands)
506 if (macro_name `elem` map fst builtin_commands)
507 then throwDyn (CmdLineError
508 ("command `" ++ macro_name ++ "' cannot be undefined"))
510 if (macro_name `notElem` map fst cmds)
511 then throwDyn (CmdLineError
512 ("command `" ++ macro_name ++ "' not defined"))
514 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
516 loadModule :: String -> GHCi ()
517 loadModule str = timeIt (loadModule' str)
520 let files = words str
521 state <- getGHCiState
522 dflags <- io getDynFlags
523 cmstate1 <- io (cmUnload (cmstate state) dflags)
524 setGHCiState state{ cmstate = cmstate1, targets = [] }
525 io (revertCAFs) -- always revert CAFs on load.
526 (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 files)
527 setGHCiState state{ cmstate = cmstate2, targets = files }
528 modulesLoadedMsg ok mods
530 reloadModule :: String -> GHCi ()
532 state <- getGHCiState
533 case targets state of
534 [] -> io (putStr "no current target\n")
536 -> do io (revertCAFs) -- always revert CAFs on reload.
537 (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) paths)
538 setGHCiState state{ cmstate=new_cmstate }
539 modulesLoadedMsg ok mods
541 reloadModule _ = noArgs ":reload"
544 modulesLoadedMsg ok mods = do
546 | null mods = text "none."
548 punctuate comma (map text mods)) <> text "."
551 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
553 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
556 typeOfExpr :: String -> GHCi ()
558 = do st <- getGHCiState
559 dflags <- io getDynFlags
560 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
561 setGHCiState st{cmstate = new_cmstate}
564 Just tystr -> io (putStrLn tystr)
566 quit :: String -> GHCi Bool
569 shellEscape :: String -> GHCi Bool
570 shellEscape str = io (system str >> return False)
572 ----------------------------------------------------------------------------
575 -- set options in the interpreter. Syntax is exactly the same as the
576 -- ghc command line, except that certain options aren't available (-C,
579 -- This is pretty fragile: most options won't work as expected. ToDo:
580 -- figure out which ones & disallow them.
582 setOptions :: String -> GHCi ()
584 = do st <- getGHCiState
585 let opts = options st
586 io $ putStrLn (showSDoc (
587 text "options currently set: " <>
590 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
593 = do -- first, deal with the GHCi opts (+s, +t, etc.)
594 let (plus_opts, minus_opts) = partition isPlus (words str)
595 mapM setOpt plus_opts
597 -- now, the GHC flags
598 pkgs_before <- io (readIORef v_Packages)
599 leftovers <- io (processArgs static_flags minus_opts [])
600 pkgs_after <- io (readIORef v_Packages)
602 -- update things if the users wants more packages
603 when (pkgs_before /= pkgs_after) $
604 newPackages (pkgs_after \\ pkgs_before)
606 -- then, dynamic flags
609 leftovers <- processArgs dynamic_flags leftovers []
612 if (not (null leftovers))
613 then throwDyn (CmdLineError ("unrecognised flags: " ++
618 unsetOptions :: String -> GHCi ()
620 = do -- first, deal with the GHCi opts (+s, +t, etc.)
622 (minus_opts, rest1) = partition isMinus opts
623 (plus_opts, rest2) = partition isPlus rest1
625 if (not (null rest2))
626 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
629 mapM unsetOpt plus_opts
631 -- can't do GHC flags for now
632 if (not (null minus_opts))
633 then throwDyn (CmdLineError "can't unset GHC command-line flags")
636 isMinus ('-':s) = True
639 isPlus ('+':s) = True
643 = case strToGHCiOpt str of
644 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
645 Just o -> setOption o
648 = case strToGHCiOpt str of
649 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
650 Just o -> unsetOption o
652 strToGHCiOpt :: String -> (Maybe GHCiOption)
653 strToGHCiOpt "s" = Just ShowTiming
654 strToGHCiOpt "t" = Just ShowType
655 strToGHCiOpt "r" = Just RevertCAFs
656 strToGHCiOpt _ = Nothing
658 optToStr :: GHCiOption -> String
659 optToStr ShowTiming = "s"
660 optToStr ShowType = "t"
661 optToStr RevertCAFs = "r"
663 newPackages new_pkgs = do
664 state <- getGHCiState
665 dflags <- io getDynFlags
666 cmstate1 <- io (cmUnload (cmstate state) dflags)
667 setGHCiState state{ cmstate = cmstate1, targets = [] }
670 pkgs <- getPackageInfo
671 flushPackageCache pkgs
673 new_pkg_info <- getPackageDetails new_pkgs
674 mapM_ (linkPackage False) (reverse new_pkg_info)
676 -----------------------------------------------------------------------------
679 data GHCiState = GHCiState
681 targets :: [FilePath],
683 options :: [GHCiOption]
687 = ShowTiming -- show time/allocs after evaluation
688 | ShowType -- show the type of expressions
689 | RevertCAFs -- revert CAFs after every evaluation
692 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
693 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
695 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
697 startGHCi :: GHCi a -> GHCiState -> IO a
698 startGHCi g state = do ref <- newIORef state; unGHCi g ref
700 instance Monad GHCi where
701 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
702 return a = GHCi $ \s -> return a
704 getGHCiState = GHCi $ \r -> readIORef r
705 setGHCiState s = GHCi $ \r -> writeIORef r s
707 isOptionSet :: GHCiOption -> GHCi Bool
709 = do st <- getGHCiState
710 return (opt `elem` options st)
712 setOption :: GHCiOption -> GHCi ()
714 = do st <- getGHCiState
715 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
717 unsetOption :: GHCiOption -> GHCi ()
719 = do st <- getGHCiState
720 setGHCiState (st{ options = filter (/= opt) (options st) })
723 io m = GHCi { unGHCi = \s -> m >>= return }
725 -----------------------------------------------------------------------------
726 -- recursive exception handlers
728 -- Don't forget to unblock async exceptions in the handler, or if we're
729 -- in an exception loop (eg. let a = error a in a) the ^C exception
730 -- may never be delivered. Thanks to Marcin for pointing out the bug.
732 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
733 ghciHandle h (GHCi m) = GHCi $ \s ->
734 Exception.catch (m s)
735 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
737 ghciUnblock :: GHCi a -> GHCi a
738 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
740 -----------------------------------------------------------------------------
743 -- Left: full path name of a .o file, including trailing .o
744 -- Right: "unadorned" name of a .DLL/.so
745 -- e.g. On unix "qt" denotes "libqt.so"
746 -- On WinDoze "burble" denotes "burble.DLL"
747 -- addDLL is platform-specific and adds the lib/.so/.DLL
748 -- suffixes platform-dependently; we don't do that here.
750 -- For dynamic objects only, try to find the object file in all the
751 -- directories specified in v_Library_Paths before giving up.
754 = Either FilePath String
756 showLS (Left nm) = "(static) " ++ nm
757 showLS (Right nm) = "(dynamic) " ++ nm
759 linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO ()
760 linkPackages cmdline_lib_specs pkgs
761 = do sequence_ [ linkPackage (name p `elem` loaded) p | p <- reverse pkgs ]
762 lib_paths <- readIORef v_Library_paths
763 mapM_ (preloadLib lib_paths) cmdline_lib_specs
764 if (null cmdline_lib_specs)
766 else do putStr "final link ... "
768 if ok then putStrLn "done."
769 else throwDyn (InstallationError "linking extra libraries/objects failed")
771 -- Packages that are already linked into GHCi. For mingw32, we only
772 -- skip gmp and rts, since std and after need to load the msvcrt.dll
773 -- library which std depends on.
775 # ifndef mingw32_TARGET_OS
776 = [ "gmp", "rts", "std", "concurrent", "posix", "text", "util" ]
781 preloadLib :: [String] -> LibrarySpec -> IO ()
782 preloadLib lib_paths lib_spec
783 = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
786 -> do b <- preload_static lib_paths static_ish
787 putStrLn (if b then "done." else "not found")
789 -> -- We add "" to the set of paths to try, so that
790 -- if none of the real paths match, we force addDLL
791 -- to look in the default dynamic-link search paths.
792 do b <- preload_dynamic (lib_paths++[""]) dll_unadorned
793 when (not b) (cantFind lib_paths lib_spec)
796 cantFind :: [String] -> LibrarySpec -> IO ()
798 = do putStr ("failed.\nCan't find " ++ showLS spec
799 ++ " in directories:\n"
800 ++ unlines (map (" "++) paths) )
803 -- not interested in the paths in the static case.
804 preload_static paths name
805 = do b <- doesFileExist name
806 if not b then return False
807 else loadObj name >> return True
809 preload_dynamic [] name
811 preload_dynamic (path:paths) rootname
812 = do maybe_errmsg <- addDLL path rootname
813 if maybe_errmsg /= nullPtr
814 then preload_dynamic paths rootname
818 = (throwDyn . CmdLineError)
819 "user specified .o/.so/.DLL could not be loaded."
822 linkPackage :: Bool -> PackageConfig -> IO ()
823 -- ignore rts and gmp for now (ToDo; better?)
824 linkPackage loaded_in_ghci pkg
825 | name pkg `elem` ["rts", "gmp"]
828 = do putStr ("Loading package " ++ name pkg ++ " ... ")
829 -- For each obj, try obj.o and if that fails, obj.so.
830 -- Complication: all the .so's must be loaded before any of the .o's.
831 let dirs = library_dirs pkg
832 let objs = hs_libraries pkg ++ extra_libraries pkg
833 classifieds <- mapM (locateOneObj dirs) objs
835 -- Don't load the .so libs if this is a package GHCi is already
836 -- linked against, because we'll already have the .so linked in.
837 let (so_libs, obj_libs) = partition isRight classifieds
838 let sos_first | loaded_in_ghci = obj_libs
839 | otherwise = so_libs ++ obj_libs
841 mapM loadClassified sos_first
842 putStr "linking ... "
844 if ok then putStrLn "done."
845 else panic ("can't load package `" ++ name pkg ++ "'")
847 isRight (Right _) = True
848 isRight (Left _) = False
850 loadClassified :: LibrarySpec -> IO ()
851 loadClassified (Left obj_absolute_filename)
852 = do loadObj obj_absolute_filename
853 loadClassified (Right dll_unadorned)
854 = do maybe_errmsg <- addDLL "" dll_unadorned -- doesn't seem right to me
855 if maybe_errmsg == nullPtr
857 else do str <- peekCString maybe_errmsg
858 throwDyn (CmdLineError ("can't load .so/.DLL for: "
859 ++ dll_unadorned ++ " (" ++ str ++ ")" ))
861 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
863 = return (Right obj) -- we assume
864 locateOneObj (d:ds) obj
865 = do let path = d ++ '/':obj ++ ".o"
866 b <- doesFileExist path
867 if b then return (Left path) else locateOneObj ds obj
869 -----------------------------------------------------------------------------
870 -- timing & statistics
872 timeIt :: GHCi a -> GHCi a
874 = do b <- isOptionSet ShowTiming
877 else do allocs1 <- io $ getAllocations
878 time1 <- io $ getCPUTime
880 allocs2 <- io $ getAllocations
881 time2 <- io $ getCPUTime
882 io $ printTimes (allocs2 - allocs1) (time2 - time1)
885 foreign import "getAllocations" getAllocations :: IO Int
887 printTimes :: Int -> Integer -> IO ()
888 printTimes allocs psecs
889 = do let secs = (fromIntegral psecs / (10^12)) :: Float
890 secs_str = showFFloat (Just 2) secs
892 parens (text (secs_str "") <+> text "secs" <> comma <+>
893 int allocs <+> text "bytes")))
895 -----------------------------------------------------------------------------
898 foreign import revertCAFs :: IO () -- make it "safe", just in case