1 -----------------------------------------------------------------------------
2 -- $Id: InteractiveUI.hs,v 1.90 2001/08/16 10:54:22 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(..), 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 )
32 import FieldLabel ( fieldLabelTyCon )
33 import SrcLoc ( isGoodSrcLoc )
34 import Name ( Name, isHomePackageName, nameSrcLoc, NamedThing(..) )
35 import BasicTypes ( defaultFixity )
37 import CmdLineOpts ( DynFlag(..), getDynFlags, saveDynFlags, restoreDynFlags, dopt_unset )
38 import Panic ( GhcException(..) )
41 #ifndef mingw32_TARGET_OS
47 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
61 import PrelGHC ( unsafeCoerce# )
62 import Foreign ( nullPtr )
63 import CString ( peekCString )
65 -----------------------------------------------------------------------------
69 \ / _ \\ /\\ /\\/ __(_)\n\
70 \ / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
71 \/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n\
72 \\\____/\\/ /_/\\____/|_| Type :? for help.\n"
74 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
76 builtin_commands :: [(String, String -> GHCi Bool)]
78 ("add", keepGoing addModule),
79 ("cd", keepGoing changeDirectory),
80 ("def", keepGoing defineMacro),
81 ("help", keepGoing help),
82 ("?", keepGoing help),
83 ("info", keepGoing info),
84 ("load", keepGoing loadModule),
85 ("module", keepGoing setContext),
86 ("reload", keepGoing reloadModule),
87 ("set", keepGoing setOptions),
88 ("type", keepGoing typeOfExpr),
89 ("unset", keepGoing unsetOptions),
90 ("undef", keepGoing undefineMacro),
94 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
95 keepGoing a str = a str >> return False
97 shortHelpText = "use :? for help.\n"
100 \ Commands available from the prompt:\n\
102 \ <stmt> evaluate/run <stmt>\n\
103 \ :add <filename> ... add module(s) to the current target set\n\
104 \ :cd <dir> change directory to <dir>\n\
105 \ :def <cmd> <expr> define a command :<cmd>\n\
106 \ :help, :? display this list of commands\n\
107 \ :info [<name> ...] display information about the given names\n\
108 \ :load <filename> ... load module(s) and their dependents\n\
109 \ :module <mod> set the context for expression evaluation to <mod>\n\
110 \ :reload reload the current module set\n\
111 \ :set <option> ... set options\n\
112 \ :undef <cmd> undefine user-defined command :<cmd>\n\
113 \ :type <expr> show the type of <expr>\n\
114 \ :unset <option> ... unset options\n\
116 \ :!<command> run the shell command <command>\n\
118 \ Options for `:set' and `:unset':\n\
120 \ +r revert top-level expressions after each evaluation\n\
121 \ +s print timing/memory stats after each evaluation\n\
122 \ +t print type after evaluation\n\
123 \ -<flags> most GHC command line flags can also be set here\n\
124 \ (eg. -v2, -fglasgow-exts, etc.)\n\
127 interactiveUI :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
128 interactiveUI cmstate paths cmdline_libs = do
130 hSetBuffering stdout NoBuffering
132 -- link in the available packages
133 pkgs <- getPackageInfo
135 linkPackages cmdline_libs pkgs
137 (cmstate, ok, mods) <-
139 [] -> return (cmstate, True, [])
140 _ -> cmLoadModule cmstate paths
142 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
146 dflags <- getDynFlags
148 (cmstate, maybe_hval)
149 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stderr"
151 Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
152 _ -> panic "interactiveUI:stderr"
154 (cmstate, maybe_hval)
155 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stdout"
157 Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
158 _ -> panic "interactiveUI:stdout"
160 startGHCi runGHCi GHCiState{ targets = paths,
164 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
165 Readline.resetTerminal Nothing
173 read_dot_files <- io (readIORef v_Read_DotGHCi)
175 when (read_dot_files) $ do
178 exists <- io (doesFileExist file)
180 dir_ok <- io (checkPerms ".")
181 file_ok <- io (checkPerms file)
182 when (dir_ok && file_ok) $ do
183 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
186 Right hdl -> fileLoop hdl False
188 when (read_dot_files) $ do
189 -- Read in $HOME/.ghci
190 either_dir <- io (IO.try (getEnv "HOME"))
194 cwd <- io (getCurrentDirectory)
195 when (dir /= cwd) $ do
196 let file = dir ++ "/.ghci"
197 ok <- io (checkPerms file)
199 either_hdl <- io (IO.try (openFile file ReadMode))
202 Right hdl -> fileLoop hdl False
204 -- read commands from stdin
205 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
212 io $ do putStrLn "Leaving GHCi."
215 -- NOTE: We only read .ghci files if they are owned by the current user,
216 -- and aren't world writable. Otherwise, we could be accidentally
217 -- running code planted by a malicious third party.
219 -- Furthermore, We only read ./.ghci if . is owned by the current user
220 -- and isn't writable by anyone else. I think this is sufficient: we
221 -- don't need to check .. and ../.. etc. because "." always refers to
222 -- the same directory while a process is running.
224 checkPerms :: String -> IO Bool
226 handle (\_ -> return False) $ do
227 #ifdef mingw32_TARGET_OS
230 st <- getFileStatus name
232 if fileOwner st /= me then do
233 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
236 let mode = fileMode st
237 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
238 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
240 putStrLn $ "*** WARNING: " ++ name ++
241 " is writable by someone else, IGNORING!"
246 fileLoop :: Handle -> Bool -> GHCi ()
247 fileLoop hdl prompt = do
249 mod <- io (cmGetContext (cmstate st))
250 when prompt (io (putStr (mod ++ "> ")))
251 l <- io (IO.try (hGetLine hdl))
253 Left e | isEOFError e -> return ()
254 | otherwise -> throw e
256 case remove_spaces l of
257 "" -> fileLoop hdl prompt
258 l -> do quit <- runCommand l
259 if quit then return () else fileLoop hdl prompt
261 stringLoop :: [String] -> GHCi ()
262 stringLoop [] = return ()
263 stringLoop (s:ss) = do
265 case remove_spaces s of
267 l -> do quit <- runCommand l
268 if quit then return () else stringLoop ss
270 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
271 readlineLoop :: GHCi ()
274 mod <- io (cmGetContext (cmstate st))
275 l <- io (readline (mod ++ "> "))
279 case remove_spaces l of
284 if quit then return () else readlineLoop
287 -- Top level exception handler, just prints out the exception
289 runCommand :: String -> GHCi Bool
291 ghciHandle ( \exception -> do
293 showException exception
298 showException (DynException dyn) =
299 case fromDynamic dyn of
301 io (putStrLn ("*** Exception: (unknown)"))
302 Just (PhaseFailed phase code) ->
303 io (putStrLn ("Phase " ++ phase ++ " failed (code "
304 ++ show code ++ ")"))
306 io (putStrLn "Interrupted.")
307 Just (CmdLineError s) ->
308 io (putStrLn s) -- omit the location for CmdLineError
310 io (putStrLn (show other_ghc_ex))
311 showException other_exception
312 = io (putStrLn ("*** Exception: " ++ show other_exception))
314 doCommand (':' : command) = specialCommand command
316 = do timeIt (do stuff <- runStmt stmt; finishEvalExpr stuff)
319 -- Returns True if the expr was successfully parsed, renamed and
321 runStmt :: String -> GHCi (Maybe [Name])
323 | null (filter (not.isSpace) stmt)
326 = do st <- getGHCiState
327 dflags <- io getDynFlags
328 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
329 (new_cmstate, names) <- io (cmRunStmt (cmstate st) dflags' stmt)
330 setGHCiState st{cmstate = new_cmstate}
333 -- possibly print the type and revert CAFs after evaluating an expression
334 finishEvalExpr Nothing = return False
335 finishEvalExpr (Just names)
336 = do b <- isOptionSet ShowType
338 when b (mapM_ (showTypeOfName (cmstate st)) names)
340 b <- isOptionSet RevertCAFs
341 io (when b revertCAFs)
345 showTypeOfName :: CmState -> Name -> GHCi ()
346 showTypeOfName cmstate n
347 = do maybe_str <- io (cmTypeOfName cmstate n)
350 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
352 flushEverything :: GHCi ()
354 = io $ do flush_so <- readIORef flush_stdout
356 flush_se <- readIORef flush_stdout
360 specialCommand :: String -> GHCi Bool
361 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
362 specialCommand str = do
363 let (cmd,rest) = break isSpace str
364 cmds <- io (readIORef commands)
365 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
366 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
367 ++ shortHelpText) >> return False)
368 [(_,f)] -> f (dropWhile isSpace rest)
369 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
370 " matches multiple commands (" ++
371 foldr1 (\a b -> a ++ ',':b) (map fst cs)
372 ++ ")") >> return False)
374 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
376 -----------------------------------------------------------------------------
379 help :: String -> GHCi ()
380 help _ = io (putStr helpText)
382 info :: String -> GHCi ()
383 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
386 state <- getGHCiState
387 dflags <- io getDynFlags
389 infoThings cms [] = return cms
390 infoThings cms (name:names) = do
391 (cms, unqual, stuff) <- io (cmInfoThing cms dflags name)
392 io (putStrLn (showSDocForUser unqual (
393 vcat (intersperse (text "") (map showThing stuff))))
397 showThing (ty_thing, fixity)
398 = vcat [ text "-- " <> showTyThing ty_thing,
399 showFixity fixity (getName ty_thing),
400 ppr (ifaceTyCls ty_thing) ]
403 | fix == defaultFixity = empty
404 | otherwise = ppr fix <+> ppr name
406 showTyThing (AClass cl)
407 = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
408 showTyThing (ATyCon ty)
409 = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
410 showTyThing (AnId id)
411 = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
414 | isRecordSelector id =
415 case tyConClass_maybe (fieldLabelTyCon (
416 recordSelectorFieldLabel id)) of
417 Nothing -> text "record selector"
418 Just c -> text "method in class " <> ppr c
419 | isDataConWrapId id = text "data constructor"
420 | otherwise = text "variable"
422 -- also print out the source location for home things
424 | isHomePackageName name && isGoodSrcLoc loc
425 = hsep [ text ", defined at", ppr loc ]
428 where loc = nameSrcLoc name
430 cms <- infoThings (cmstate state) names
431 setGHCiState state{ cmstate = cms }
435 addModule :: String -> GHCi ()
437 let files = words str
438 state <- getGHCiState
439 dflags <- io (getDynFlags)
440 io (revertCAFs) -- always revert CAFs on load/add.
441 let new_targets = files ++ targets state
442 (cmstate1, ok, mods) <- io (cmLoadModule (cmstate state) new_targets)
443 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
444 modulesLoadedMsg ok mods
446 setContext :: String -> GHCi ()
448 = throwDyn (CmdLineError "syntax: `:m <module>'")
449 setContext m | not (isUpper (head m)) || not (all isAlphaNumEx (tail m))
450 = throwDyn (CmdLineError ("strange looking module name: `" ++ m ++ "'"))
452 isAlphaNumEx c = isAlphaNum c || c == '_'
454 = do st <- getGHCiState
455 new_cmstate <- io (cmSetContext (cmstate st) str)
456 setGHCiState st{cmstate=new_cmstate}
458 changeDirectory :: String -> GHCi ()
459 changeDirectory ('~':d) = do
460 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
461 io (setCurrentDirectory (tilde ++ '/':d))
462 changeDirectory d = io (setCurrentDirectory d)
464 defineMacro :: String -> GHCi ()
466 let (macro_name, definition) = break isSpace s
467 cmds <- io (readIORef commands)
469 then throwDyn (CmdLineError "invalid macro name")
471 if (macro_name `elem` map fst cmds)
472 then throwDyn (CmdLineError
473 ("command `" ++ macro_name ++ "' is already defined"))
476 -- give the expression a type signature, so we can be sure we're getting
477 -- something of the right type.
478 let new_expr = '(' : definition ++ ") :: String -> IO String"
480 -- compile the expression
482 dflags <- io getDynFlags
483 (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
484 setGHCiState st{cmstate = new_cmstate}
487 Just hv -> io (writeIORef commands --
488 ((macro_name, keepGoing (runMacro hv)) : cmds))
490 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
492 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
493 stringLoop (lines str)
495 undefineMacro :: String -> GHCi ()
496 undefineMacro macro_name = do
497 cmds <- io (readIORef commands)
498 if (macro_name `elem` map fst builtin_commands)
499 then throwDyn (CmdLineError
500 ("command `" ++ macro_name ++ "' cannot be undefined"))
502 if (macro_name `notElem` map fst cmds)
503 then throwDyn (CmdLineError
504 ("command `" ++ macro_name ++ "' not defined"))
506 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
508 loadModule :: String -> GHCi ()
509 loadModule str = timeIt (loadModule' str)
512 let files = words str
513 state <- getGHCiState
514 dflags <- io getDynFlags
515 cmstate1 <- io (cmUnload (cmstate state) dflags)
516 setGHCiState state{ cmstate = cmstate1, targets = [] }
517 io (revertCAFs) -- always revert CAFs on load.
518 (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 files)
519 setGHCiState state{ cmstate = cmstate2, targets = files }
520 modulesLoadedMsg ok mods
522 reloadModule :: String -> GHCi ()
524 state <- getGHCiState
525 case targets state of
526 [] -> io (putStr "no current target\n")
528 -> do io (revertCAFs) -- always revert CAFs on reload.
529 (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) paths)
530 setGHCiState state{ cmstate=new_cmstate }
531 modulesLoadedMsg ok mods
533 reloadModule _ = noArgs ":reload"
536 modulesLoadedMsg ok mods = do
538 | null mods = text "none."
540 punctuate comma (map text mods)) <> text "."
543 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
545 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
548 typeOfExpr :: String -> GHCi ()
550 = do st <- getGHCiState
551 dflags <- io getDynFlags
552 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
553 setGHCiState st{cmstate = new_cmstate}
556 Just tystr -> io (putStrLn tystr)
558 quit :: String -> GHCi Bool
561 shellEscape :: String -> GHCi Bool
562 shellEscape str = io (system str >> return False)
564 ----------------------------------------------------------------------------
567 -- set options in the interpreter. Syntax is exactly the same as the
568 -- ghc command line, except that certain options aren't available (-C,
571 -- This is pretty fragile: most options won't work as expected. ToDo:
572 -- figure out which ones & disallow them.
574 setOptions :: String -> GHCi ()
576 = do st <- getGHCiState
577 let opts = options st
578 io $ putStrLn (showSDoc (
579 text "options currently set: " <>
582 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
585 = do -- first, deal with the GHCi opts (+s, +t, etc.)
586 let (plus_opts, minus_opts) = partition isPlus (words str)
587 mapM setOpt plus_opts
589 -- now, the GHC flags
590 pkgs_before <- io (readIORef v_Packages)
591 leftovers <- io (processArgs static_flags minus_opts [])
592 pkgs_after <- io (readIORef v_Packages)
594 -- update things if the users wants more packages
595 when (pkgs_before /= pkgs_after) $
596 newPackages (pkgs_after \\ pkgs_before)
598 -- then, dynamic flags
601 leftovers <- processArgs dynamic_flags leftovers []
604 if (not (null leftovers))
605 then throwDyn (CmdLineError ("unrecognised flags: " ++
610 unsetOptions :: String -> GHCi ()
612 = do -- first, deal with the GHCi opts (+s, +t, etc.)
614 (minus_opts, rest1) = partition isMinus opts
615 (plus_opts, rest2) = partition isPlus rest1
617 if (not (null rest2))
618 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
621 mapM unsetOpt plus_opts
623 -- can't do GHC flags for now
624 if (not (null minus_opts))
625 then throwDyn (CmdLineError "can't unset GHC command-line flags")
628 isMinus ('-':s) = True
631 isPlus ('+':s) = True
635 = case strToGHCiOpt str of
636 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
637 Just o -> setOption o
640 = case strToGHCiOpt str of
641 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
642 Just o -> unsetOption o
644 strToGHCiOpt :: String -> (Maybe GHCiOption)
645 strToGHCiOpt "s" = Just ShowTiming
646 strToGHCiOpt "t" = Just ShowType
647 strToGHCiOpt "r" = Just RevertCAFs
648 strToGHCiOpt _ = Nothing
650 optToStr :: GHCiOption -> String
651 optToStr ShowTiming = "s"
652 optToStr ShowType = "t"
653 optToStr RevertCAFs = "r"
655 newPackages new_pkgs = do
656 state <- getGHCiState
657 dflags <- io getDynFlags
658 cmstate1 <- io (cmUnload (cmstate state) dflags)
659 setGHCiState state{ cmstate = cmstate1, targets = [] }
662 pkgs <- getPackageInfo
663 flushPackageCache pkgs
665 new_pkg_info <- getPackageDetails new_pkgs
666 mapM_ (linkPackage False) (reverse new_pkg_info)
668 -----------------------------------------------------------------------------
671 data GHCiState = GHCiState
673 targets :: [FilePath],
675 options :: [GHCiOption]
679 = ShowTiming -- show time/allocs after evaluation
680 | ShowType -- show the type of expressions
681 | RevertCAFs -- revert CAFs after every evaluation
684 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
685 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
687 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
689 startGHCi :: GHCi a -> GHCiState -> IO a
690 startGHCi g state = do ref <- newIORef state; unGHCi g ref
692 instance Monad GHCi where
693 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
694 return a = GHCi $ \s -> return a
696 getGHCiState = GHCi $ \r -> readIORef r
697 setGHCiState s = GHCi $ \r -> writeIORef r s
699 isOptionSet :: GHCiOption -> GHCi Bool
701 = do st <- getGHCiState
702 return (opt `elem` options st)
704 setOption :: GHCiOption -> GHCi ()
706 = do st <- getGHCiState
707 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
709 unsetOption :: GHCiOption -> GHCi ()
711 = do st <- getGHCiState
712 setGHCiState (st{ options = filter (/= opt) (options st) })
715 io m = GHCi { unGHCi = \s -> m >>= return }
717 -----------------------------------------------------------------------------
718 -- recursive exception handlers
720 -- Don't forget to unblock async exceptions in the handler, or if we're
721 -- in an exception loop (eg. let a = error a in a) the ^C exception
722 -- may never be delivered. Thanks to Marcin for pointing out the bug.
724 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
725 ghciHandle h (GHCi m) = GHCi $ \s ->
726 Exception.catch (m s)
727 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
729 ghciUnblock :: GHCi a -> GHCi a
730 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
732 -----------------------------------------------------------------------------
735 -- Left: full path name of a .o file, including trailing .o
736 -- Right: "unadorned" name of a .DLL/.so
737 -- e.g. On unix "qt" denotes "libqt.so"
738 -- On WinDoze "burble" denotes "burble.DLL"
739 -- addDLL is platform-specific and adds the lib/.so/.DLL
740 -- suffixes platform-dependently; we don't do that here.
742 -- For dynamic objects only, try to find the object file in all the
743 -- directories specified in v_Library_Paths before giving up.
746 = Either FilePath String
748 showLS (Left nm) = "(static) " ++ nm
749 showLS (Right nm) = "(dynamic) " ++ nm
751 linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO ()
752 linkPackages cmdline_lib_specs pkgs
753 = do sequence_ [ linkPackage (name p `elem` loaded) p | p <- reverse pkgs ]
754 lib_paths <- readIORef v_Library_paths
755 mapM_ (preloadLib lib_paths) cmdline_lib_specs
756 if (null cmdline_lib_specs)
758 else do putStr "final link ... "
760 if ok then putStrLn "done."
761 else throwDyn (InstallationError "linking extra libraries/objects failed")
763 -- Packages that are already linked into GHCi. For mingw32, we only
764 -- skip gmp and rts, since std and after need to load the msvcrt.dll
765 -- library which std depends on.
767 # ifndef mingw32_TARGET_OS
768 = [ "gmp", "rts", "std", "concurrent", "posix", "text", "util" ]
773 preloadLib :: [String] -> LibrarySpec -> IO ()
774 preloadLib lib_paths lib_spec
775 = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
778 -> do b <- preload_static lib_paths static_ish
779 putStrLn (if b then "done." else "not found")
781 -> -- We add "" to the set of paths to try, so that
782 -- if none of the real paths match, we force addDLL
783 -- to look in the default dynamic-link search paths.
784 do b <- preload_dynamic (lib_paths++[""]) dll_unadorned
785 when (not b) (cantFind lib_paths lib_spec)
788 cantFind :: [String] -> LibrarySpec -> IO ()
790 = do putStr ("failed.\nCan't find " ++ showLS spec
791 ++ " in directories:\n"
792 ++ unlines (map (" "++) paths) )
795 -- not interested in the paths in the static case.
796 preload_static paths name
797 = do b <- doesFileExist name
798 if not b then return False
799 else loadObj name >> return True
801 preload_dynamic [] name
803 preload_dynamic (path:paths) rootname
804 = do maybe_errmsg <- addDLL path rootname
805 if maybe_errmsg /= nullPtr
806 then preload_dynamic paths rootname
810 = (throwDyn . CmdLineError)
811 "user specified .o/.so/.DLL could not be loaded."
814 linkPackage :: Bool -> PackageConfig -> IO ()
815 -- ignore rts and gmp for now (ToDo; better?)
816 linkPackage loaded_in_ghci pkg
817 | name pkg `elem` ["rts", "gmp"]
820 = do putStr ("Loading package " ++ name pkg ++ " ... ")
821 -- For each obj, try obj.o and if that fails, obj.so.
822 -- Complication: all the .so's must be loaded before any of the .o's.
823 let dirs = library_dirs pkg
824 let objs = hs_libraries pkg ++ extra_libraries pkg
825 classifieds <- mapM (locateOneObj dirs) objs
827 -- Don't load the .so libs if this is a package GHCi is already
828 -- linked against, because we'll already have the .so linked in.
829 let (so_libs, obj_libs) = partition isRight classifieds
830 let sos_first | loaded_in_ghci = obj_libs
831 | otherwise = so_libs ++ obj_libs
833 mapM loadClassified sos_first
834 putStr "linking ... "
836 if ok then putStrLn "done."
837 else panic ("can't load package `" ++ name pkg ++ "'")
839 isRight (Right _) = True
840 isRight (Left _) = False
842 loadClassified :: LibrarySpec -> IO ()
843 loadClassified (Left obj_absolute_filename)
844 = do loadObj obj_absolute_filename
845 loadClassified (Right dll_unadorned)
846 = do maybe_errmsg <- addDLL "" dll_unadorned -- doesn't seem right to me
847 if maybe_errmsg == nullPtr
849 else do str <- peekCString maybe_errmsg
850 throwDyn (CmdLineError ("can't load .so/.DLL for: "
851 ++ dll_unadorned ++ " (" ++ str ++ ")" ))
853 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
855 = return (Right obj) -- we assume
856 locateOneObj (d:ds) obj
857 = do let path = d ++ '/':obj ++ ".o"
858 b <- doesFileExist path
859 if b then return (Left path) else locateOneObj ds obj
861 -----------------------------------------------------------------------------
862 -- timing & statistics
864 timeIt :: GHCi a -> GHCi a
866 = do b <- isOptionSet ShowTiming
869 else do allocs1 <- io $ getAllocations
870 time1 <- io $ getCPUTime
872 allocs2 <- io $ getAllocations
873 time2 <- io $ getCPUTime
874 io $ printTimes (allocs2 - allocs1) (time2 - time1)
877 foreign import "getAllocations" getAllocations :: IO Int
879 printTimes :: Int -> Integer -> IO ()
880 printTimes allocs psecs
881 = do let secs = (fromIntegral psecs / (10^12)) :: Float
882 secs_str = showFFloat (Just 2) secs
884 parens (text (secs_str "") <+> text "secs" <> comma <+>
885 int allocs <+> text "bytes")))
887 -----------------------------------------------------------------------------
890 foreign import revertCAFs :: IO () -- make it "safe", just in case