1 {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.130 2002/07/26 03:06:58 sof 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"
167 Just hval -> unsafeCoerce# hval :: IO ()
168 _ -> panic "interactiveUI:buffering"
170 (cmstate, maybe_hval)
171 <- cmCompileExpr cmstate dflags "IO.hFlush IO.stderr"
173 Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
174 _ -> panic "interactiveUI:stderr"
176 (cmstate, maybe_hval)
177 <- cmCompileExpr cmstate dflags "IO.hFlush IO.stdout"
179 Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
180 _ -> panic "interactiveUI:stdout"
182 -- We don't want the cmd line to buffer any input that might be
183 -- intended for the program, so unbuffer stdin.
184 hSetBuffering stdin NoBuffering
186 -- initial context is just the Prelude
187 cmstate <- cmSetContext cmstate dflags [] ["Prelude"]
189 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
193 startGHCi (runGHCi paths dflags)
194 GHCiState{ progname = "<interactive>",
200 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
201 Readline.resetTerminal Nothing
207 runGHCi :: [FilePath] -> DynFlags -> GHCi ()
208 runGHCi paths dflags = do
209 read_dot_files <- io (readIORef v_Read_DotGHCi)
211 when (read_dot_files) $ do
214 exists <- io (doesFileExist file)
216 dir_ok <- io (checkPerms ".")
217 file_ok <- io (checkPerms file)
218 when (dir_ok && file_ok) $ do
219 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
222 Right hdl -> fileLoop hdl False
224 when (read_dot_files) $ do
225 -- Read in $HOME/.ghci
226 either_dir <- io (IO.try (getEnv "HOME"))
230 cwd <- io (getCurrentDirectory)
231 when (dir /= cwd) $ do
232 let file = dir ++ "/.ghci"
233 ok <- io (checkPerms file)
235 either_hdl <- io (IO.try (openFile file ReadMode))
238 Right hdl -> fileLoop hdl False
240 -- perform a :load for files given on the GHCi command line
241 when (not (null paths)) $
242 ghciHandle showException $
243 loadModule (unwords paths)
245 -- enter the interactive loop
246 #if defined(mingw32_TARGET_OS)
247 -- always show prompt, since hIsTerminalDevice returns True for Consoles
248 -- only, which we may or may not be running under (cf. Emacs sub-shells.)
251 is_tty <- io (hIsTerminalDevice stdin)
252 interactiveLoop is_tty
256 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
259 interactiveLoop is_tty = do
260 -- ignore ^C exceptions caught here
261 ghciHandleDyn (\e -> case e of
262 Interrupted -> ghciUnblock (interactiveLoop is_tty)
263 _other -> return ()) $ do
265 -- read commands from stdin
266 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
269 else fileLoop stdin False -- turn off prompt for non-TTY input
271 fileLoop stdin is_tty
275 -- NOTE: We only read .ghci files if they are owned by the current user,
276 -- and aren't world writable. Otherwise, we could be accidentally
277 -- running code planted by a malicious third party.
279 -- Furthermore, We only read ./.ghci if . is owned by the current user
280 -- and isn't writable by anyone else. I think this is sufficient: we
281 -- don't need to check .. and ../.. etc. because "." always refers to
282 -- the same directory while a process is running.
284 checkPerms :: String -> IO Bool
286 #ifdef mingw32_TARGET_OS
289 DriverUtil.handle (\_ -> return False) $ do
290 st <- getFileStatus name
292 if fileOwner st /= me then do
293 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
296 let mode = fileMode st
297 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
298 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
300 putStrLn $ "*** WARNING: " ++ name ++
301 " is writable by someone else, IGNORING!"
306 fileLoop :: Handle -> Bool -> GHCi ()
307 fileLoop hdl prompt = do
308 cmstate <- getCmState
309 (mod,imports) <- io (cmGetContext cmstate)
310 when prompt (io (putStr (mkPrompt mod imports)))
311 l <- io (IO.try (hGetLine hdl))
313 Left e | isEOFError e -> return ()
314 | otherwise -> throw e
316 case remove_spaces l of
317 "" -> fileLoop hdl prompt
318 l -> do quit <- runCommand l
319 if quit then return () else fileLoop hdl prompt
321 stringLoop :: [String] -> GHCi ()
322 stringLoop [] = return ()
323 stringLoop (s:ss) = do
324 case remove_spaces s of
326 l -> do quit <- runCommand l
327 if quit then return () else stringLoop ss
329 mkPrompt toplevs exports
330 = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
332 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
333 readlineLoop :: GHCi ()
335 cmstate <- getCmState
336 (mod,imports) <- io (cmGetContext cmstate)
338 l <- io (readline (mkPrompt mod imports))
342 case remove_spaces l of
347 if quit then return () else readlineLoop
350 -- Top level exception handler, just prints out the exception
352 runCommand :: String -> GHCi Bool
354 ghciHandle ( \exception -> do
356 showException exception
361 showException (DynException dyn) =
362 case fromDynamic dyn of
363 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
364 Just Interrupted -> io (putStrLn "Interrupted.")
365 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
366 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
367 Just other_ghc_ex -> io (print other_ghc_ex)
369 showException other_exception
370 = io (putStrLn ("*** Exception: " ++ show other_exception))
372 doCommand (':' : command) = specialCommand command
374 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
377 runStmt :: String -> GHCi [Name]
379 | null (filter (not.isSpace) stmt) = return []
381 = do st <- getGHCiState
382 dflags <- io getDynFlags
383 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
384 (new_cmstate, result) <-
385 io $ withProgName (progname st) $ withArgs (args st) $
386 cmRunStmt (cmstate st) dflags' stmt
387 setGHCiState st{cmstate = new_cmstate}
389 CmRunFailed -> return []
390 CmRunException e -> showException e >> return []
391 CmRunOk names -> return names
393 -- possibly print the type and revert CAFs after evaluating an expression
395 = do b <- isOptionSet ShowType
396 cmstate <- getCmState
397 when b (mapM_ (showTypeOfName cmstate) names)
399 b <- isOptionSet RevertCAFs
400 io (when b revertCAFs)
404 showTypeOfName :: CmState -> Name -> GHCi ()
405 showTypeOfName cmstate n
406 = do maybe_str <- io (cmTypeOfName cmstate n)
409 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
411 flushEverything :: GHCi ()
413 = io $ do Monad.join (readIORef flush_stdout)
414 Monad.join (readIORef flush_stderr)
417 specialCommand :: String -> GHCi Bool
418 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
419 specialCommand str = do
420 let (cmd,rest) = break isSpace str
421 cmds <- io (readIORef commands)
422 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
423 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
424 ++ shortHelpText) >> return False)
425 [(_,f)] -> f (dropWhile isSpace rest)
426 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
427 " matches multiple commands (" ++
428 foldr1 (\a b -> a ++ ',':b) (map fst cs)
429 ++ ")") >> return False)
431 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
433 -----------------------------------------------------------------------------
436 help :: String -> GHCi ()
437 help _ = io (putStr helpText)
439 info :: String -> GHCi ()
440 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
443 init_cms <- getCmState
444 dflags <- io getDynFlags
446 infoThings cms [] = return cms
447 infoThings cms (name:names) = do
448 (cms, stuff) <- io (cmInfoThing cms dflags name)
449 io (putStrLn (showSDocForUser unqual (
450 vcat (intersperse (text "") (map showThing stuff))))
454 unqual = cmGetPrintUnqual init_cms
456 showThing (ty_thing, fixity)
457 = vcat [ text "-- " <> showTyThing ty_thing,
458 showFixity fixity (getName ty_thing),
459 ppr (ifaceTyThing ty_thing) ]
462 | fix == defaultFixity = empty
463 | otherwise = ppr fix <+>
464 (if isSymOcc (nameOccName name)
466 else char '`' <> ppr name <> char '`')
468 showTyThing (AClass cl)
469 = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
470 showTyThing (ATyCon ty)
472 = hcat [ppr ty, text " is a primitive type constructor"]
474 = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
475 showTyThing (AnId id)
476 = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
479 | isRecordSelector id =
480 case tyConClass_maybe (fieldLabelTyCon (
481 recordSelectorFieldLabel id)) of
482 Nothing -> text "record selector"
483 Just c -> text "method in class " <> ppr c
484 | isDataConWrapId id = text "data constructor"
485 | otherwise = text "variable"
487 -- also print out the source location for home things
489 | isHomePackageName name && isGoodSrcLoc loc
490 = hsep [ text ", defined at", ppr loc ]
493 where loc = nameSrcLoc name
495 cms <- infoThings init_cms names
499 addModule :: String -> GHCi ()
501 let files = words str
502 state <- getGHCiState
503 dflags <- io (getDynFlags)
504 io (revertCAFs) -- always revert CAFs on load/add.
505 let new_targets = files ++ targets state
506 graph <- io (cmDepAnal (cmstate state) dflags new_targets)
507 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
508 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
509 setContextAfterLoad mods
510 modulesLoadedMsg ok mods dflags
512 changeDirectory :: String -> GHCi ()
513 changeDirectory ('~':d) = do
514 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
515 io (setCurrentDirectory (tilde ++ '/':d))
516 changeDirectory d = io (setCurrentDirectory d)
518 defineMacro :: String -> GHCi ()
520 let (macro_name, definition) = break isSpace s
521 cmds <- io (readIORef commands)
523 then throwDyn (CmdLineError "invalid macro name")
525 if (macro_name `elem` map fst cmds)
526 then throwDyn (CmdLineError
527 ("command `" ++ macro_name ++ "' is already defined"))
530 -- give the expression a type signature, so we can be sure we're getting
531 -- something of the right type.
532 let new_expr = '(' : definition ++ ") :: String -> IO String"
534 -- compile the expression
536 dflags <- io getDynFlags
537 (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
538 setCmState new_cmstate
541 Just hv -> io (writeIORef commands --
542 ((macro_name, keepGoing (runMacro hv)) : cmds))
544 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
546 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
547 stringLoop (lines str)
549 undefineMacro :: String -> GHCi ()
550 undefineMacro macro_name = do
551 cmds <- io (readIORef commands)
552 if (macro_name `elem` map fst builtin_commands)
553 then throwDyn (CmdLineError
554 ("command `" ++ macro_name ++ "' cannot be undefined"))
556 if (macro_name `notElem` map fst cmds)
557 then throwDyn (CmdLineError
558 ("command `" ++ macro_name ++ "' not defined"))
560 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
563 loadModule :: String -> GHCi ()
564 loadModule str = timeIt (loadModule' str)
567 let files = words str
568 state <- getGHCiState
569 dflags <- io getDynFlags
571 -- do the dependency anal first, so that if it fails we don't throw
572 -- away the current set of modules.
573 graph <- io (cmDepAnal (cmstate state) dflags files)
575 -- Dependency anal ok, now unload everything
576 cmstate1 <- io (cmUnload (cmstate state) dflags)
577 setGHCiState state{ cmstate = cmstate1, targets = [] }
579 io (revertCAFs) -- always revert CAFs on load.
580 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
581 setGHCiState state{ cmstate = cmstate2, targets = files }
583 setContextAfterLoad mods
584 modulesLoadedMsg ok mods dflags
587 reloadModule :: String -> GHCi ()
589 state <- getGHCiState
590 dflags <- io getDynFlags
591 case targets state of
592 [] -> io (putStr "no current target\n")
594 -- do the dependency anal first, so that if it fails we don't throw
595 -- away the current set of modules.
596 graph <- io (cmDepAnal (cmstate state) dflags paths)
598 io (revertCAFs) -- always revert CAFs on reload.
600 <- io (cmLoadModules (cmstate state) dflags graph)
601 setGHCiState state{ cmstate=cmstate1 }
602 setContextAfterLoad mods
603 modulesLoadedMsg ok mods dflags
605 reloadModule _ = noArgs ":reload"
607 setContextAfterLoad [] = setContext prel
608 setContextAfterLoad (m:_) = do
609 cmstate <- getCmState
610 b <- io (cmModuleIsInterpreted cmstate m)
611 if b then setContext ('*':m) else setContext m
613 modulesLoadedMsg ok mods dflags =
614 when (verbosity dflags > 0) $ do
616 | null mods = text "none."
618 punctuate comma (map text mods)) <> text "."
621 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
623 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
626 typeOfExpr :: String -> GHCi ()
628 = do cms <- getCmState
629 dflags <- io getDynFlags
630 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
631 setCmState new_cmstate
634 Just tystr -> io (putStrLn tystr)
636 quit :: String -> GHCi Bool
639 shellEscape :: String -> GHCi Bool
640 shellEscape str = io (system str >> return False)
642 -----------------------------------------------------------------------------
643 -- Browing a module's contents
645 browseCmd :: String -> GHCi ()
648 ['*':m] | looksLikeModuleName m -> browseModule m False
649 [m] | looksLikeModuleName m -> browseModule m True
650 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
652 browseModule m exports_only = do
654 dflags <- io getDynFlags
656 is_interpreted <- io (cmModuleIsInterpreted cms m)
657 when (not is_interpreted && not exports_only) $
658 throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
660 -- temporarily set the context to the module we're interested in,
661 -- just so we can get an appropriate PrintUnqualified
662 (as,bs) <- io (cmGetContext cms)
663 cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m]
664 else cmSetContext cms dflags [m] [])
665 cms2 <- io (cmSetContext cms1 dflags as bs)
667 (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)
671 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
673 things' = filter wantToSee things
675 wantToSee (AnId id) = not (isDataConId id || isDataConWrapId id)
678 thing_names = map getName things
680 thingDecl thing@(AnId id) = ifaceTyThing thing
682 thingDecl thing@(AClass c) =
683 let rn_decl = ifaceTyThing thing in
685 ClassDecl { tcdSigs = cons } ->
686 rn_decl{ tcdSigs = filter methodIsVisible cons }
689 methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
691 thingDecl thing@(ATyCon t) =
692 let rn_decl = ifaceTyThing thing in
694 TyData { tcdCons = DataCons cons } ->
695 rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
698 conIsVisible (ConDecl n _ _ _ _ _) = n `elem` thing_names
700 io (putStrLn (showSDocForUser unqual (
701 vcat (map (ppr . thingDecl) things')))
706 -----------------------------------------------------------------------------
707 -- Setting the module context
710 | all sensible mods = fn mods
711 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
713 (fn, mods) = case str of
714 '+':stuff -> (addToContext, words stuff)
715 '-':stuff -> (removeFromContext, words stuff)
716 stuff -> (newContext, words stuff)
718 sensible ('*':m) = looksLikeModuleName m
719 sensible m = looksLikeModuleName m
723 dflags <- io getDynFlags
724 (as,bs) <- separate cms mods [] []
725 let bs' = if null as && prel `notElem` bs then prel:bs else bs
726 cms' <- io (cmSetContext cms dflags as bs')
729 separate cmstate [] as bs = return (as,bs)
730 separate cmstate (('*':m):ms) as bs = do
731 b <- io (cmModuleIsInterpreted cmstate m)
732 if b then separate cmstate ms (m:as) bs
733 else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
734 separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
739 addToContext mods = do
741 dflags <- io getDynFlags
742 (as,bs) <- io (cmGetContext cms)
744 (as',bs') <- separate cms mods [] []
746 let as_to_add = as' \\ (as ++ bs)
747 bs_to_add = bs' \\ (as ++ bs)
749 cms' <- io (cmSetContext cms dflags
750 (as ++ as_to_add) (bs ++ bs_to_add))
754 removeFromContext mods = do
756 dflags <- io getDynFlags
757 (as,bs) <- io (cmGetContext cms)
759 (as_to_remove,bs_to_remove) <- separate cms mods [] []
761 let as' = as \\ (as_to_remove ++ bs_to_remove)
762 bs' = bs \\ (as_to_remove ++ bs_to_remove)
764 cms' <- io (cmSetContext cms dflags as' bs')
767 ----------------------------------------------------------------------------
770 -- set options in the interpreter. Syntax is exactly the same as the
771 -- ghc command line, except that certain options aren't available (-C,
774 -- This is pretty fragile: most options won't work as expected. ToDo:
775 -- figure out which ones & disallow them.
777 setCmd :: String -> GHCi ()
779 = do st <- getGHCiState
780 let opts = options st
781 io $ putStrLn (showSDoc (
782 text "options currently set: " <>
785 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
789 ("args":args) -> setArgs args
790 ("prog":prog) -> setProg prog
791 wds -> setOptions wds
795 setGHCiState st{ args = args }
799 setGHCiState st{ progname = prog }
801 io (hPutStrLn stderr "syntax: :set prog <progname>")
804 do -- first, deal with the GHCi opts (+s, +t, etc.)
805 let (plus_opts, minus_opts) = partition isPlus wds
806 mapM_ setOpt plus_opts
808 -- now, the GHC flags
809 pkgs_before <- io (readIORef v_Packages)
810 leftovers <- io (processArgs static_flags minus_opts [])
811 pkgs_after <- io (readIORef v_Packages)
813 -- update things if the users wants more packages
814 when (pkgs_before /= pkgs_after) $
815 newPackages (pkgs_after \\ pkgs_before)
817 -- then, dynamic flags
820 leftovers <- processArgs dynamic_flags leftovers []
823 if (not (null leftovers))
824 then throwDyn (CmdLineError ("unrecognised flags: " ++
829 unsetOptions :: String -> GHCi ()
831 = do -- first, deal with the GHCi opts (+s, +t, etc.)
833 (minus_opts, rest1) = partition isMinus opts
834 (plus_opts, rest2) = partition isPlus rest1
836 if (not (null rest2))
837 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
840 mapM_ unsetOpt plus_opts
842 -- can't do GHC flags for now
843 if (not (null minus_opts))
844 then throwDyn (CmdLineError "can't unset GHC command-line flags")
847 isMinus ('-':s) = True
850 isPlus ('+':s) = True
854 = case strToGHCiOpt str of
855 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
856 Just o -> setOption o
859 = case strToGHCiOpt str of
860 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
861 Just o -> unsetOption o
863 strToGHCiOpt :: String -> (Maybe GHCiOption)
864 strToGHCiOpt "s" = Just ShowTiming
865 strToGHCiOpt "t" = Just ShowType
866 strToGHCiOpt "r" = Just RevertCAFs
867 strToGHCiOpt _ = Nothing
869 optToStr :: GHCiOption -> String
870 optToStr ShowTiming = "s"
871 optToStr ShowType = "t"
872 optToStr RevertCAFs = "r"
874 newPackages new_pkgs = do
875 state <- getGHCiState
876 dflags <- io getDynFlags
877 cmstate1 <- io (cmUnload (cmstate state) dflags)
878 setGHCiState state{ cmstate = cmstate1, targets = [] }
881 pkgs <- getPackageInfo
882 flushPackageCache pkgs
884 new_pkg_info <- getPackageDetails new_pkgs
885 mapM_ (linkPackage dflags) (reverse new_pkg_info)
887 setContextAfterLoad []
889 -----------------------------------------------------------------------------
894 ["modules" ] -> showModules
895 ["bindings"] -> showBindings
896 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
900 let mg = cmGetModuleGraph cms
901 ls = cmGetLinkables cms
902 maybe_linkables = map (findModuleLinkable_maybe ls)
903 (map (moduleName.ms_mod) mg)
904 zipWithM showModule mg maybe_linkables
907 showModule :: ModSummary -> Maybe Linkable -> GHCi ()
908 showModule m (Just l) = do
909 io (putStrLn (showModMsg (isObjectLinkable l) (ms_mod m) (ms_location m)))
910 showModule _ Nothing = panic "missing linkable"
915 unqual = cmGetPrintUnqual cms
916 showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
918 io (mapM_ showBinding (cmGetBindings cms))
921 -----------------------------------------------------------------------------
924 data GHCiState = GHCiState
928 targets :: [FilePath],
930 options :: [GHCiOption]
934 = ShowTiming -- show time/allocs after evaluation
935 | ShowType -- show the type of expressions
936 | RevertCAFs -- revert CAFs after every evaluation
939 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
940 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
942 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
944 startGHCi :: GHCi a -> GHCiState -> IO a
945 startGHCi g state = do ref <- newIORef state; unGHCi g ref
947 instance Monad GHCi where
948 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
949 return a = GHCi $ \s -> return a
951 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
952 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
953 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
955 getGHCiState = GHCi $ \r -> readIORef r
956 setGHCiState s = GHCi $ \r -> writeIORef r s
958 -- for convenience...
959 getCmState = getGHCiState >>= return . cmstate
960 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
962 isOptionSet :: GHCiOption -> GHCi Bool
964 = do st <- getGHCiState
965 return (opt `elem` options st)
967 setOption :: GHCiOption -> GHCi ()
969 = do st <- getGHCiState
970 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
972 unsetOption :: GHCiOption -> GHCi ()
974 = do st <- getGHCiState
975 setGHCiState (st{ options = filter (/= opt) (options st) })
978 io m = GHCi { unGHCi = \s -> m >>= return }
980 -----------------------------------------------------------------------------
981 -- recursive exception handlers
983 -- Don't forget to unblock async exceptions in the handler, or if we're
984 -- in an exception loop (eg. let a = error a in a) the ^C exception
985 -- may never be delivered. Thanks to Marcin for pointing out the bug.
987 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
988 ghciHandle h (GHCi m) = GHCi $ \s ->
989 Exception.catch (m s)
990 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
992 ghciUnblock :: GHCi a -> GHCi a
993 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
995 -----------------------------------------------------------------------------
998 -- Left: full path name of a .o file, including trailing .o
999 -- Right: "unadorned" name of a .DLL/.so
1000 -- e.g. On unix "qt" denotes "libqt.so"
1001 -- On WinDoze "burble" denotes "burble.DLL"
1002 -- addDLL is platform-specific and adds the lib/.so/.DLL
1003 -- suffixes platform-dependently; we don't do that here.
1005 -- For dynamic objects only, try to find the object file in all the
1006 -- directories specified in v_Library_Paths before giving up.
1008 data LibrarySpec = Object FilePath | DLL String
1009 #ifdef darwin_TARGET_OS
1013 -- Packages that don't need loading, because the compiler shares them with
1014 -- the interpreted program.
1015 dont_load_these = [ "rts" ]
1017 -- Packages that are already linked into GHCi. For mingw32, we only
1018 -- skip gmp and rts, since std and after need to load the msvcrt.dll
1019 -- library which std depends on.
1021 # ifndef mingw32_TARGET_OS
1022 = [ "std", "concurrent", "posix", "text", "util" ]
1027 showLS (Object nm) = "(static) " ++ nm
1028 showLS (DLL nm) = "(dynamic) " ++ nm
1029 #ifdef darwin_TARGET_OS
1030 showLS (Framework nm) = "(framework) " ++ nm
1033 linkPackages :: DynFlags -> [LibrarySpec] -> [PackageConfig] -> IO ()
1034 linkPackages dflags cmdline_lib_specs pkgs
1035 = do mapM_ (linkPackage dflags) (reverse pkgs)
1036 lib_paths <- readIORef v_Library_paths
1037 mapM_ (preloadLib dflags lib_paths) cmdline_lib_specs
1038 if (null cmdline_lib_specs)
1040 else do maybePutStr dflags "final link ... "
1043 if ok then maybePutStrLn dflags "done."
1044 else throwDyn (InstallationError
1045 "linking extra libraries/objects failed")
1047 preloadLib :: DynFlags -> [String] -> LibrarySpec -> IO ()
1048 preloadLib dflags lib_paths lib_spec
1049 = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
1052 -> do b <- preload_static lib_paths static_ish
1053 maybePutStrLn dflags (if b then "done."
1056 -> -- We add "" to the set of paths to try, so that
1057 -- if none of the real paths match, we force addDLL
1058 -- to look in the default dynamic-link search paths.
1059 do maybe_errstr <- loadDynamic (lib_paths++[""])
1061 case maybe_errstr of
1062 Nothing -> return ()
1063 Just mm -> preloadFailed mm lib_paths lib_spec
1064 maybePutStrLn dflags "done"
1066 preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
1067 preloadFailed sys_errmsg paths spec
1068 = do maybePutStr dflags
1069 ("failed.\nDynamic linker error message was:\n "
1070 ++ sys_errmsg ++ "\nWhilst trying to load: "
1071 ++ showLS spec ++ "\nDirectories to search are:\n"
1072 ++ unlines (map (" "++) paths) )
1075 -- not interested in the paths in the static case.
1076 preload_static paths name
1077 = do b <- doesFileExist name
1078 if not b then return False
1079 else loadObj name >> return True
1082 = (throwDyn . CmdLineError)
1083 "user specified .o/.so/.DLL could not be loaded."
1085 linkPackage :: DynFlags -> PackageConfig -> IO ()
1086 linkPackage dflags pkg
1087 | name pkg `elem` dont_load_these = return ()
1090 let dirs = library_dirs pkg
1091 let libs = hs_libraries pkg ++ extra_libraries pkg
1092 classifieds <- mapM (locateOneObj dirs) libs
1093 #ifdef darwin_TARGET_OS
1094 let fwDirs = framework_dirs pkg
1095 let frameworks= extra_frameworks pkg
1098 -- Complication: all the .so's must be loaded before any of the .o's.
1099 let dlls = [ dll | DLL dll <- classifieds ]
1100 objs = [ obj | Object obj <- classifieds ]
1102 maybePutStr dflags ("Loading package " ++ name pkg ++ " ... ")
1104 -- If this package is already part of the GHCi binary, we'll already
1105 -- have the right DLLs for this package loaded, so don't try to
1107 when (name pkg `notElem` loaded_in_ghci) $ do
1108 #ifdef darwin_TARGET_OS
1109 loadFrameworks fwDirs frameworks
1111 loadDynamics dirs dlls
1113 -- After loading all the DLLs, we can load the static objects.
1116 maybePutStr dflags "linking ... "
1118 if ok then maybePutStrLn dflags "done."
1119 else panic ("can't load package `" ++ name pkg ++ "'")
1121 loadDynamics dirs [] = return ()
1122 loadDynamics dirs (dll:dlls) = do
1123 r <- loadDynamic dirs dll
1125 Nothing -> loadDynamics dirs dlls
1126 Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: "
1127 ++ dll ++ " (" ++ err ++ ")" ))
1128 #ifdef darwin_TARGET_OS
1129 loadFrameworks dirs [] = return ()
1130 loadFrameworks dirs (fw:fws) = do
1131 r <- loadFramework dirs fw
1133 Nothing -> loadFrameworks dirs fws
1134 Just err -> throwDyn (CmdLineError ("can't load framework: "
1135 ++ fw ++ " (" ++ err ++ ")" ))
1138 -- Try to find an object file for a given library in the given paths.
1139 -- If it isn't present, we assume it's a dynamic library.
1140 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1142 = return (DLL lib) -- we assume
1143 locateOneObj (d:ds) lib
1144 = do let path = d ++ '/':lib ++ ".o"
1145 b <- doesFileExist path
1146 if b then return (Object path) else locateOneObj ds lib
1148 -- ----------------------------------------------------------------------------
1149 -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
1151 #if defined(mingw32_TARGET_OS) || defined(cygwin32_TARGET_OS)
1152 loadDynamic paths rootname = addDLL rootname
1153 -- ignore paths on windows (why? --SDM)
1157 -- return Nothing == success, else Just error message from dlopen
1158 loadDynamic (path:paths) rootname = do
1159 let dll = path ++ '/':mkSOName rootname
1160 b <- doesFileExist dll
1162 then loadDynamic paths rootname
1164 loadDynamic [] rootname = do
1165 -- tried all our known library paths, let dlopen() search its
1166 -- own builtin paths now.
1167 addDLL (mkSOName rootname)
1169 #ifdef darwin_TARGET_OS
1170 mkSOName root = "lib" ++ root ++ ".dylib"
1172 mkSOName root = "lib" ++ root ++ ".so"
1177 -- Darwin / MacOS X only: load a framework
1178 -- a framework is a dynamic library packaged inside a directory of the same
1179 -- name. They are searched for in different paths than normal libraries.
1180 #ifdef darwin_TARGET_OS
1181 loadFramework extraPaths rootname
1182 = loadFramework' (extraPaths ++ defaultFrameworkPaths) where
1183 defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
1185 loadFramework' (path:paths) = do
1186 let dll = path ++ '/' : rootname ++ ".framework/" ++ rootname
1187 b <- doesFileExist dll
1189 then loadFramework' paths
1191 loadFramework' [] = do
1192 -- tried all our known library paths, but dlopen()
1193 -- has no built-in paths for frameworks: give up
1194 return $ Just $ "not found"
1197 addDLL :: String -> IO (Maybe String)
1199 maybe_errmsg <- withCString str $ \dll -> c_addDLL dll
1200 if maybe_errmsg == nullPtr
1202 else do str <- peekCString maybe_errmsg
1205 foreign import ccall "addDLL" unsafe
1206 c_addDLL :: CString -> IO CString
1208 -----------------------------------------------------------------------------
1209 -- timing & statistics
1211 timeIt :: GHCi a -> GHCi a
1213 = do b <- isOptionSet ShowTiming
1216 else do allocs1 <- io $ getAllocations
1217 time1 <- io $ getCPUTime
1219 allocs2 <- io $ getAllocations
1220 time2 <- io $ getCPUTime
1221 io $ printTimes (allocs2 - allocs1) (time2 - time1)
1224 foreign import "getAllocations" getAllocations :: IO Int
1226 printTimes :: Int -> Integer -> IO ()
1227 printTimes allocs psecs
1228 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1229 secs_str = showFFloat (Just 2) secs
1230 putStrLn (showSDoc (
1231 parens (text (secs_str "") <+> text "secs" <> comma <+>
1232 int allocs <+> text "bytes")))
1234 -----------------------------------------------------------------------------
1237 looksLikeModuleName [] = False
1238 looksLikeModuleName (c:cs) = isUpper c && all isAlphaNumEx cs
1240 isAlphaNumEx c = isAlphaNum c || c == '_' || c == '.'
1242 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1243 | otherwise = return ()
1245 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1246 | otherwise = return ()
1248 -----------------------------------------------------------------------------
1251 foreign import revertCAFs :: IO () -- make it "safe", just in case