1 {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.108 2002/01/22 16:50:29 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(..) )
18 import MkIface ( ifaceTyThing )
21 import DriverUtil ( handle, remove_spaces )
23 import Finder ( flushPackageCache )
25 import Id ( isRecordSelector, recordSelectorFieldLabel,
26 isDataConWrapId, idName )
27 import Class ( className )
28 import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon )
29 import FieldLabel ( fieldLabelTyCon )
30 import SrcLoc ( isGoodSrcLoc )
31 import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName,
33 import OccName ( isSymOcc )
34 import BasicTypes ( defaultFixity )
36 import CmdLineOpts ( DynFlag(..), getDynFlags, saveDynFlags, restoreDynFlags,
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 ("import", keepGoing importModules),
87 ("load", keepGoing loadModule),
88 ("module", keepGoing setContext),
89 ("reload", keepGoing reloadModule),
90 ("set", keepGoing setCmd),
91 ("type", keepGoing typeOfExpr),
92 ("unset", keepGoing unsetOptions),
93 ("undef", keepGoing undefineMacro),
97 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
98 keepGoing a str = a str >> return False
100 shortHelpText = "use :? for help.\n"
103 \ Commands available from the prompt:\n\
105 \ <stmt> evaluate/run <stmt>\n\
106 \ :add <filename> ... add module(s) to the current target set\n\
107 \ :cd <dir> change directory to <dir>\n\
108 \ :def <cmd> <expr> define a command :<cmd>\n\
109 \ :help, :? display this list of commands\n\
110 \ :info [<name> ...] display information about the given names\n\
111 \ :load <filename> ... load module(s) and their dependents\n\
112 \ :module <mod> set the context for expression evaluation to <mod>\n\
113 \ :reload reload the current module set\n\
114 \ :set <option> ... set options\n\
115 \ :set args <arg> ... set the arguments returned by System.getArgs\n\
116 \ :set prog <progname> set the value returned by System.getProgName\n\
117 \ :undef <cmd> undefine user-defined command :<cmd>\n\
118 \ :type <expr> show the type of <expr>\n\
119 \ :unset <option> ... unset options\n\
121 \ :!<command> run the shell command <command>\n\
123 \ Options for `:set' and `:unset':\n\
125 \ +r revert top-level expressions after each evaluation\n\
126 \ +s print timing/memory stats after each evaluation\n\
127 \ +t print type after evaluation\n\
128 \ -<flags> most GHC command line flags can also be set here\n\
129 \ (eg. -v2, -fglasgow-exts, etc.)\n\
132 interactiveUI :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
133 interactiveUI cmstate paths cmdline_libs = do
135 hSetBuffering stdout NoBuffering
137 -- link in the available packages
138 pkgs <- getPackageInfo
140 linkPackages cmdline_libs pkgs
142 dflags <- getDynFlags
144 (cmstate, maybe_hval)
145 <- cmCompileExpr cmstate dflags "IO.hSetBuffering IO.stdout IO.NoBuffering Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
147 Just hval -> unsafeCoerce# hval :: IO ()
148 _ -> panic "interactiveUI:buffering"
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 -- initial context is just the Prelude
163 cmstate <- cmSetContext cmstate dflags [] ["Prelude"]
165 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
169 startGHCi (runGHCi paths)
170 GHCiState{ progname = "<interactive>",
176 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
177 Readline.resetTerminal Nothing
183 runGHCi :: [FilePath] -> GHCi ()
185 read_dot_files <- io (readIORef v_Read_DotGHCi)
187 when (read_dot_files) $ do
190 exists <- io (doesFileExist file)
192 dir_ok <- io (checkPerms ".")
193 file_ok <- io (checkPerms file)
194 when (dir_ok && file_ok) $ do
195 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
198 Right hdl -> fileLoop hdl False
200 when (read_dot_files) $ do
201 -- Read in $HOME/.ghci
202 either_dir <- io (IO.try (getEnv "HOME"))
206 cwd <- io (getCurrentDirectory)
207 when (dir /= cwd) $ do
208 let file = dir ++ "/.ghci"
209 ok <- io (checkPerms file)
211 either_hdl <- io (IO.try (openFile file ReadMode))
214 Right hdl -> fileLoop hdl False
216 -- perform a :load for files given on the GHCi command line
217 when (not (null paths)) $
218 ghciHandle showException $
219 loadModule (unwords paths)
221 -- enter the interactive loop
225 io $ do putStrLn "Leaving GHCi."
229 -- ignore ^C exceptions caught here
230 ghciHandleDyn (\e -> case e of Interrupted -> ghciUnblock interactiveLoop
231 _other -> return ()) $ do
233 -- read commands from stdin
234 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
241 -- NOTE: We only read .ghci files if they are owned by the current user,
242 -- and aren't world writable. Otherwise, we could be accidentally
243 -- running code planted by a malicious third party.
245 -- Furthermore, We only read ./.ghci if . is owned by the current user
246 -- and isn't writable by anyone else. I think this is sufficient: we
247 -- don't need to check .. and ../.. etc. because "." always refers to
248 -- the same directory while a process is running.
250 checkPerms :: String -> IO Bool
252 handle (\_ -> return False) $ do
253 #ifdef mingw32_TARGET_OS
256 st <- getFileStatus name
258 if fileOwner st /= me then do
259 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
262 let mode = fileMode st
263 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
264 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
266 putStrLn $ "*** WARNING: " ++ name ++
267 " is writable by someone else, IGNORING!"
272 fileLoop :: Handle -> Bool -> GHCi ()
273 fileLoop hdl prompt = do
275 (mod,imports) <- io (cmGetContext (cmstate st))
276 when prompt (io (putStr (mkPrompt mod imports)))
277 l <- io (IO.try (hGetLine hdl))
279 Left e | isEOFError e -> return ()
280 | otherwise -> throw e
282 case remove_spaces l of
283 "" -> fileLoop hdl prompt
284 l -> do quit <- runCommand l
285 if quit then return () else fileLoop hdl prompt
287 stringLoop :: [String] -> GHCi ()
288 stringLoop [] = return ()
289 stringLoop (s:ss) = do
291 case remove_spaces s of
293 l -> do quit <- runCommand l
294 if quit then return () else stringLoop ss
296 mkPrompt toplevs exports
297 = concat (intersperse "," toplevs)
298 ++ (if not (null exports)
299 then "[" ++ concat (intersperse "," exports) ++ "]"
303 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
304 readlineLoop :: GHCi ()
307 (mod,imports) <- io (cmGetContext (cmstate st))
309 l <- io (readline (mkPrompt mod imports))
313 case remove_spaces l of
318 if quit then return () else readlineLoop
321 -- Top level exception handler, just prints out the exception
323 runCommand :: String -> GHCi Bool
325 ghciHandle ( \exception -> do
327 showException exception
332 showException (DynException dyn) =
333 case fromDynamic dyn of
334 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
335 Just Interrupted -> io (putStrLn "Interrupted.")
336 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
337 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
338 Just other_ghc_ex -> io (print other_ghc_ex)
340 showException other_exception
341 = io (putStrLn ("*** Exception: " ++ show other_exception))
343 doCommand (':' : command) = specialCommand command
345 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
348 runStmt :: String -> GHCi [Name]
350 | null (filter (not.isSpace) stmt) = return []
352 = do st <- getGHCiState
353 dflags <- io getDynFlags
354 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
355 (new_cmstate, result) <-
356 io $ withProgName (progname st) $ withArgs (args st) $
357 cmRunStmt (cmstate st) dflags' stmt
358 setGHCiState st{cmstate = new_cmstate}
360 CmRunFailed -> return []
361 CmRunException e -> showException e >> return []
362 CmRunOk names -> return names
364 -- possibly print the type and revert CAFs after evaluating an expression
366 = do b <- isOptionSet ShowType
368 when b (mapM_ (showTypeOfName (cmstate st)) names)
370 b <- isOptionSet RevertCAFs
371 io (when b revertCAFs)
375 showTypeOfName :: CmState -> Name -> GHCi ()
376 showTypeOfName cmstate n
377 = do maybe_str <- io (cmTypeOfName cmstate n)
380 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
382 flushEverything :: GHCi ()
384 = io $ do Monad.join (readIORef flush_stdout)
385 Monad.join (readIORef flush_stderr)
388 specialCommand :: String -> GHCi Bool
389 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
390 specialCommand str = do
391 let (cmd,rest) = break isSpace str
392 cmds <- io (readIORef commands)
393 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
394 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
395 ++ shortHelpText) >> return False)
396 [(_,f)] -> f (dropWhile isSpace rest)
397 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
398 " matches multiple commands (" ++
399 foldr1 (\a b -> a ++ ',':b) (map fst cs)
400 ++ ")") >> return False)
402 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
404 -----------------------------------------------------------------------------
407 help :: String -> GHCi ()
408 help _ = io (putStr helpText)
410 info :: String -> GHCi ()
411 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
414 state <- getGHCiState
415 dflags <- io getDynFlags
417 infoThings cms [] = return cms
418 infoThings cms (name:names) = do
419 (cms, unqual, stuff) <- io (cmInfoThing cms dflags name)
420 io (putStrLn (showSDocForUser unqual (
421 vcat (intersperse (text "") (map showThing stuff))))
425 showThing (ty_thing, fixity)
426 = vcat [ text "-- " <> showTyThing ty_thing,
427 showFixity fixity (getName ty_thing),
428 ppr (ifaceTyThing ty_thing) ]
431 | fix == defaultFixity = empty
432 | otherwise = ppr fix <+>
433 (if isSymOcc (nameOccName name)
435 else char '`' <> ppr name <> char '`')
437 showTyThing (AClass cl)
438 = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
439 showTyThing (ATyCon ty)
441 = hcat [ppr ty, text " is a primitive type constructor"]
443 = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
444 showTyThing (AnId id)
445 = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
448 | isRecordSelector id =
449 case tyConClass_maybe (fieldLabelTyCon (
450 recordSelectorFieldLabel id)) of
451 Nothing -> text "record selector"
452 Just c -> text "method in class " <> ppr c
453 | isDataConWrapId id = text "data constructor"
454 | otherwise = text "variable"
456 -- also print out the source location for home things
458 | isHomePackageName name && isGoodSrcLoc loc
459 = hsep [ text ", defined at", ppr loc ]
462 where loc = nameSrcLoc name
464 cms <- infoThings (cmstate state) names
465 setGHCiState state{ cmstate = cms }
468 addModule :: String -> GHCi ()
470 let files = words str
471 state <- getGHCiState
472 dflags <- io (getDynFlags)
473 io (revertCAFs) -- always revert CAFs on load/add.
474 let new_targets = files ++ targets state
475 graph <- io (cmDepAnal (cmstate state) dflags new_targets)
476 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
477 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
478 setContextAfterLoad mods
479 modulesLoadedMsg ok mods
481 changeDirectory :: String -> GHCi ()
482 changeDirectory ('~':d) = do
483 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
484 io (setCurrentDirectory (tilde ++ '/':d))
485 changeDirectory d = io (setCurrentDirectory d)
487 defineMacro :: String -> GHCi ()
489 let (macro_name, definition) = break isSpace s
490 cmds <- io (readIORef commands)
492 then throwDyn (CmdLineError "invalid macro name")
494 if (macro_name `elem` map fst cmds)
495 then throwDyn (CmdLineError
496 ("command `" ++ macro_name ++ "' is already defined"))
499 -- give the expression a type signature, so we can be sure we're getting
500 -- something of the right type.
501 let new_expr = '(' : definition ++ ") :: String -> IO String"
503 -- compile the expression
505 dflags <- io getDynFlags
506 (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
507 setGHCiState st{cmstate = new_cmstate}
510 Just hv -> io (writeIORef commands --
511 ((macro_name, keepGoing (runMacro hv)) : cmds))
513 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
515 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
516 stringLoop (lines str)
518 undefineMacro :: String -> GHCi ()
519 undefineMacro macro_name = do
520 cmds <- io (readIORef commands)
521 if (macro_name `elem` map fst builtin_commands)
522 then throwDyn (CmdLineError
523 ("command `" ++ macro_name ++ "' cannot be undefined"))
525 if (macro_name `notElem` map fst cmds)
526 then throwDyn (CmdLineError
527 ("command `" ++ macro_name ++ "' not defined"))
529 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
532 importModules :: String -> GHCi ()
533 importModules str = return ()
536 loadModule :: String -> GHCi ()
537 loadModule str = timeIt (loadModule' str)
540 let files = words str
541 state <- getGHCiState
542 dflags <- io getDynFlags
544 -- do the dependency anal first, so that if it fails we don't throw
545 -- away the current set of modules.
546 graph <- io (cmDepAnal (cmstate state) dflags files)
548 -- Dependency anal ok, now unload everything
549 cmstate1 <- io (cmUnload (cmstate state) dflags)
550 setGHCiState state{ cmstate = cmstate1, targets = [] }
552 io (revertCAFs) -- always revert CAFs on load.
553 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
554 setGHCiState state{ cmstate = cmstate2, targets = files }
556 setContextAfterLoad mods
557 modulesLoadedMsg ok mods
560 reloadModule :: String -> GHCi ()
562 state <- getGHCiState
563 dflags <- io getDynFlags
564 case targets state of
565 [] -> io (putStr "no current target\n")
567 -- do the dependency anal first, so that if it fails we don't throw
568 -- away the current set of modules.
569 graph <- io (cmDepAnal (cmstate state) dflags paths)
571 io (revertCAFs) -- always revert CAFs on reload.
573 <- io (cmLoadModules (cmstate state) dflags graph)
574 setGHCiState state{ cmstate=cmstate1 }
575 setContextAfterLoad mods
576 modulesLoadedMsg ok mods
578 reloadModule _ = noArgs ":reload"
580 setContextAfterLoad [] = setContext prel
581 setContextAfterLoad (m:_) = setContext m
583 modulesLoadedMsg ok mods = do
585 | null mods = text "none."
587 punctuate comma (map text mods)) <> text "."
590 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
592 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
595 typeOfExpr :: String -> GHCi ()
597 = do st <- getGHCiState
598 dflags <- io getDynFlags
599 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
600 setGHCiState st{cmstate = new_cmstate}
603 Just tystr -> io (putStrLn tystr)
605 quit :: String -> GHCi Bool
608 shellEscape :: String -> GHCi Bool
609 shellEscape str = io (system str >> return False)
611 -----------------------------------------------------------------------------
612 -- Setting the module context
615 | all sensible mods = newContext mods -- default is to set the empty context
616 | all plusminus mods = adjustContext mods
618 = throwDyn (CmdLineError "syntax: :module M1 .. Mn | :module [+/-]M1 ... [+/-]Mn")
622 sensible (c:cs) = isUpper c && all isAlphaNumEx cs
623 isAlphaNumEx c = isAlphaNum c || c == '_'
625 plusminus ('-':mod) = sensible mod
626 plusminus ('+':mod) = sensible mod
630 state@GHCiState{cmstate=cmstate} <- getGHCiState
631 dflags <- io getDynFlags
633 let separate [] as bs = return (as,bs)
634 separate (m:ms) as bs = do
635 b <- io (cmModuleIsInterpreted cmstate m)
636 if b then separate ms (m:as) bs
637 else separate ms as (m:bs)
639 (as,bs) <- separate mods [] []
640 let bs' = if null as && prel `notElem` bs then prel:bs else bs
641 cmstate' <- io (cmSetContext cmstate dflags as bs')
642 setGHCiState state{cmstate=cmstate'}
646 adjustContext mods = do
647 state@GHCiState{cmstate=cmstate} <- getGHCiState
648 dflags <- io getDynFlags
650 let adjust [] as bs = return (as,bs)
651 adjust (('-':m) : ms) as bs
652 | m `elem` as = adjust ms (delete m as) bs
653 | m `elem` bs = adjust ms as (delete m bs)
654 | otherwise = throwDyn (CmdLineError ("module `" ++ m ++ "' is not currently in scope"))
655 adjust (('+':m) : ms) as bs
656 | m `elem` as || m `elem` bs = adjust ms as bs -- continue silently
657 | otherwise = do b <- io (cmModuleIsInterpreted cmstate m)
658 if b then adjust ms (m:as) bs
659 else adjust ms as (m:bs)
661 (as,bs) <- io (cmGetContext cmstate)
662 (as,bs) <- adjust mods as bs
663 let bs' = if null as && prel `notElem` bs then prel:bs else bs
664 cmstate' <- io (cmSetContext cmstate dflags as bs')
665 setGHCiState state{cmstate=cmstate'}
667 ----------------------------------------------------------------------------
670 -- set options in the interpreter. Syntax is exactly the same as the
671 -- ghc command line, except that certain options aren't available (-C,
674 -- This is pretty fragile: most options won't work as expected. ToDo:
675 -- figure out which ones & disallow them.
677 setCmd :: String -> GHCi ()
679 = do st <- getGHCiState
680 let opts = options st
681 io $ putStrLn (showSDoc (
682 text "options currently set: " <>
685 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
689 ("args":args) -> setArgs args
690 ("prog":prog) -> setProg prog
691 wds -> setOptions wds
695 setGHCiState st{ args = args }
699 setGHCiState st{ progname = prog }
701 io (hPutStrLn stderr "syntax: :set prog <progname>")
704 do -- first, deal with the GHCi opts (+s, +t, etc.)
705 let (plus_opts, minus_opts) = partition isPlus wds
706 mapM setOpt plus_opts
708 -- now, the GHC flags
709 pkgs_before <- io (readIORef v_Packages)
710 leftovers <- io (processArgs static_flags minus_opts [])
711 pkgs_after <- io (readIORef v_Packages)
713 -- update things if the users wants more packages
714 when (pkgs_before /= pkgs_after) $
715 newPackages (pkgs_after \\ pkgs_before)
717 -- then, dynamic flags
720 leftovers <- processArgs dynamic_flags leftovers []
723 if (not (null leftovers))
724 then throwDyn (CmdLineError ("unrecognised flags: " ++
729 unsetOptions :: String -> GHCi ()
731 = do -- first, deal with the GHCi opts (+s, +t, etc.)
733 (minus_opts, rest1) = partition isMinus opts
734 (plus_opts, rest2) = partition isPlus rest1
736 if (not (null rest2))
737 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
740 mapM unsetOpt plus_opts
742 -- can't do GHC flags for now
743 if (not (null minus_opts))
744 then throwDyn (CmdLineError "can't unset GHC command-line flags")
747 isMinus ('-':s) = True
750 isPlus ('+':s) = True
754 = case strToGHCiOpt str of
755 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
756 Just o -> setOption o
759 = case strToGHCiOpt str of
760 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
761 Just o -> unsetOption o
763 strToGHCiOpt :: String -> (Maybe GHCiOption)
764 strToGHCiOpt "s" = Just ShowTiming
765 strToGHCiOpt "t" = Just ShowType
766 strToGHCiOpt "r" = Just RevertCAFs
767 strToGHCiOpt _ = Nothing
769 optToStr :: GHCiOption -> String
770 optToStr ShowTiming = "s"
771 optToStr ShowType = "t"
772 optToStr RevertCAFs = "r"
774 newPackages new_pkgs = do
775 state <- getGHCiState
776 dflags <- io getDynFlags
777 cmstate1 <- io (cmUnload (cmstate state) dflags)
778 setGHCiState state{ cmstate = cmstate1, targets = [] }
781 pkgs <- getPackageInfo
782 flushPackageCache pkgs
784 new_pkg_info <- getPackageDetails new_pkgs
785 mapM_ linkPackage (reverse new_pkg_info)
787 -----------------------------------------------------------------------------
790 data GHCiState = GHCiState
794 targets :: [FilePath],
796 options :: [GHCiOption]
800 = ShowTiming -- show time/allocs after evaluation
801 | ShowType -- show the type of expressions
802 | RevertCAFs -- revert CAFs after every evaluation
805 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
806 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
808 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
810 startGHCi :: GHCi a -> GHCiState -> IO a
811 startGHCi g state = do ref <- newIORef state; unGHCi g ref
813 instance Monad GHCi where
814 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
815 return a = GHCi $ \s -> return a
817 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
818 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
819 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
821 getGHCiState = GHCi $ \r -> readIORef r
822 setGHCiState s = GHCi $ \r -> writeIORef r s
824 isOptionSet :: GHCiOption -> GHCi Bool
826 = do st <- getGHCiState
827 return (opt `elem` options st)
829 setOption :: GHCiOption -> GHCi ()
831 = do st <- getGHCiState
832 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
834 unsetOption :: GHCiOption -> GHCi ()
836 = do st <- getGHCiState
837 setGHCiState (st{ options = filter (/= opt) (options st) })
840 io m = GHCi { unGHCi = \s -> m >>= return }
842 -----------------------------------------------------------------------------
843 -- recursive exception handlers
845 -- Don't forget to unblock async exceptions in the handler, or if we're
846 -- in an exception loop (eg. let a = error a in a) the ^C exception
847 -- may never be delivered. Thanks to Marcin for pointing out the bug.
849 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
850 ghciHandle h (GHCi m) = GHCi $ \s ->
851 Exception.catch (m s)
852 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
854 ghciUnblock :: GHCi a -> GHCi a
855 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
857 -----------------------------------------------------------------------------
860 -- Left: full path name of a .o file, including trailing .o
861 -- Right: "unadorned" name of a .DLL/.so
862 -- e.g. On unix "qt" denotes "libqt.so"
863 -- On WinDoze "burble" denotes "burble.DLL"
864 -- addDLL is platform-specific and adds the lib/.so/.DLL
865 -- suffixes platform-dependently; we don't do that here.
867 -- For dynamic objects only, try to find the object file in all the
868 -- directories specified in v_Library_Paths before giving up.
871 = Either FilePath String
873 showLS (Left nm) = "(static) " ++ nm
874 showLS (Right nm) = "(dynamic) " ++ nm
876 linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO ()
877 linkPackages cmdline_lib_specs pkgs
878 = do mapM_ linkPackage (reverse pkgs)
879 lib_paths <- readIORef v_Library_paths
880 mapM_ (preloadLib lib_paths) cmdline_lib_specs
881 if (null cmdline_lib_specs)
883 else do putStr "final link ... "
885 if ok then putStrLn "done."
886 else throwDyn (InstallationError
887 "linking extra libraries/objects failed")
889 preloadLib :: [String] -> LibrarySpec -> IO ()
890 preloadLib lib_paths lib_spec
891 = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
894 -> do b <- preload_static lib_paths static_ish
895 putStrLn (if b then "done." else "not found")
897 -> -- We add "" to the set of paths to try, so that
898 -- if none of the real paths match, we force addDLL
899 -- to look in the default dynamic-link search paths.
900 do maybe_errstr <- preload_dynamic (lib_paths++[""])
904 Just mm -> preloadFailed mm lib_paths lib_spec
907 preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
908 preloadFailed sys_errmsg paths spec
909 = do putStr ("failed.\nDynamic linker error message was:\n "
910 ++ sys_errmsg ++ "\nWhilst trying to load: "
911 ++ showLS spec ++ "\nDirectories to search are:\n"
912 ++ unlines (map (" "++) paths) )
915 -- not interested in the paths in the static case.
916 preload_static paths name
917 = do b <- doesFileExist name
918 if not b then return False
919 else loadObj name >> return True
921 -- return Nothing == success, else Just error message from addDLL
922 preload_dynamic [] name
924 preload_dynamic (path:paths) rootname
925 = do -- addDLL returns NULL on success
926 maybe_errmsg <- addDLL path rootname
927 if maybe_errmsg == nullPtr
928 then preload_dynamic paths rootname
929 else do str <- peekCString maybe_errmsg
933 = (throwDyn . CmdLineError)
934 "user specified .o/.so/.DLL could not be loaded."
936 -- Packages that don't need loading, because the compiler shares them with
937 -- the interpreted program.
938 dont_load_these = [ "gmp", "rts" ]
940 -- Packages that are already linked into GHCi. For mingw32, we only
941 -- skip gmp and rts, since std and after need to load the msvcrt.dll
942 -- library which std depends on.
944 # ifndef mingw32_TARGET_OS
945 = [ "std", "concurrent", "posix", "text", "util" ]
950 linkPackage :: PackageConfig -> IO ()
952 | name pkg `elem` dont_load_these = return ()
955 -- For each obj, try obj.o and if that fails, obj.so.
956 -- Complication: all the .so's must be loaded before any of the .o's.
957 let dirs = library_dirs pkg
958 let objs = hs_libraries pkg ++ extra_libraries pkg
959 classifieds <- mapM (locateOneObj dirs) objs
961 -- Don't load the .so libs if this is a package GHCi is already
962 -- linked against, because we'll already have the .so linked in.
963 let (so_libs, obj_libs) = partition isRight classifieds
964 let sos_first | name pkg `elem` loaded_in_ghci = obj_libs
965 | otherwise = so_libs ++ obj_libs
967 putStr ("Loading package " ++ name pkg ++ " ... ")
968 mapM loadClassified sos_first
969 putStr "linking ... "
971 if ok then putStrLn "done."
972 else panic ("can't load package `" ++ name pkg ++ "'")
974 isRight (Right _) = True
975 isRight (Left _) = False
977 loadClassified :: LibrarySpec -> IO ()
978 loadClassified (Left obj_absolute_filename)
979 = do loadObj obj_absolute_filename
980 loadClassified (Right dll_unadorned)
981 = do maybe_errmsg <- addDLL "" dll_unadorned -- doesn't seem right to me
982 if maybe_errmsg == nullPtr
984 else do str <- peekCString maybe_errmsg
985 throwDyn (CmdLineError ("can't load .so/.DLL for: "
986 ++ dll_unadorned ++ " (" ++ str ++ ")" ))
988 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
990 = return (Right obj) -- we assume
991 locateOneObj (d:ds) obj
992 = do let path = d ++ '/':obj ++ ".o"
993 b <- doesFileExist path
994 if b then return (Left path) else locateOneObj ds obj
996 -----------------------------------------------------------------------------
997 -- timing & statistics
999 timeIt :: GHCi a -> GHCi a
1001 = do b <- isOptionSet ShowTiming
1004 else do allocs1 <- io $ getAllocations
1005 time1 <- io $ getCPUTime
1007 allocs2 <- io $ getAllocations
1008 time2 <- io $ getCPUTime
1009 io $ printTimes (allocs2 - allocs1) (time2 - time1)
1012 foreign import "getAllocations" getAllocations :: IO Int
1014 printTimes :: Int -> Integer -> IO ()
1015 printTimes allocs psecs
1016 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1017 secs_str = showFFloat (Just 2) secs
1018 putStrLn (showSDoc (
1019 parens (text (secs_str "") <+> text "secs" <> comma <+>
1020 int allocs <+> text "bytes")))
1022 -----------------------------------------------------------------------------
1025 foreign import revertCAFs :: IO () -- make it "safe", just in case