1 {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.101 2001/10/31 12:51:08 simonmar 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(..) )
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
324 io (putStrLn ("*** Exception: (unknown)"))
325 Just (PhaseFailed phase code) ->
326 io (putStrLn ("Phase " ++ phase ++ " failed (code "
327 ++ show code ++ ")"))
329 io (putStrLn "Interrupted.")
330 Just (CmdLineError s) ->
331 io (putStrLn s) -- omit the location for CmdLineError
333 io (putStrLn (show other_ghc_ex))
334 showException other_exception
335 = io (putStrLn ("*** Exception: " ++ show other_exception))
337 doCommand (':' : command) = specialCommand command
339 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
342 runStmt :: String -> GHCi [Name]
344 | null (filter (not.isSpace) stmt) = return []
346 = do st <- getGHCiState
347 dflags <- io getDynFlags
348 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
349 (new_cmstate, result) <-
350 io $ withProgName (progname st) $ withArgs (args st) $
351 cmRunStmt (cmstate st) dflags' stmt
352 setGHCiState st{cmstate = new_cmstate}
354 CmRunFailed -> return []
355 CmRunException e -> showException e >> return []
356 CmRunDeadlocked -> io (putStrLn "Deadlocked.") >> return []
357 CmRunOk names -> return names
359 -- possibly print the type and revert CAFs after evaluating an expression
361 = do b <- isOptionSet ShowType
363 when b (mapM_ (showTypeOfName (cmstate st)) names)
365 b <- isOptionSet RevertCAFs
366 io (when b revertCAFs)
370 showTypeOfName :: CmState -> Name -> GHCi ()
371 showTypeOfName cmstate n
372 = do maybe_str <- io (cmTypeOfName cmstate n)
375 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
377 flushEverything :: GHCi ()
379 = io $ do Monad.join (readIORef flush_stdout)
380 Monad.join (readIORef flush_stderr)
383 specialCommand :: String -> GHCi Bool
384 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
385 specialCommand str = do
386 let (cmd,rest) = break isSpace str
387 cmds <- io (readIORef commands)
388 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
389 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
390 ++ shortHelpText) >> return False)
391 [(_,f)] -> f (dropWhile isSpace rest)
392 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
393 " matches multiple commands (" ++
394 foldr1 (\a b -> a ++ ',':b) (map fst cs)
395 ++ ")") >> return False)
397 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
399 -----------------------------------------------------------------------------
402 help :: String -> GHCi ()
403 help _ = io (putStr helpText)
405 info :: String -> GHCi ()
406 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
409 state <- getGHCiState
410 dflags <- io getDynFlags
412 infoThings cms [] = return cms
413 infoThings cms (name:names) = do
414 (cms, unqual, stuff) <- io (cmInfoThing cms dflags name)
415 io (putStrLn (showSDocForUser unqual (
416 vcat (intersperse (text "") (map showThing stuff))))
420 showThing (ty_thing, fixity)
421 = vcat [ text "-- " <> showTyThing ty_thing,
422 showFixity fixity (getName ty_thing),
423 ppr (ifaceTyThing ty_thing) ]
426 | fix == defaultFixity = empty
427 | otherwise = ppr fix <+>
428 (if isSymOcc (nameOccName name)
430 else char '`' <> ppr name <> char '`')
432 showTyThing (AClass cl)
433 = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
434 showTyThing (ATyCon ty)
436 = hcat [ppr ty, text " is a primitive type constructor"]
438 = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
439 showTyThing (AnId id)
440 = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
443 | isRecordSelector id =
444 case tyConClass_maybe (fieldLabelTyCon (
445 recordSelectorFieldLabel id)) of
446 Nothing -> text "record selector"
447 Just c -> text "method in class " <> ppr c
448 | isDataConWrapId id = text "data constructor"
449 | otherwise = text "variable"
451 -- also print out the source location for home things
453 | isHomePackageName name && isGoodSrcLoc loc
454 = hsep [ text ", defined at", ppr loc ]
457 where loc = nameSrcLoc name
459 cms <- infoThings (cmstate state) names
460 setGHCiState state{ cmstate = cms }
464 addModule :: String -> GHCi ()
466 let files = words str
467 state <- getGHCiState
468 dflags <- io (getDynFlags)
469 io (revertCAFs) -- always revert CAFs on load/add.
470 let new_targets = files ++ targets state
471 (cmstate1, ok, mods) <- io (cmLoadModule (cmstate state) new_targets)
472 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
473 modulesLoadedMsg ok mods
475 setContext :: String -> GHCi ()
477 = throwDyn (CmdLineError "syntax: `:m <module>'")
478 setContext m | not (isUpper (head m)) || not (all isAlphaNumEx (tail m))
479 = throwDyn (CmdLineError ("strange looking module name: `" ++ m ++ "'"))
481 isAlphaNumEx c = isAlphaNum c || c == '_'
483 = do st <- getGHCiState
484 new_cmstate <- io (cmSetContext (cmstate st) str)
485 setGHCiState st{cmstate=new_cmstate}
487 changeDirectory :: String -> GHCi ()
488 changeDirectory ('~':d) = do
489 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
490 io (setCurrentDirectory (tilde ++ '/':d))
491 changeDirectory d = io (setCurrentDirectory d)
493 defineMacro :: String -> GHCi ()
495 let (macro_name, definition) = break isSpace s
496 cmds <- io (readIORef commands)
498 then throwDyn (CmdLineError "invalid macro name")
500 if (macro_name `elem` map fst cmds)
501 then throwDyn (CmdLineError
502 ("command `" ++ macro_name ++ "' is already defined"))
505 -- give the expression a type signature, so we can be sure we're getting
506 -- something of the right type.
507 let new_expr = '(' : definition ++ ") :: String -> IO String"
509 -- compile the expression
511 dflags <- io getDynFlags
512 (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
513 setGHCiState st{cmstate = new_cmstate}
516 Just hv -> io (writeIORef commands --
517 ((macro_name, keepGoing (runMacro hv)) : cmds))
519 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
521 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
522 stringLoop (lines str)
524 undefineMacro :: String -> GHCi ()
525 undefineMacro macro_name = do
526 cmds <- io (readIORef commands)
527 if (macro_name `elem` map fst builtin_commands)
528 then throwDyn (CmdLineError
529 ("command `" ++ macro_name ++ "' cannot be undefined"))
531 if (macro_name `notElem` map fst cmds)
532 then throwDyn (CmdLineError
533 ("command `" ++ macro_name ++ "' not defined"))
535 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
537 loadModule :: String -> GHCi ()
538 loadModule str = timeIt (loadModule' str)
541 let files = words str
542 state <- getGHCiState
543 dflags <- io getDynFlags
544 cmstate1 <- io (cmUnload (cmstate state) dflags)
545 setGHCiState state{ cmstate = cmstate1, targets = [] }
546 io (revertCAFs) -- always revert CAFs on load.
547 (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 files)
548 setGHCiState state{ cmstate = cmstate2, targets = files }
549 modulesLoadedMsg ok mods
551 reloadModule :: String -> GHCi ()
553 state <- getGHCiState
554 case targets state of
555 [] -> io (putStr "no current target\n")
557 -> do io (revertCAFs) -- always revert CAFs on reload.
558 (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) paths)
559 setGHCiState state{ cmstate=new_cmstate }
560 modulesLoadedMsg ok mods
562 reloadModule _ = noArgs ":reload"
565 modulesLoadedMsg ok mods = do
567 | null mods = text "none."
569 punctuate comma (map text mods)) <> text "."
572 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
574 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
577 typeOfExpr :: String -> GHCi ()
579 = do st <- getGHCiState
580 dflags <- io getDynFlags
581 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
582 setGHCiState st{cmstate = new_cmstate}
585 Just tystr -> io (putStrLn tystr)
587 quit :: String -> GHCi Bool
590 shellEscape :: String -> GHCi Bool
591 shellEscape str = io (system str >> return False)
593 ----------------------------------------------------------------------------
596 -- set options in the interpreter. Syntax is exactly the same as the
597 -- ghc command line, except that certain options aren't available (-C,
600 -- This is pretty fragile: most options won't work as expected. ToDo:
601 -- figure out which ones & disallow them.
603 setCmd :: String -> GHCi ()
605 = do st <- getGHCiState
606 let opts = options st
607 io $ putStrLn (showSDoc (
608 text "options currently set: " <>
611 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
615 ("args":args) -> setArgs args
616 ("prog":prog) -> setProg prog
617 wds -> setOptions wds
621 setGHCiState st{ args = args }
625 setGHCiState st{ progname = prog }
627 io (hPutStrLn stderr "syntax: :set prog <progname>")
630 do -- first, deal with the GHCi opts (+s, +t, etc.)
631 let (plus_opts, minus_opts) = partition isPlus wds
632 mapM setOpt plus_opts
634 -- now, the GHC flags
635 pkgs_before <- io (readIORef v_Packages)
636 leftovers <- io (processArgs static_flags minus_opts [])
637 pkgs_after <- io (readIORef v_Packages)
639 -- update things if the users wants more packages
640 when (pkgs_before /= pkgs_after) $
641 newPackages (pkgs_after \\ pkgs_before)
643 -- then, dynamic flags
646 leftovers <- processArgs dynamic_flags leftovers []
649 if (not (null leftovers))
650 then throwDyn (CmdLineError ("unrecognised flags: " ++
655 unsetOptions :: String -> GHCi ()
657 = do -- first, deal with the GHCi opts (+s, +t, etc.)
659 (minus_opts, rest1) = partition isMinus opts
660 (plus_opts, rest2) = partition isPlus rest1
662 if (not (null rest2))
663 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
666 mapM unsetOpt plus_opts
668 -- can't do GHC flags for now
669 if (not (null minus_opts))
670 then throwDyn (CmdLineError "can't unset GHC command-line flags")
673 isMinus ('-':s) = True
676 isPlus ('+':s) = True
680 = case strToGHCiOpt str of
681 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
682 Just o -> setOption o
685 = case strToGHCiOpt str of
686 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
687 Just o -> unsetOption o
689 strToGHCiOpt :: String -> (Maybe GHCiOption)
690 strToGHCiOpt "s" = Just ShowTiming
691 strToGHCiOpt "t" = Just ShowType
692 strToGHCiOpt "r" = Just RevertCAFs
693 strToGHCiOpt _ = Nothing
695 optToStr :: GHCiOption -> String
696 optToStr ShowTiming = "s"
697 optToStr ShowType = "t"
698 optToStr RevertCAFs = "r"
700 newPackages new_pkgs = do
701 state <- getGHCiState
702 dflags <- io getDynFlags
703 cmstate1 <- io (cmUnload (cmstate state) dflags)
704 setGHCiState state{ cmstate = cmstate1, targets = [] }
707 pkgs <- getPackageInfo
708 flushPackageCache pkgs
710 new_pkg_info <- getPackageDetails new_pkgs
711 mapM_ linkPackage (reverse new_pkg_info)
713 -----------------------------------------------------------------------------
716 data GHCiState = GHCiState
720 targets :: [FilePath],
722 options :: [GHCiOption]
726 = ShowTiming -- show time/allocs after evaluation
727 | ShowType -- show the type of expressions
728 | RevertCAFs -- revert CAFs after every evaluation
731 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
732 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
734 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
736 startGHCi :: GHCi a -> GHCiState -> IO a
737 startGHCi g state = do ref <- newIORef state; unGHCi g ref
739 instance Monad GHCi where
740 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
741 return a = GHCi $ \s -> return a
743 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
744 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
745 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
747 getGHCiState = GHCi $ \r -> readIORef r
748 setGHCiState s = GHCi $ \r -> writeIORef r s
750 isOptionSet :: GHCiOption -> GHCi Bool
752 = do st <- getGHCiState
753 return (opt `elem` options st)
755 setOption :: GHCiOption -> GHCi ()
757 = do st <- getGHCiState
758 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
760 unsetOption :: GHCiOption -> GHCi ()
762 = do st <- getGHCiState
763 setGHCiState (st{ options = filter (/= opt) (options st) })
766 io m = GHCi { unGHCi = \s -> m >>= return }
768 -----------------------------------------------------------------------------
769 -- recursive exception handlers
771 -- Don't forget to unblock async exceptions in the handler, or if we're
772 -- in an exception loop (eg. let a = error a in a) the ^C exception
773 -- may never be delivered. Thanks to Marcin for pointing out the bug.
775 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
776 ghciHandle h (GHCi m) = GHCi $ \s ->
777 Exception.catch (m s)
778 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
780 ghciUnblock :: GHCi a -> GHCi a
781 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
783 -----------------------------------------------------------------------------
786 -- Left: full path name of a .o file, including trailing .o
787 -- Right: "unadorned" name of a .DLL/.so
788 -- e.g. On unix "qt" denotes "libqt.so"
789 -- On WinDoze "burble" denotes "burble.DLL"
790 -- addDLL is platform-specific and adds the lib/.so/.DLL
791 -- suffixes platform-dependently; we don't do that here.
793 -- For dynamic objects only, try to find the object file in all the
794 -- directories specified in v_Library_Paths before giving up.
797 = Either FilePath String
799 showLS (Left nm) = "(static) " ++ nm
800 showLS (Right nm) = "(dynamic) " ++ nm
802 linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO ()
803 linkPackages cmdline_lib_specs pkgs
804 = do mapM_ linkPackage (reverse pkgs)
805 lib_paths <- readIORef v_Library_paths
806 mapM_ (preloadLib lib_paths) cmdline_lib_specs
807 if (null cmdline_lib_specs)
809 else do putStr "final link ... "
811 if ok then putStrLn "done."
812 else throwDyn (InstallationError "linking extra libraries/objects failed")
814 preloadLib :: [String] -> LibrarySpec -> IO ()
815 preloadLib lib_paths lib_spec
816 = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
819 -> do b <- preload_static lib_paths static_ish
820 putStrLn (if b then "done." else "not found")
822 -> -- We add "" to the set of paths to try, so that
823 -- if none of the real paths match, we force addDLL
824 -- to look in the default dynamic-link search paths.
825 do b <- preload_dynamic (lib_paths++[""]) dll_unadorned
826 when (not b) (cantFind lib_paths lib_spec)
829 cantFind :: [String] -> LibrarySpec -> IO ()
831 = do putStr ("failed.\nCan't find " ++ showLS spec
832 ++ " in directories:\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 preload_dynamic [] name
844 preload_dynamic (path:paths) rootname
845 = do maybe_errmsg <- addDLL path rootname
846 if maybe_errmsg /= nullPtr
847 then preload_dynamic paths rootname
851 = (throwDyn . CmdLineError)
852 "user specified .o/.so/.DLL could not be loaded."
854 -- Packages that don't need loading, because the compiler shares them with
855 -- the interpreted program.
856 dont_load_these = [ "gmp", "rts" ]
858 -- Packages that are already linked into GHCi. For mingw32, we only
859 -- skip gmp and rts, since std and after need to load the msvcrt.dll
860 -- library which std depends on.
862 # ifndef mingw32_TARGET_OS
863 = [ "std", "concurrent", "posix", "text", "util" ]
868 linkPackage :: PackageConfig -> IO ()
870 | name pkg `elem` dont_load_these = return ()
873 -- For each obj, try obj.o and if that fails, obj.so.
874 -- Complication: all the .so's must be loaded before any of the .o's.
875 let dirs = library_dirs pkg
876 let objs = hs_libraries pkg ++ extra_libraries pkg
877 classifieds <- mapM (locateOneObj dirs) objs
879 -- Don't load the .so libs if this is a package GHCi is already
880 -- linked against, because we'll already have the .so linked in.
881 let (so_libs, obj_libs) = partition isRight classifieds
882 let sos_first | name pkg `elem` loaded_in_ghci = obj_libs
883 | otherwise = so_libs ++ obj_libs
885 putStr ("Loading package " ++ name pkg ++ " ... ")
886 mapM loadClassified sos_first
887 putStr "linking ... "
889 if ok then putStrLn "done."
890 else panic ("can't load package `" ++ name pkg ++ "'")
892 isRight (Right _) = True
893 isRight (Left _) = False
895 loadClassified :: LibrarySpec -> IO ()
896 loadClassified (Left obj_absolute_filename)
897 = do loadObj obj_absolute_filename
898 loadClassified (Right dll_unadorned)
899 = do maybe_errmsg <- addDLL "" dll_unadorned -- doesn't seem right to me
900 if maybe_errmsg == nullPtr
902 else do str <- peekCString maybe_errmsg
903 throwDyn (CmdLineError ("can't load .so/.DLL for: "
904 ++ dll_unadorned ++ " (" ++ str ++ ")" ))
906 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
908 = return (Right obj) -- we assume
909 locateOneObj (d:ds) obj
910 = do let path = d ++ '/':obj ++ ".o"
911 b <- doesFileExist path
912 if b then return (Left path) else locateOneObj ds obj
914 -----------------------------------------------------------------------------
915 -- timing & statistics
917 timeIt :: GHCi a -> GHCi a
919 = do b <- isOptionSet ShowTiming
922 else do allocs1 <- io $ getAllocations
923 time1 <- io $ getCPUTime
925 allocs2 <- io $ getAllocations
926 time2 <- io $ getCPUTime
927 io $ printTimes (allocs2 - allocs1) (time2 - time1)
930 foreign import "getAllocations" getAllocations :: IO Int
932 printTimes :: Int -> Integer -> IO ()
933 printTimes allocs psecs
934 = do let secs = (fromIntegral psecs / (10^12)) :: Float
935 secs_str = showFFloat (Just 2) secs
937 parens (text (secs_str "") <+> text "secs" <> comma <+>
938 int allocs <+> text "bytes")))
940 -----------------------------------------------------------------------------
943 foreign import revertCAFs :: IO () -- make it "safe", just in case