1 {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.104 2002/01/03 17:05:50 sewardj Exp $
5 -- GHC Interactive User Interface
7 -- (c) The GHC Team 2000
9 -----------------------------------------------------------------------------
10 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
12 #include "../includes/config.h"
13 #include "HsVersions.h"
17 import HscTypes ( TyThing(..) )
24 import Finder ( flushPackageCache )
26 import Id ( isRecordSelector, recordSelectorFieldLabel,
27 isDataConWrapId, idName )
28 import Class ( className )
29 import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon )
30 import FieldLabel ( fieldLabelTyCon )
31 import SrcLoc ( isGoodSrcLoc )
32 import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName,
34 import OccName ( isSymOcc )
35 import BasicTypes ( defaultFixity )
37 import CmdLineOpts ( DynFlag(..), getDynFlags, saveDynFlags, restoreDynFlags, dopt_unset )
38 import Panic ( GhcException(..), showGhcException )
41 #ifndef mingw32_TARGET_OS
47 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
61 import Monad ( when, join )
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 setCmd),
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 \ :set args <arg> ... set the arguments returned by System.getArgs\n\
115 \ :set prog <progname> set the value returned by System.getProgName\n\
116 \ :undef <cmd> undefine user-defined command :<cmd>\n\
117 \ :type <expr> show the type of <expr>\n\
118 \ :unset <option> ... unset options\n\
120 \ :!<command> run the shell command <command>\n\
122 \ Options for `:set' and `:unset':\n\
124 \ +r revert top-level expressions after each evaluation\n\
125 \ +s print timing/memory stats after each evaluation\n\
126 \ +t print type after evaluation\n\
127 \ -<flags> most GHC command line flags can also be set here\n\
128 \ (eg. -v2, -fglasgow-exts, etc.)\n\
131 interactiveUI :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
132 interactiveUI cmstate paths cmdline_libs = do
134 hSetBuffering stdout NoBuffering
136 -- link in the available packages
137 pkgs <- getPackageInfo
139 linkPackages cmdline_libs pkgs
141 dflags <- getDynFlags
143 (cmstate, maybe_hval)
144 <- cmCompileExpr cmstate dflags "IO.hSetBuffering IO.stdout IO.NoBuffering Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
146 Just hval -> unsafeCoerce# hval :: IO ()
147 _ -> panic "interactiveUI:buffering"
149 (cmstate, maybe_hval)
150 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stderr"
152 Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
153 _ -> panic "interactiveUI:stderr"
155 (cmstate, maybe_hval)
156 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stdout"
158 Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
159 _ -> panic "interactiveUI:stdout"
161 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
165 startGHCi (runGHCi paths)
166 GHCiState{ progname = "<interactive>",
172 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
173 Readline.resetTerminal Nothing
179 runGHCi :: [FilePath] -> GHCi ()
181 read_dot_files <- io (readIORef v_Read_DotGHCi)
183 when (read_dot_files) $ do
186 exists <- io (doesFileExist file)
188 dir_ok <- io (checkPerms ".")
189 file_ok <- io (checkPerms file)
190 when (dir_ok && file_ok) $ do
191 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
194 Right hdl -> fileLoop hdl False
196 when (read_dot_files) $ do
197 -- Read in $HOME/.ghci
198 either_dir <- io (IO.try (getEnv "HOME"))
202 cwd <- io (getCurrentDirectory)
203 when (dir /= cwd) $ do
204 let file = dir ++ "/.ghci"
205 ok <- io (checkPerms file)
207 either_hdl <- io (IO.try (openFile file ReadMode))
210 Right hdl -> fileLoop hdl False
212 -- perform a :load for files given on the GHCi command line
213 when (not (null paths)) $
214 ghciHandle showException $
215 loadModule (unwords paths)
217 -- enter the interactive loop
221 io $ do putStrLn "Leaving GHCi."
225 -- ignore ^C exceptions caught here
226 ghciHandleDyn (\e -> case e of Interrupted -> ghciUnblock interactiveLoop
227 _other -> return ()) $ do
229 -- read commands from stdin
230 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
237 -- NOTE: We only read .ghci files if they are owned by the current user,
238 -- and aren't world writable. Otherwise, we could be accidentally
239 -- running code planted by a malicious third party.
241 -- Furthermore, We only read ./.ghci if . is owned by the current user
242 -- and isn't writable by anyone else. I think this is sufficient: we
243 -- don't need to check .. and ../.. etc. because "." always refers to
244 -- the same directory while a process is running.
246 checkPerms :: String -> IO Bool
248 handle (\_ -> return False) $ do
249 #ifdef mingw32_TARGET_OS
252 st <- getFileStatus name
254 if fileOwner st /= me then do
255 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
258 let mode = fileMode st
259 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
260 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
262 putStrLn $ "*** WARNING: " ++ name ++
263 " is writable by someone else, IGNORING!"
268 fileLoop :: Handle -> Bool -> GHCi ()
269 fileLoop hdl prompt = do
271 mod <- io (cmGetContext (cmstate st))
272 when prompt (io (putStr (mod ++ "> ")))
273 l <- io (IO.try (hGetLine hdl))
275 Left e | isEOFError e -> return ()
276 | otherwise -> throw e
278 case remove_spaces l of
279 "" -> fileLoop hdl prompt
280 l -> do quit <- runCommand l
281 if quit then return () else fileLoop hdl prompt
283 stringLoop :: [String] -> GHCi ()
284 stringLoop [] = return ()
285 stringLoop (s:ss) = do
287 case remove_spaces s of
289 l -> do quit <- runCommand l
290 if quit then return () else stringLoop ss
292 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
293 readlineLoop :: GHCi ()
296 mod <- io (cmGetContext (cmstate st))
298 l <- io (readline (mod ++ "> "))
302 case remove_spaces l of
307 if quit then return () else readlineLoop
310 -- Top level exception handler, just prints out the exception
312 runCommand :: String -> GHCi Bool
314 ghciHandle ( \exception -> do
316 showException exception
321 showException (DynException dyn) =
322 case fromDynamic dyn of
323 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
324 Just Interrupted -> io (putStrLn "Interrupted.")
325 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
326 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
327 Just other_ghc_ex -> io (print other_ghc_ex)
329 showException other_exception
330 = io (putStrLn ("*** Exception: " ++ show other_exception))
332 doCommand (':' : command) = specialCommand command
334 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
337 runStmt :: String -> GHCi [Name]
339 | null (filter (not.isSpace) stmt) = return []
341 = do st <- getGHCiState
342 dflags <- io getDynFlags
343 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
344 (new_cmstate, result) <-
345 io $ withProgName (progname st) $ withArgs (args st) $
346 cmRunStmt (cmstate st) dflags' stmt
347 setGHCiState st{cmstate = new_cmstate}
349 CmRunFailed -> return []
350 CmRunException e -> showException e >> return []
351 CmRunDeadlocked -> io (putStrLn "Deadlocked.") >> return []
352 CmRunOk names -> return names
354 -- possibly print the type and revert CAFs after evaluating an expression
356 = do b <- isOptionSet ShowType
358 when b (mapM_ (showTypeOfName (cmstate st)) names)
360 b <- isOptionSet RevertCAFs
361 io (when b revertCAFs)
365 showTypeOfName :: CmState -> Name -> GHCi ()
366 showTypeOfName cmstate n
367 = do maybe_str <- io (cmTypeOfName cmstate n)
370 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
372 flushEverything :: GHCi ()
374 = io $ do Monad.join (readIORef flush_stdout)
375 Monad.join (readIORef flush_stderr)
378 specialCommand :: String -> GHCi Bool
379 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
380 specialCommand str = do
381 let (cmd,rest) = break isSpace str
382 cmds <- io (readIORef commands)
383 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
384 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
385 ++ shortHelpText) >> return False)
386 [(_,f)] -> f (dropWhile isSpace rest)
387 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
388 " matches multiple commands (" ++
389 foldr1 (\a b -> a ++ ',':b) (map fst cs)
390 ++ ")") >> return False)
392 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
394 -----------------------------------------------------------------------------
397 help :: String -> GHCi ()
398 help _ = io (putStr helpText)
400 info :: String -> GHCi ()
401 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
404 state <- getGHCiState
405 dflags <- io getDynFlags
407 infoThings cms [] = return cms
408 infoThings cms (name:names) = do
409 (cms, unqual, stuff) <- io (cmInfoThing cms dflags name)
410 io (putStrLn (showSDocForUser unqual (
411 vcat (intersperse (text "") (map showThing stuff))))
415 showThing (ty_thing, fixity)
416 = vcat [ text "-- " <> showTyThing ty_thing,
417 showFixity fixity (getName ty_thing),
418 ppr (ifaceTyThing ty_thing) ]
421 | fix == defaultFixity = empty
422 | otherwise = ppr fix <+>
423 (if isSymOcc (nameOccName name)
425 else char '`' <> ppr name <> char '`')
427 showTyThing (AClass cl)
428 = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
429 showTyThing (ATyCon ty)
431 = hcat [ppr ty, text " is a primitive type constructor"]
433 = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
434 showTyThing (AnId id)
435 = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
438 | isRecordSelector id =
439 case tyConClass_maybe (fieldLabelTyCon (
440 recordSelectorFieldLabel id)) of
441 Nothing -> text "record selector"
442 Just c -> text "method in class " <> ppr c
443 | isDataConWrapId id = text "data constructor"
444 | otherwise = text "variable"
446 -- also print out the source location for home things
448 | isHomePackageName name && isGoodSrcLoc loc
449 = hsep [ text ", defined at", ppr loc ]
452 where loc = nameSrcLoc name
454 cms <- infoThings (cmstate state) names
455 setGHCiState state{ cmstate = cms }
459 addModule :: String -> GHCi ()
461 let files = words str
462 state <- getGHCiState
463 dflags <- io (getDynFlags)
464 io (revertCAFs) -- always revert CAFs on load/add.
465 let new_targets = files ++ targets state
466 (cmstate1, ok, mods) <- io (cmLoadModule (cmstate state) new_targets)
467 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
468 modulesLoadedMsg ok mods
470 setContext :: String -> GHCi ()
472 = throwDyn (CmdLineError "syntax: `:m <module>'")
473 setContext m | not (isUpper (head m)) || not (all isAlphaNumEx (tail m))
474 = throwDyn (CmdLineError ("strange looking module name: `" ++ m ++ "'"))
476 isAlphaNumEx c = isAlphaNum c || c == '_'
478 = do st <- getGHCiState
479 new_cmstate <- io (cmSetContext (cmstate st) str)
480 setGHCiState st{cmstate=new_cmstate}
482 changeDirectory :: String -> GHCi ()
483 changeDirectory ('~':d) = do
484 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
485 io (setCurrentDirectory (tilde ++ '/':d))
486 changeDirectory d = io (setCurrentDirectory d)
488 defineMacro :: String -> GHCi ()
490 let (macro_name, definition) = break isSpace s
491 cmds <- io (readIORef commands)
493 then throwDyn (CmdLineError "invalid macro name")
495 if (macro_name `elem` map fst cmds)
496 then throwDyn (CmdLineError
497 ("command `" ++ macro_name ++ "' is already defined"))
500 -- give the expression a type signature, so we can be sure we're getting
501 -- something of the right type.
502 let new_expr = '(' : definition ++ ") :: String -> IO String"
504 -- compile the expression
506 dflags <- io getDynFlags
507 (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
508 setGHCiState st{cmstate = new_cmstate}
511 Just hv -> io (writeIORef commands --
512 ((macro_name, keepGoing (runMacro hv)) : cmds))
514 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
516 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
517 stringLoop (lines str)
519 undefineMacro :: String -> GHCi ()
520 undefineMacro macro_name = do
521 cmds <- io (readIORef commands)
522 if (macro_name `elem` map fst builtin_commands)
523 then throwDyn (CmdLineError
524 ("command `" ++ macro_name ++ "' cannot be undefined"))
526 if (macro_name `notElem` map fst cmds)
527 then throwDyn (CmdLineError
528 ("command `" ++ macro_name ++ "' not defined"))
530 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
532 loadModule :: String -> GHCi ()
533 loadModule str = timeIt (loadModule' str)
536 let files = words str
537 state <- getGHCiState
538 dflags <- io getDynFlags
539 cmstate1 <- io (cmUnload (cmstate state) dflags)
540 setGHCiState state{ cmstate = cmstate1, targets = [] }
541 io (revertCAFs) -- always revert CAFs on load.
542 (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 files)
543 setGHCiState state{ cmstate = cmstate2, targets = files }
544 modulesLoadedMsg ok mods
546 reloadModule :: String -> GHCi ()
548 state <- getGHCiState
549 case targets state of
550 [] -> io (putStr "no current target\n")
552 -> do io (revertCAFs) -- always revert CAFs on reload.
553 (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) paths)
554 setGHCiState state{ cmstate=new_cmstate }
555 modulesLoadedMsg ok mods
557 reloadModule _ = noArgs ":reload"
560 modulesLoadedMsg ok mods = do
562 | null mods = text "none."
564 punctuate comma (map text mods)) <> text "."
567 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
569 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
572 typeOfExpr :: String -> GHCi ()
574 = do st <- getGHCiState
575 dflags <- io getDynFlags
576 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
577 setGHCiState st{cmstate = new_cmstate}
580 Just tystr -> io (putStrLn tystr)
582 quit :: String -> GHCi Bool
585 shellEscape :: String -> GHCi Bool
586 shellEscape str = io (system str >> return False)
588 ----------------------------------------------------------------------------
591 -- set options in the interpreter. Syntax is exactly the same as the
592 -- ghc command line, except that certain options aren't available (-C,
595 -- This is pretty fragile: most options won't work as expected. ToDo:
596 -- figure out which ones & disallow them.
598 setCmd :: String -> GHCi ()
600 = do st <- getGHCiState
601 let opts = options st
602 io $ putStrLn (showSDoc (
603 text "options currently set: " <>
606 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
610 ("args":args) -> setArgs args
611 ("prog":prog) -> setProg prog
612 wds -> setOptions wds
616 setGHCiState st{ args = args }
620 setGHCiState st{ progname = prog }
622 io (hPutStrLn stderr "syntax: :set prog <progname>")
625 do -- first, deal with the GHCi opts (+s, +t, etc.)
626 let (plus_opts, minus_opts) = partition isPlus wds
627 mapM setOpt plus_opts
629 -- now, the GHC flags
630 pkgs_before <- io (readIORef v_Packages)
631 leftovers <- io (processArgs static_flags minus_opts [])
632 pkgs_after <- io (readIORef v_Packages)
634 -- update things if the users wants more packages
635 when (pkgs_before /= pkgs_after) $
636 newPackages (pkgs_after \\ pkgs_before)
638 -- then, dynamic flags
641 leftovers <- processArgs dynamic_flags leftovers []
644 if (not (null leftovers))
645 then throwDyn (CmdLineError ("unrecognised flags: " ++
650 unsetOptions :: String -> GHCi ()
652 = do -- first, deal with the GHCi opts (+s, +t, etc.)
654 (minus_opts, rest1) = partition isMinus opts
655 (plus_opts, rest2) = partition isPlus rest1
657 if (not (null rest2))
658 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
661 mapM unsetOpt plus_opts
663 -- can't do GHC flags for now
664 if (not (null minus_opts))
665 then throwDyn (CmdLineError "can't unset GHC command-line flags")
668 isMinus ('-':s) = True
671 isPlus ('+':s) = True
675 = case strToGHCiOpt str of
676 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
677 Just o -> setOption o
680 = case strToGHCiOpt str of
681 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
682 Just o -> unsetOption o
684 strToGHCiOpt :: String -> (Maybe GHCiOption)
685 strToGHCiOpt "s" = Just ShowTiming
686 strToGHCiOpt "t" = Just ShowType
687 strToGHCiOpt "r" = Just RevertCAFs
688 strToGHCiOpt _ = Nothing
690 optToStr :: GHCiOption -> String
691 optToStr ShowTiming = "s"
692 optToStr ShowType = "t"
693 optToStr RevertCAFs = "r"
695 newPackages new_pkgs = do
696 state <- getGHCiState
697 dflags <- io getDynFlags
698 cmstate1 <- io (cmUnload (cmstate state) dflags)
699 setGHCiState state{ cmstate = cmstate1, targets = [] }
702 pkgs <- getPackageInfo
703 flushPackageCache pkgs
705 new_pkg_info <- getPackageDetails new_pkgs
706 mapM_ linkPackage (reverse new_pkg_info)
708 -----------------------------------------------------------------------------
711 data GHCiState = GHCiState
715 targets :: [FilePath],
717 options :: [GHCiOption]
721 = ShowTiming -- show time/allocs after evaluation
722 | ShowType -- show the type of expressions
723 | RevertCAFs -- revert CAFs after every evaluation
726 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
727 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
729 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
731 startGHCi :: GHCi a -> GHCiState -> IO a
732 startGHCi g state = do ref <- newIORef state; unGHCi g ref
734 instance Monad GHCi where
735 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
736 return a = GHCi $ \s -> return a
738 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
739 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
740 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
742 getGHCiState = GHCi $ \r -> readIORef r
743 setGHCiState s = GHCi $ \r -> writeIORef r s
745 isOptionSet :: GHCiOption -> GHCi Bool
747 = do st <- getGHCiState
748 return (opt `elem` options st)
750 setOption :: GHCiOption -> GHCi ()
752 = do st <- getGHCiState
753 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
755 unsetOption :: GHCiOption -> GHCi ()
757 = do st <- getGHCiState
758 setGHCiState (st{ options = filter (/= opt) (options st) })
761 io m = GHCi { unGHCi = \s -> m >>= return }
763 -----------------------------------------------------------------------------
764 -- recursive exception handlers
766 -- Don't forget to unblock async exceptions in the handler, or if we're
767 -- in an exception loop (eg. let a = error a in a) the ^C exception
768 -- may never be delivered. Thanks to Marcin for pointing out the bug.
770 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
771 ghciHandle h (GHCi m) = GHCi $ \s ->
772 Exception.catch (m s)
773 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
775 ghciUnblock :: GHCi a -> GHCi a
776 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
778 -----------------------------------------------------------------------------
781 -- Left: full path name of a .o file, including trailing .o
782 -- Right: "unadorned" name of a .DLL/.so
783 -- e.g. On unix "qt" denotes "libqt.so"
784 -- On WinDoze "burble" denotes "burble.DLL"
785 -- addDLL is platform-specific and adds the lib/.so/.DLL
786 -- suffixes platform-dependently; we don't do that here.
788 -- For dynamic objects only, try to find the object file in all the
789 -- directories specified in v_Library_Paths before giving up.
792 = Either FilePath String
794 showLS (Left nm) = "(static) " ++ nm
795 showLS (Right nm) = "(dynamic) " ++ nm
797 linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO ()
798 linkPackages cmdline_lib_specs pkgs
799 = do mapM_ linkPackage (reverse pkgs)
800 lib_paths <- readIORef v_Library_paths
801 mapM_ (preloadLib lib_paths) cmdline_lib_specs
802 if (null cmdline_lib_specs)
804 else do putStr "final link ... "
806 if ok then putStrLn "done."
807 else throwDyn (InstallationError
808 "linking extra libraries/objects failed")
810 preloadLib :: [String] -> LibrarySpec -> IO ()
811 preloadLib lib_paths lib_spec
812 = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
815 -> do b <- preload_static lib_paths static_ish
816 putStrLn (if b then "done." else "not found")
818 -> -- We add "" to the set of paths to try, so that
819 -- if none of the real paths match, we force addDLL
820 -- to look in the default dynamic-link search paths.
821 do maybe_errstr <- preload_dynamic (lib_paths++[""])
825 Just mm -> preloadFailed mm lib_paths lib_spec
828 preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
829 preloadFailed sys_errmsg paths spec
830 = do putStr ("failed.\nDynamic linker error message was:\n "
831 ++ sys_errmsg ++ "\nWhilst trying to load: "
832 ++ showLS spec ++ "\nDirectories to search are:\n"
833 ++ unlines (map (" "++) paths) )
836 -- not interested in the paths in the static case.
837 preload_static paths name
838 = do b <- doesFileExist name
839 if not b then return False
840 else loadObj name >> return True
842 -- return Nothing == success, else Just error message from addDLL
843 preload_dynamic [] name
845 preload_dynamic (path:paths) rootname
846 = do -- addDLL returns NULL on success
847 maybe_errmsg <- addDLL path rootname
848 if maybe_errmsg == nullPtr
849 then preload_dynamic paths rootname
850 else do str <- peekCString maybe_errmsg
854 = (throwDyn . CmdLineError)
855 "user specified .o/.so/.DLL could not be loaded."
857 -- Packages that don't need loading, because the compiler shares them with
858 -- the interpreted program.
859 dont_load_these = [ "gmp", "rts" ]
861 -- Packages that are already linked into GHCi. For mingw32, we only
862 -- skip gmp and rts, since std and after need to load the msvcrt.dll
863 -- library which std depends on.
865 # ifndef mingw32_TARGET_OS
866 = [ "std", "concurrent", "posix", "text", "util" ]
871 linkPackage :: PackageConfig -> IO ()
873 | name pkg `elem` dont_load_these = return ()
876 -- For each obj, try obj.o and if that fails, obj.so.
877 -- Complication: all the .so's must be loaded before any of the .o's.
878 let dirs = library_dirs pkg
879 let objs = hs_libraries pkg ++ extra_libraries pkg
880 classifieds <- mapM (locateOneObj dirs) objs
882 -- Don't load the .so libs if this is a package GHCi is already
883 -- linked against, because we'll already have the .so linked in.
884 let (so_libs, obj_libs) = partition isRight classifieds
885 let sos_first | name pkg `elem` loaded_in_ghci = obj_libs
886 | otherwise = so_libs ++ obj_libs
888 putStr ("Loading package " ++ name pkg ++ " ... ")
889 mapM loadClassified sos_first
890 putStr "linking ... "
892 if ok then putStrLn "done."
893 else panic ("can't load package `" ++ name pkg ++ "'")
895 isRight (Right _) = True
896 isRight (Left _) = False
898 loadClassified :: LibrarySpec -> IO ()
899 loadClassified (Left obj_absolute_filename)
900 = do loadObj obj_absolute_filename
901 loadClassified (Right dll_unadorned)
902 = do maybe_errmsg <- addDLL "" dll_unadorned -- doesn't seem right to me
903 if maybe_errmsg == nullPtr
905 else do str <- peekCString maybe_errmsg
906 throwDyn (CmdLineError ("can't load .so/.DLL for: "
907 ++ dll_unadorned ++ " (" ++ str ++ ")" ))
909 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
911 = return (Right obj) -- we assume
912 locateOneObj (d:ds) obj
913 = do let path = d ++ '/':obj ++ ".o"
914 b <- doesFileExist path
915 if b then return (Left path) else locateOneObj ds obj
917 -----------------------------------------------------------------------------
918 -- timing & statistics
920 timeIt :: GHCi a -> GHCi a
922 = do b <- isOptionSet ShowTiming
925 else do allocs1 <- io $ getAllocations
926 time1 <- io $ getCPUTime
928 allocs2 <- io $ getAllocations
929 time2 <- io $ getCPUTime
930 io $ printTimes (allocs2 - allocs1) (time2 - time1)
933 foreign import "getAllocations" getAllocations :: IO Int
935 printTimes :: Int -> Integer -> IO ()
936 printTimes allocs psecs
937 = do let secs = (fromIntegral psecs / (10^12)) :: Float
938 secs_str = showFFloat (Just 2) secs
940 parens (text (secs_str "") <+> text "secs" <> comma <+>
941 int allocs <+> text "bytes")))
943 -----------------------------------------------------------------------------
946 foreign import revertCAFs :: IO () -- make it "safe", just in case