1 {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.131 2002/08/05 09:18:27 simonmar Exp $
5 -- GHC Interactive User Interface
7 -- (c) The GHC Team 2000
9 -----------------------------------------------------------------------------
10 module InteractiveUI (
11 interactiveUI, -- :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
16 #include "../includes/config.h"
17 #include "HsVersions.h"
22 import CmTypes ( Linkable, isObjectLinkable, ModSummary(..) )
23 import CmLink ( findModuleLinkable_maybe )
25 import HscTypes ( TyThing(..), showModMsg, InteractiveContext(..) )
26 import HsSyn ( TyClDecl(..), ConDecl(..), Sig(..) )
27 import MkIface ( ifaceTyThing )
30 import DriverUtil ( handle, remove_spaces )
32 import Finder ( flushPackageCache )
34 import Id ( isRecordSelector, recordSelectorFieldLabel,
35 isDataConWrapId, isDataConId, idName )
36 import Class ( className )
37 import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) )
38 import FieldLabel ( fieldLabelTyCon )
39 import SrcLoc ( isGoodSrcLoc )
40 import Module ( moduleName )
41 import NameEnv ( nameEnvElts )
42 import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName,
44 import OccName ( isSymOcc )
45 import BasicTypes ( defaultFixity )
47 import CmdLineOpts ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags,
48 restoreDynFlags, dopt_unset )
49 import Panic ( GhcException(..), showGhcException )
52 #ifndef mingw32_TARGET_OS
58 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
74 import GlaExts ( unsafeCoerce# )
76 import Foreign ( nullPtr )
77 import CString ( CString, peekCString, withCString )
79 -----------------------------------------------------------------------------
83 \ / _ \\ /\\ /\\/ __(_)\n\
84 \ / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
85 \/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n\
86 \\\____/\\/ /_/\\____/|_| Type :? for help.\n"
88 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
90 builtin_commands :: [(String, String -> GHCi Bool)]
92 ("add", keepGoing addModule),
93 ("browse", keepGoing browseCmd),
94 ("cd", keepGoing changeDirectory),
95 ("def", keepGoing defineMacro),
96 ("help", keepGoing help),
97 ("?", keepGoing help),
98 ("info", keepGoing info),
99 ("load", keepGoing loadModule),
100 ("module", keepGoing setContext),
101 ("reload", keepGoing reloadModule),
102 ("set", keepGoing setCmd),
103 ("show", keepGoing showCmd),
104 ("type", keepGoing typeOfExpr),
105 ("unset", keepGoing unsetOptions),
106 ("undef", keepGoing undefineMacro),
110 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
111 keepGoing a str = a str >> return False
113 shortHelpText = "use :? for help.\n"
115 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
117 \ Commands available from the prompt:\n\
119 \ <stmt> evaluate/run <stmt>\n\
120 \ :add <filename> ... add module(s) to the current target set\n\
121 \ :browse [*]<module> display the names defined by <module>\n\
122 \ :cd <dir> change directory to <dir>\n\
123 \ :def <cmd> <expr> define a command :<cmd>\n\
124 \ :help, :? display this list of commands\n\
125 \ :info [<name> ...] display information about the given names\n\
126 \ :load <filename> ... load module(s) and their dependents\n\
127 \ :module [+/-] [*]<mod> ... set the context for expression evaluation\n\
128 \ :reload reload the current module set\n\
130 \ :set <option> ... set options\n\
131 \ :set args <arg> ... set the arguments returned by System.getArgs\n\
132 \ :set prog <progname> set the value returned by System.getProgName\n\
134 \ :show modules show the currently loaded modules\n\
135 \ :show bindings show the current bindings made at the prompt\n\
137 \ :type <expr> show the type of <expr>\n\
138 \ :undef <cmd> undefine user-defined command :<cmd>\n\
139 \ :unset <option> ... unset options\n\
141 \ :!<command> run the shell command <command>\n\
143 \ Options for `:set' and `:unset':\n\
145 \ +r revert top-level expressions after each evaluation\n\
146 \ +s print timing/memory stats after each evaluation\n\
147 \ +t print type after evaluation\n\
148 \ -<flags> most GHC command line flags can also be set here\n\
149 \ (eg. -v2, -fglasgow-exts, etc.)\n\
152 interactiveUI :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
153 interactiveUI cmstate paths cmdline_libs = do
155 hSetBuffering stdout NoBuffering
157 dflags <- getDynFlags
159 -- link in the available packages
160 pkgs <- getPackageInfo
162 linkPackages dflags cmdline_libs pkgs
164 (cmstate, maybe_hval)
165 <- cmCompileExpr cmstate dflags "IO.hSetBuffering IO.stdout IO.NoBuffering Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
168 let action = unsafeCoerce# hval :: IO ()
170 writeIORef turn_off_buffering action -- and save it for later
171 _ -> panic "interactiveUI:buffering"
173 (cmstate, maybe_hval)
174 <- cmCompileExpr cmstate dflags "IO.hFlush IO.stderr"
176 Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
177 _ -> panic "interactiveUI:stderr"
179 (cmstate, maybe_hval)
180 <- cmCompileExpr cmstate dflags "IO.hFlush IO.stdout"
182 Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
183 _ -> panic "interactiveUI:stdout"
185 -- We don't want the cmd line to buffer any input that might be
186 -- intended for the program, so unbuffer stdin.
187 hSetBuffering stdin NoBuffering
189 -- initial context is just the Prelude
190 cmstate <- cmSetContext cmstate dflags [] ["Prelude"]
192 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
196 startGHCi (runGHCi paths dflags)
197 GHCiState{ progname = "<interactive>",
203 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
204 Readline.resetTerminal Nothing
210 runGHCi :: [FilePath] -> DynFlags -> GHCi ()
211 runGHCi paths dflags = do
212 read_dot_files <- io (readIORef v_Read_DotGHCi)
214 when (read_dot_files) $ do
217 exists <- io (doesFileExist file)
219 dir_ok <- io (checkPerms ".")
220 file_ok <- io (checkPerms file)
221 when (dir_ok && file_ok) $ do
222 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
225 Right hdl -> fileLoop hdl False
227 when (read_dot_files) $ do
228 -- Read in $HOME/.ghci
229 either_dir <- io (IO.try (getEnv "HOME"))
233 cwd <- io (getCurrentDirectory)
234 when (dir /= cwd) $ do
235 let file = dir ++ "/.ghci"
236 ok <- io (checkPerms file)
238 either_hdl <- io (IO.try (openFile file ReadMode))
241 Right hdl -> fileLoop hdl False
243 -- perform a :load for files given on the GHCi command line
244 when (not (null paths)) $
245 ghciHandle showException $
246 loadModule (unwords paths)
248 -- enter the interactive loop
249 #if defined(mingw32_TARGET_OS)
250 -- always show prompt, since hIsTerminalDevice returns True for Consoles
251 -- only, which we may or may not be running under (cf. Emacs sub-shells.)
254 is_tty <- io (hIsTerminalDevice stdin)
255 interactiveLoop is_tty
259 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
262 interactiveLoop is_tty = do
263 -- ignore ^C exceptions caught here
264 ghciHandleDyn (\e -> case e of
265 Interrupted -> ghciUnblock (interactiveLoop is_tty)
266 _other -> return ()) $ do
268 -- read commands from stdin
269 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
272 else fileLoop stdin False -- turn off prompt for non-TTY input
274 fileLoop stdin is_tty
278 -- NOTE: We only read .ghci files if they are owned by the current user,
279 -- and aren't world writable. Otherwise, we could be accidentally
280 -- running code planted by a malicious third party.
282 -- Furthermore, We only read ./.ghci if . is owned by the current user
283 -- and isn't writable by anyone else. I think this is sufficient: we
284 -- don't need to check .. and ../.. etc. because "." always refers to
285 -- the same directory while a process is running.
287 checkPerms :: String -> IO Bool
289 #ifdef mingw32_TARGET_OS
292 DriverUtil.handle (\_ -> return False) $ do
293 st <- getFileStatus name
295 if fileOwner st /= me then do
296 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
299 let mode = fileMode st
300 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
301 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
303 putStrLn $ "*** WARNING: " ++ name ++
304 " is writable by someone else, IGNORING!"
309 fileLoop :: Handle -> Bool -> GHCi ()
310 fileLoop hdl prompt = do
311 cmstate <- getCmState
312 (mod,imports) <- io (cmGetContext cmstate)
313 when prompt (io (putStr (mkPrompt mod imports)))
314 l <- io (IO.try (hGetLine hdl))
316 Left e | isEOFError e -> return ()
317 | otherwise -> throw e
319 case remove_spaces l of
320 "" -> fileLoop hdl prompt
321 l -> do quit <- runCommand l
322 if quit then return () else fileLoop hdl prompt
324 stringLoop :: [String] -> GHCi ()
325 stringLoop [] = return ()
326 stringLoop (s:ss) = do
327 case remove_spaces s of
329 l -> do quit <- runCommand l
330 if quit then return () else stringLoop ss
332 mkPrompt toplevs exports
333 = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
335 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
336 readlineLoop :: GHCi ()
338 cmstate <- getCmState
339 (mod,imports) <- io (cmGetContext cmstate)
341 l <- io (readline (mkPrompt mod imports))
345 case remove_spaces l of
350 if quit then return () else readlineLoop
353 -- Top level exception handler, just prints out the exception
355 runCommand :: String -> GHCi Bool
357 ghciHandle ( \exception -> do
359 showException exception
364 showException (DynException dyn) =
365 case fromDynamic dyn of
366 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
367 Just Interrupted -> io (putStrLn "Interrupted.")
368 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
369 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
370 Just other_ghc_ex -> io (print other_ghc_ex)
372 showException other_exception
373 = io (putStrLn ("*** Exception: " ++ show other_exception))
375 doCommand (':' : command) = specialCommand command
377 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
380 runStmt :: String -> GHCi [Name]
382 | null (filter (not.isSpace) stmt) = return []
384 = do st <- getGHCiState
385 dflags <- io getDynFlags
386 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
387 (new_cmstate, result) <-
388 io $ withProgName (progname st) $ withArgs (args st) $
389 cmRunStmt (cmstate st) dflags' stmt
390 setGHCiState st{cmstate = new_cmstate}
392 CmRunFailed -> return []
393 CmRunException e -> showException e >> return []
394 CmRunOk names -> return names
396 -- possibly print the type and revert CAFs after evaluating an expression
398 = do b <- isOptionSet ShowType
399 cmstate <- getCmState
400 when b (mapM_ (showTypeOfName cmstate) names)
402 b <- isOptionSet RevertCAFs
403 io (when b revertCAFs)
407 showTypeOfName :: CmState -> Name -> GHCi ()
408 showTypeOfName cmstate n
409 = do maybe_str <- io (cmTypeOfName cmstate n)
412 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
414 flushEverything :: GHCi ()
416 = io $ do Monad.join (readIORef flush_stdout)
417 Monad.join (readIORef flush_stderr)
420 specialCommand :: String -> GHCi Bool
421 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
422 specialCommand str = do
423 let (cmd,rest) = break isSpace str
424 cmds <- io (readIORef commands)
425 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
426 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
427 ++ shortHelpText) >> return False)
428 [(_,f)] -> f (dropWhile isSpace rest)
429 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
430 " matches multiple commands (" ++
431 foldr1 (\a b -> a ++ ',':b) (map fst cs)
432 ++ ")") >> return False)
434 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
436 -----------------------------------------------------------------------------
439 help :: String -> GHCi ()
440 help _ = io (putStr helpText)
442 info :: String -> GHCi ()
443 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
446 init_cms <- getCmState
447 dflags <- io getDynFlags
449 infoThings cms [] = return cms
450 infoThings cms (name:names) = do
451 (cms, stuff) <- io (cmInfoThing cms dflags name)
452 io (putStrLn (showSDocForUser unqual (
453 vcat (intersperse (text "") (map showThing stuff))))
457 unqual = cmGetPrintUnqual init_cms
459 showThing (ty_thing, fixity)
460 = vcat [ text "-- " <> showTyThing ty_thing,
461 showFixity fixity (getName ty_thing),
462 ppr (ifaceTyThing ty_thing) ]
465 | fix == defaultFixity = empty
466 | otherwise = ppr fix <+>
467 (if isSymOcc (nameOccName name)
469 else char '`' <> ppr name <> char '`')
471 showTyThing (AClass cl)
472 = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
473 showTyThing (ATyCon ty)
475 = hcat [ppr ty, text " is a primitive type constructor"]
477 = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
478 showTyThing (AnId id)
479 = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
482 | isRecordSelector id =
483 case tyConClass_maybe (fieldLabelTyCon (
484 recordSelectorFieldLabel id)) of
485 Nothing -> text "record selector"
486 Just c -> text "method in class " <> ppr c
487 | isDataConWrapId id = text "data constructor"
488 | otherwise = text "variable"
490 -- also print out the source location for home things
492 | isHomePackageName name && isGoodSrcLoc loc
493 = hsep [ text ", defined at", ppr loc ]
496 where loc = nameSrcLoc name
498 cms <- infoThings init_cms names
502 addModule :: String -> GHCi ()
504 let files = words str
505 state <- getGHCiState
506 dflags <- io (getDynFlags)
507 io (revertCAFs) -- always revert CAFs on load/add.
508 let new_targets = files ++ targets state
509 graph <- io (cmDepAnal (cmstate state) dflags new_targets)
510 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
511 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
512 setContextAfterLoad mods
513 modulesLoadedMsg ok mods dflags
515 changeDirectory :: String -> GHCi ()
516 changeDirectory ('~':d) = do
517 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
518 io (setCurrentDirectory (tilde ++ '/':d))
519 changeDirectory d = io (setCurrentDirectory d)
521 defineMacro :: String -> GHCi ()
523 let (macro_name, definition) = break isSpace s
524 cmds <- io (readIORef commands)
526 then throwDyn (CmdLineError "invalid macro name")
528 if (macro_name `elem` map fst cmds)
529 then throwDyn (CmdLineError
530 ("command `" ++ macro_name ++ "' is already defined"))
533 -- give the expression a type signature, so we can be sure we're getting
534 -- something of the right type.
535 let new_expr = '(' : definition ++ ") :: String -> IO String"
537 -- compile the expression
539 dflags <- io getDynFlags
540 (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
541 setCmState new_cmstate
544 Just hv -> io (writeIORef commands --
545 ((macro_name, keepGoing (runMacro hv)) : cmds))
547 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
549 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
550 stringLoop (lines str)
552 undefineMacro :: String -> GHCi ()
553 undefineMacro macro_name = do
554 cmds <- io (readIORef commands)
555 if (macro_name `elem` map fst builtin_commands)
556 then throwDyn (CmdLineError
557 ("command `" ++ macro_name ++ "' cannot be undefined"))
559 if (macro_name `notElem` map fst cmds)
560 then throwDyn (CmdLineError
561 ("command `" ++ macro_name ++ "' not defined"))
563 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
566 loadModule :: String -> GHCi ()
567 loadModule str = timeIt (loadModule' str)
570 let files = words str
571 state <- getGHCiState
572 dflags <- io getDynFlags
574 -- do the dependency anal first, so that if it fails we don't throw
575 -- away the current set of modules.
576 graph <- io (cmDepAnal (cmstate state) dflags files)
578 -- Dependency anal ok, now unload everything
579 cmstate1 <- io (cmUnload (cmstate state) dflags)
580 setGHCiState state{ cmstate = cmstate1, targets = [] }
582 io (revertCAFs) -- always revert CAFs on load.
583 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
584 setGHCiState state{ cmstate = cmstate2, targets = files }
586 setContextAfterLoad mods
587 modulesLoadedMsg ok mods dflags
590 reloadModule :: String -> GHCi ()
592 state <- getGHCiState
593 dflags <- io getDynFlags
594 case targets state of
595 [] -> io (putStr "no current target\n")
597 -- do the dependency anal first, so that if it fails we don't throw
598 -- away the current set of modules.
599 graph <- io (cmDepAnal (cmstate state) dflags paths)
601 io (revertCAFs) -- always revert CAFs on reload.
603 <- io (cmLoadModules (cmstate state) dflags graph)
604 setGHCiState state{ cmstate=cmstate1 }
605 setContextAfterLoad mods
606 modulesLoadedMsg ok mods dflags
608 reloadModule _ = noArgs ":reload"
610 setContextAfterLoad [] = setContext prel
611 setContextAfterLoad (m:_) = do
612 cmstate <- getCmState
613 b <- io (cmModuleIsInterpreted cmstate m)
614 if b then setContext ('*':m) else setContext m
616 modulesLoadedMsg ok mods dflags =
617 when (verbosity dflags > 0) $ do
619 | null mods = text "none."
621 punctuate comma (map text mods)) <> text "."
624 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
626 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
629 typeOfExpr :: String -> GHCi ()
631 = do cms <- getCmState
632 dflags <- io getDynFlags
633 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
634 setCmState new_cmstate
637 Just tystr -> io (putStrLn tystr)
639 quit :: String -> GHCi Bool
642 shellEscape :: String -> GHCi Bool
643 shellEscape str = io (system str >> return False)
645 -----------------------------------------------------------------------------
646 -- Browing a module's contents
648 browseCmd :: String -> GHCi ()
651 ['*':m] | looksLikeModuleName m -> browseModule m False
652 [m] | looksLikeModuleName m -> browseModule m True
653 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
655 browseModule m exports_only = do
657 dflags <- io getDynFlags
659 is_interpreted <- io (cmModuleIsInterpreted cms m)
660 when (not is_interpreted && not exports_only) $
661 throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
663 -- temporarily set the context to the module we're interested in,
664 -- just so we can get an appropriate PrintUnqualified
665 (as,bs) <- io (cmGetContext cms)
666 cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m]
667 else cmSetContext cms dflags [m] [])
668 cms2 <- io (cmSetContext cms1 dflags as bs)
670 (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)
674 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
676 things' = filter wantToSee things
678 wantToSee (AnId id) = not (isDataConId id || isDataConWrapId id)
681 thing_names = map getName things
683 thingDecl thing@(AnId id) = ifaceTyThing thing
685 thingDecl thing@(AClass c) =
686 let rn_decl = ifaceTyThing thing in
688 ClassDecl { tcdSigs = cons } ->
689 rn_decl{ tcdSigs = filter methodIsVisible cons }
692 methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
694 thingDecl thing@(ATyCon t) =
695 let rn_decl = ifaceTyThing thing in
697 TyData { tcdCons = DataCons cons } ->
698 rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
701 conIsVisible (ConDecl n _ _ _ _ _) = n `elem` thing_names
703 io (putStrLn (showSDocForUser unqual (
704 vcat (map (ppr . thingDecl) things')))
709 -----------------------------------------------------------------------------
710 -- Setting the module context
713 | all sensible mods = fn mods
714 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
716 (fn, mods) = case str of
717 '+':stuff -> (addToContext, words stuff)
718 '-':stuff -> (removeFromContext, words stuff)
719 stuff -> (newContext, words stuff)
721 sensible ('*':m) = looksLikeModuleName m
722 sensible m = looksLikeModuleName m
726 dflags <- io getDynFlags
727 (as,bs) <- separate cms mods [] []
728 let bs' = if null as && prel `notElem` bs then prel:bs else bs
729 cms' <- io (cmSetContext cms dflags as bs')
732 separate cmstate [] as bs = return (as,bs)
733 separate cmstate (('*':m):ms) as bs = do
734 b <- io (cmModuleIsInterpreted cmstate m)
735 if b then separate cmstate ms (m:as) bs
736 else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
737 separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
742 addToContext mods = do
744 dflags <- io getDynFlags
745 (as,bs) <- io (cmGetContext cms)
747 (as',bs') <- separate cms mods [] []
749 let as_to_add = as' \\ (as ++ bs)
750 bs_to_add = bs' \\ (as ++ bs)
752 cms' <- io (cmSetContext cms dflags
753 (as ++ as_to_add) (bs ++ bs_to_add))
757 removeFromContext mods = do
759 dflags <- io getDynFlags
760 (as,bs) <- io (cmGetContext cms)
762 (as_to_remove,bs_to_remove) <- separate cms mods [] []
764 let as' = as \\ (as_to_remove ++ bs_to_remove)
765 bs' = bs \\ (as_to_remove ++ bs_to_remove)
767 cms' <- io (cmSetContext cms dflags as' bs')
770 ----------------------------------------------------------------------------
773 -- set options in the interpreter. Syntax is exactly the same as the
774 -- ghc command line, except that certain options aren't available (-C,
777 -- This is pretty fragile: most options won't work as expected. ToDo:
778 -- figure out which ones & disallow them.
780 setCmd :: String -> GHCi ()
782 = do st <- getGHCiState
783 let opts = options st
784 io $ putStrLn (showSDoc (
785 text "options currently set: " <>
788 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
792 ("args":args) -> setArgs args
793 ("prog":prog) -> setProg prog
794 wds -> setOptions wds
798 setGHCiState st{ args = args }
802 setGHCiState st{ progname = prog }
804 io (hPutStrLn stderr "syntax: :set prog <progname>")
807 do -- first, deal with the GHCi opts (+s, +t, etc.)
808 let (plus_opts, minus_opts) = partition isPlus wds
809 mapM_ setOpt plus_opts
811 -- now, the GHC flags
812 pkgs_before <- io (readIORef v_Packages)
813 leftovers <- io (processArgs static_flags minus_opts [])
814 pkgs_after <- io (readIORef v_Packages)
816 -- update things if the users wants more packages
817 when (pkgs_before /= pkgs_after) $
818 newPackages (pkgs_after \\ pkgs_before)
820 -- then, dynamic flags
823 leftovers <- processArgs dynamic_flags leftovers []
826 if (not (null leftovers))
827 then throwDyn (CmdLineError ("unrecognised flags: " ++
832 unsetOptions :: String -> GHCi ()
834 = do -- first, deal with the GHCi opts (+s, +t, etc.)
836 (minus_opts, rest1) = partition isMinus opts
837 (plus_opts, rest2) = partition isPlus rest1
839 if (not (null rest2))
840 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
843 mapM_ unsetOpt plus_opts
845 -- can't do GHC flags for now
846 if (not (null minus_opts))
847 then throwDyn (CmdLineError "can't unset GHC command-line flags")
850 isMinus ('-':s) = True
853 isPlus ('+':s) = True
857 = case strToGHCiOpt str of
858 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
859 Just o -> setOption o
862 = case strToGHCiOpt str of
863 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
864 Just o -> unsetOption o
866 strToGHCiOpt :: String -> (Maybe GHCiOption)
867 strToGHCiOpt "s" = Just ShowTiming
868 strToGHCiOpt "t" = Just ShowType
869 strToGHCiOpt "r" = Just RevertCAFs
870 strToGHCiOpt _ = Nothing
872 optToStr :: GHCiOption -> String
873 optToStr ShowTiming = "s"
874 optToStr ShowType = "t"
875 optToStr RevertCAFs = "r"
877 newPackages new_pkgs = do
878 state <- getGHCiState
879 dflags <- io getDynFlags
880 cmstate1 <- io (cmUnload (cmstate state) dflags)
881 setGHCiState state{ cmstate = cmstate1, targets = [] }
884 pkgs <- getPackageInfo
885 flushPackageCache pkgs
887 new_pkg_info <- getPackageDetails new_pkgs
888 mapM_ (linkPackage dflags) (reverse new_pkg_info)
890 setContextAfterLoad []
892 -----------------------------------------------------------------------------
897 ["modules" ] -> showModules
898 ["bindings"] -> showBindings
899 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
903 let mg = cmGetModuleGraph cms
904 ls = cmGetLinkables cms
905 maybe_linkables = map (findModuleLinkable_maybe ls)
906 (map (moduleName.ms_mod) mg)
907 zipWithM showModule mg maybe_linkables
910 showModule :: ModSummary -> Maybe Linkable -> GHCi ()
911 showModule m (Just l) = do
912 io (putStrLn (showModMsg (isObjectLinkable l) (ms_mod m) (ms_location m)))
913 showModule _ Nothing = panic "missing linkable"
918 unqual = cmGetPrintUnqual cms
919 showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
921 io (mapM_ showBinding (cmGetBindings cms))
924 -----------------------------------------------------------------------------
927 data GHCiState = GHCiState
931 targets :: [FilePath],
933 options :: [GHCiOption]
937 = ShowTiming -- show time/allocs after evaluation
938 | ShowType -- show the type of expressions
939 | RevertCAFs -- revert CAFs after every evaluation
942 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
943 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
944 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
946 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
948 startGHCi :: GHCi a -> GHCiState -> IO a
949 startGHCi g state = do ref <- newIORef state; unGHCi g ref
951 instance Monad GHCi where
952 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
953 return a = GHCi $ \s -> return a
955 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
956 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
957 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
959 getGHCiState = GHCi $ \r -> readIORef r
960 setGHCiState s = GHCi $ \r -> writeIORef r s
962 -- for convenience...
963 getCmState = getGHCiState >>= return . cmstate
964 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
966 isOptionSet :: GHCiOption -> GHCi Bool
968 = do st <- getGHCiState
969 return (opt `elem` options st)
971 setOption :: GHCiOption -> GHCi ()
973 = do st <- getGHCiState
974 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
976 unsetOption :: GHCiOption -> GHCi ()
978 = do st <- getGHCiState
979 setGHCiState (st{ options = filter (/= opt) (options st) })
982 io m = GHCi { unGHCi = \s -> m >>= return }
984 -----------------------------------------------------------------------------
985 -- recursive exception handlers
987 -- Don't forget to unblock async exceptions in the handler, or if we're
988 -- in an exception loop (eg. let a = error a in a) the ^C exception
989 -- may never be delivered. Thanks to Marcin for pointing out the bug.
991 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
992 ghciHandle h (GHCi m) = GHCi $ \s ->
993 Exception.catch (m s)
994 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
996 ghciUnblock :: GHCi a -> GHCi a
997 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
999 -----------------------------------------------------------------------------
1002 -- Left: full path name of a .o file, including trailing .o
1003 -- Right: "unadorned" name of a .DLL/.so
1004 -- e.g. On unix "qt" denotes "libqt.so"
1005 -- On WinDoze "burble" denotes "burble.DLL"
1006 -- addDLL is platform-specific and adds the lib/.so/.DLL
1007 -- suffixes platform-dependently; we don't do that here.
1009 -- For dynamic objects only, try to find the object file in all the
1010 -- directories specified in v_Library_Paths before giving up.
1012 data LibrarySpec = Object FilePath | DLL String
1013 #ifdef darwin_TARGET_OS
1017 -- Packages that don't need loading, because the compiler shares them with
1018 -- the interpreted program.
1019 dont_load_these = [ "rts" ]
1021 -- Packages that are already linked into GHCi. For mingw32, we only
1022 -- skip gmp and rts, since std and after need to load the msvcrt.dll
1023 -- library which std depends on.
1025 # ifndef mingw32_TARGET_OS
1026 = [ "std", "concurrent", "posix", "text", "util" ]
1031 showLS (Object nm) = "(static) " ++ nm
1032 showLS (DLL nm) = "(dynamic) " ++ nm
1033 #ifdef darwin_TARGET_OS
1034 showLS (Framework nm) = "(framework) " ++ nm
1037 linkPackages :: DynFlags -> [LibrarySpec] -> [PackageConfig] -> IO ()
1038 linkPackages dflags cmdline_lib_specs pkgs
1039 = do mapM_ (linkPackage dflags) (reverse pkgs)
1040 lib_paths <- readIORef v_Library_paths
1041 mapM_ (preloadLib dflags lib_paths) cmdline_lib_specs
1042 if (null cmdline_lib_specs)
1044 else do maybePutStr dflags "final link ... "
1047 if ok then maybePutStrLn dflags "done."
1048 else throwDyn (InstallationError
1049 "linking extra libraries/objects failed")
1051 preloadLib :: DynFlags -> [String] -> LibrarySpec -> IO ()
1052 preloadLib dflags lib_paths lib_spec
1053 = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
1056 -> do b <- preload_static lib_paths static_ish
1057 maybePutStrLn dflags (if b then "done."
1060 -> -- We add "" to the set of paths to try, so that
1061 -- if none of the real paths match, we force addDLL
1062 -- to look in the default dynamic-link search paths.
1063 do maybe_errstr <- loadDynamic (lib_paths++[""])
1065 case maybe_errstr of
1066 Nothing -> return ()
1067 Just mm -> preloadFailed mm lib_paths lib_spec
1068 maybePutStrLn dflags "done"
1070 preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
1071 preloadFailed sys_errmsg paths spec
1072 = do maybePutStr dflags
1073 ("failed.\nDynamic linker error message was:\n "
1074 ++ sys_errmsg ++ "\nWhilst trying to load: "
1075 ++ showLS spec ++ "\nDirectories to search are:\n"
1076 ++ unlines (map (" "++) paths) )
1079 -- not interested in the paths in the static case.
1080 preload_static paths name
1081 = do b <- doesFileExist name
1082 if not b then return False
1083 else loadObj name >> return True
1086 = (throwDyn . CmdLineError)
1087 "user specified .o/.so/.DLL could not be loaded."
1089 linkPackage :: DynFlags -> PackageConfig -> IO ()
1090 linkPackage dflags pkg
1091 | name pkg `elem` dont_load_these = return ()
1094 let dirs = library_dirs pkg
1095 let libs = hs_libraries pkg ++ extra_libraries pkg
1096 classifieds <- mapM (locateOneObj dirs) libs
1097 #ifdef darwin_TARGET_OS
1098 let fwDirs = framework_dirs pkg
1099 let frameworks= extra_frameworks pkg
1102 -- Complication: all the .so's must be loaded before any of the .o's.
1103 let dlls = [ dll | DLL dll <- classifieds ]
1104 objs = [ obj | Object obj <- classifieds ]
1106 maybePutStr dflags ("Loading package " ++ name pkg ++ " ... ")
1108 -- If this package is already part of the GHCi binary, we'll already
1109 -- have the right DLLs for this package loaded, so don't try to
1111 when (name pkg `notElem` loaded_in_ghci) $ do
1112 #ifdef darwin_TARGET_OS
1113 loadFrameworks fwDirs frameworks
1115 loadDynamics dirs dlls
1117 -- After loading all the DLLs, we can load the static objects.
1120 maybePutStr dflags "linking ... "
1122 if ok then maybePutStrLn dflags "done."
1123 else panic ("can't load package `" ++ name pkg ++ "'")
1125 loadDynamics dirs [] = return ()
1126 loadDynamics dirs (dll:dlls) = do
1127 r <- loadDynamic dirs dll
1129 Nothing -> loadDynamics dirs dlls
1130 Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: "
1131 ++ dll ++ " (" ++ err ++ ")" ))
1132 #ifdef darwin_TARGET_OS
1133 loadFrameworks dirs [] = return ()
1134 loadFrameworks dirs (fw:fws) = do
1135 r <- loadFramework dirs fw
1137 Nothing -> loadFrameworks dirs fws
1138 Just err -> throwDyn (CmdLineError ("can't load framework: "
1139 ++ fw ++ " (" ++ err ++ ")" ))
1142 -- Try to find an object file for a given library in the given paths.
1143 -- If it isn't present, we assume it's a dynamic library.
1144 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1146 = return (DLL lib) -- we assume
1147 locateOneObj (d:ds) lib
1148 = do let path = d ++ '/':lib ++ ".o"
1149 b <- doesFileExist path
1150 if b then return (Object path) else locateOneObj ds lib
1152 -- ----------------------------------------------------------------------------
1153 -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
1155 #if defined(mingw32_TARGET_OS) || defined(cygwin32_TARGET_OS)
1156 loadDynamic paths rootname = addDLL rootname
1157 -- ignore paths on windows (why? --SDM)
1161 -- return Nothing == success, else Just error message from dlopen
1162 loadDynamic (path:paths) rootname = do
1163 let dll = path ++ '/':mkSOName rootname
1164 b <- doesFileExist dll
1166 then loadDynamic paths rootname
1168 loadDynamic [] rootname = do
1169 -- tried all our known library paths, let dlopen() search its
1170 -- own builtin paths now.
1171 addDLL (mkSOName rootname)
1173 #ifdef darwin_TARGET_OS
1174 mkSOName root = "lib" ++ root ++ ".dylib"
1176 mkSOName root = "lib" ++ root ++ ".so"
1181 -- Darwin / MacOS X only: load a framework
1182 -- a framework is a dynamic library packaged inside a directory of the same
1183 -- name. They are searched for in different paths than normal libraries.
1184 #ifdef darwin_TARGET_OS
1185 loadFramework extraPaths rootname
1186 = loadFramework' (extraPaths ++ defaultFrameworkPaths) where
1187 defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
1189 loadFramework' (path:paths) = do
1190 let dll = path ++ '/' : rootname ++ ".framework/" ++ rootname
1191 b <- doesFileExist dll
1193 then loadFramework' paths
1195 loadFramework' [] = do
1196 -- tried all our known library paths, but dlopen()
1197 -- has no built-in paths for frameworks: give up
1198 return $ Just $ "not found"
1201 addDLL :: String -> IO (Maybe String)
1203 maybe_errmsg <- withCString str $ \dll -> c_addDLL dll
1204 if maybe_errmsg == nullPtr
1206 else do str <- peekCString maybe_errmsg
1209 foreign import ccall "addDLL" unsafe
1210 c_addDLL :: CString -> IO CString
1212 -----------------------------------------------------------------------------
1213 -- timing & statistics
1215 timeIt :: GHCi a -> GHCi a
1217 = do b <- isOptionSet ShowTiming
1220 else do allocs1 <- io $ getAllocations
1221 time1 <- io $ getCPUTime
1223 allocs2 <- io $ getAllocations
1224 time2 <- io $ getCPUTime
1225 io $ printTimes (allocs2 - allocs1) (time2 - time1)
1228 foreign import "getAllocations" getAllocations :: IO Int
1230 printTimes :: Int -> Integer -> IO ()
1231 printTimes allocs psecs
1232 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1233 secs_str = showFFloat (Just 2) secs
1234 putStrLn (showSDoc (
1235 parens (text (secs_str "") <+> text "secs" <> comma <+>
1236 int allocs <+> text "bytes")))
1238 -----------------------------------------------------------------------------
1241 looksLikeModuleName [] = False
1242 looksLikeModuleName (c:cs) = isUpper c && all isAlphaNumEx cs
1244 isAlphaNumEx c = isAlphaNum c || c == '_' || c == '.'
1246 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1247 | otherwise = return ()
1249 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1250 | otherwise = return ()
1252 -----------------------------------------------------------------------------
1258 Monad.join (readIORef turn_off_buffering)
1259 -- have to do this again, because we just reverted
1260 -- stdout, stderr & stdin to their defaults.
1262 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1263 -- make it "safe", just in case