1 {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.135 2002/10/14 14:54:16 simonmar Exp $
5 -- GHC Interactive User Interface
7 -- (c) The GHC Team 2000
9 -----------------------------------------------------------------------------
10 module InteractiveUI (
11 interactiveUI, -- :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
15 #include "../includes/config.h"
16 #include "HsVersions.h"
19 import HscTypes ( TyThing(..), HomeModInfo(hm_linkable), HomePackageTable,
21 import HsSyn ( TyClDecl(..), ConDecl(..), Sig(..) )
22 import MkIface ( ifaceTyThing )
25 import DriverUtil ( remove_spaces, handle )
26 import Linker ( initLinker, showLinkerState, linkLibraries )
27 import Finder ( flushPackageCache )
29 import Id ( isRecordSelector, recordSelectorFieldLabel,
30 isDataConWrapId, isDataConId, idName )
31 import Class ( className )
32 import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) )
33 import FieldLabel ( fieldLabelTyCon )
34 import SrcLoc ( isGoodSrcLoc )
35 import Module ( showModMsg, lookupModuleEnv )
36 import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName,
38 import OccName ( isSymOcc )
39 import BasicTypes ( defaultFixity, SuccessFlag(..) )
41 import CmdLineOpts ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags,
42 restoreDynFlags, dopt_unset )
43 import Panic ( GhcException(..), showGhcException )
46 #ifndef mingw32_TARGET_OS
50 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
51 import Control.Concurrent ( yield ) -- Used in readline loop
52 import System.Console.Readline as Readline
57 import Control.Exception as Exception
59 import Control.Concurrent
65 import System.Environment
66 import System.Directory
67 import System.IO as IO
69 import Control.Monad as Monad
71 import GHC.Exts ( unsafeCoerce# )
73 import Foreign ( nullPtr )
74 import Foreign.C.String ( CString, peekCString, withCString )
75 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
77 import GHC.Posix ( setNonBlockingFD )
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] -> [FilePath] -> IO ()
153 interactiveUI cmstate paths cmdline_objs = do
155 hSetBuffering stdout NoBuffering
157 dflags <- getDynFlags
159 -- Link in the available packages
161 -- Now that demand-loading works, we don't really need to pre-load the packages
162 -- pkgs <- getPackages
163 -- linkPackages dflags pkgs
164 linkLibraries dflags cmdline_objs
166 -- Initialise buffering for the *interpreted* I/O system
167 cmstate <- initInterpBuffering cmstate dflags
169 -- We don't want the cmd line to buffer any input that might be
170 -- intended for the program, so unbuffer stdin.
171 hSetBuffering stdin NoBuffering
173 -- initial context is just the Prelude
174 cmstate <- cmSetContext cmstate dflags [] ["Prelude"]
176 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
180 startGHCi (runGHCi paths dflags)
181 GHCiState{ progname = "<interactive>",
187 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
188 Readline.resetTerminal Nothing
193 runGHCi :: [FilePath] -> DynFlags -> GHCi ()
194 runGHCi paths dflags = do
195 read_dot_files <- io (readIORef v_Read_DotGHCi)
197 when (read_dot_files) $ do
200 exists <- io (doesFileExist file)
202 dir_ok <- io (checkPerms ".")
203 file_ok <- io (checkPerms file)
204 when (dir_ok && file_ok) $ do
205 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
208 Right hdl -> fileLoop hdl False
210 when (read_dot_files) $ do
211 -- Read in $HOME/.ghci
212 either_dir <- io (IO.try (getEnv "HOME"))
216 cwd <- io (getCurrentDirectory)
217 when (dir /= cwd) $ do
218 let file = dir ++ "/.ghci"
219 ok <- io (checkPerms file)
221 either_hdl <- io (IO.try (openFile file ReadMode))
224 Right hdl -> fileLoop hdl False
226 -- perform a :load for files given on the GHCi command line
227 when (not (null paths)) $
228 ghciHandle showException $
229 loadModule (unwords paths)
231 -- enter the interactive loop
232 #if defined(mingw32_TARGET_OS)
233 -- always show prompt, since hIsTerminalDevice returns True for Consoles
234 -- only, which we may or may not be running under (cf. Emacs sub-shells.)
237 is_tty <- io (hIsTerminalDevice stdin)
238 interactiveLoop is_tty
242 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
245 interactiveLoop is_tty = do
246 -- ignore ^C exceptions caught here
247 ghciHandleDyn (\e -> case e of
248 Interrupted -> ghciUnblock (interactiveLoop is_tty)
249 _other -> return ()) $ do
251 -- read commands from stdin
252 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
255 else fileLoop stdin False -- turn off prompt for non-TTY input
257 fileLoop stdin is_tty
261 -- NOTE: We only read .ghci files if they are owned by the current user,
262 -- and aren't world writable. Otherwise, we could be accidentally
263 -- running code planted by a malicious third party.
265 -- Furthermore, We only read ./.ghci if . is owned by the current user
266 -- and isn't writable by anyone else. I think this is sufficient: we
267 -- don't need to check .. and ../.. etc. because "." always refers to
268 -- the same directory while a process is running.
270 checkPerms :: String -> IO Bool
272 #ifdef mingw32_TARGET_OS
275 DriverUtil.handle (\_ -> return False) $ do
276 st <- getFileStatus name
278 if fileOwner st /= me then do
279 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
282 let mode = fileMode st
283 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
284 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
286 putStrLn $ "*** WARNING: " ++ name ++
287 " is writable by someone else, IGNORING!"
292 fileLoop :: Handle -> Bool -> GHCi ()
293 fileLoop hdl prompt = do
294 cmstate <- getCmState
295 (mod,imports) <- io (cmGetContext cmstate)
296 when prompt (io (putStr (mkPrompt mod imports)))
297 l <- io (IO.try (hGetLine hdl))
299 Left e | isEOFError e -> return ()
300 | otherwise -> throw e
302 case remove_spaces l of
303 "" -> fileLoop hdl prompt
304 l -> do quit <- runCommand l
305 if quit then return () else fileLoop hdl prompt
307 stringLoop :: [String] -> GHCi ()
308 stringLoop [] = return ()
309 stringLoop (s:ss) = do
310 case remove_spaces s of
312 l -> do quit <- runCommand l
313 if quit then return () else stringLoop ss
315 mkPrompt toplevs exports
316 = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
318 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
319 readlineLoop :: GHCi ()
321 cmstate <- getCmState
322 (mod,imports) <- io (cmGetContext cmstate)
324 l <- io (readline (mkPrompt mod imports)
325 `finally` setNonBlockingFD 0)
326 -- readline sometimes puts stdin into blocking mode,
327 -- so we need to put it back for the IO library
331 case remove_spaces l of
336 if quit then return () else readlineLoop
339 -- Top level exception handler, just prints out the exception
341 runCommand :: String -> GHCi Bool
343 ghciHandle ( \exception -> do
345 showException exception
350 showException (DynException dyn) =
351 case fromDynamic dyn of
352 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
353 Just Interrupted -> io (putStrLn "Interrupted.")
354 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
355 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
356 Just other_ghc_ex -> io (print other_ghc_ex)
358 showException other_exception
359 = io (putStrLn ("*** Exception: " ++ show other_exception))
361 doCommand (':' : command) = specialCommand command
363 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
366 runStmt :: String -> GHCi [Name]
368 | null (filter (not.isSpace) stmt) = return []
370 = do st <- getGHCiState
371 dflags <- io getDynFlags
372 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
373 (new_cmstate, result) <-
374 io $ withProgName (progname st) $ withArgs (args st) $
375 cmRunStmt (cmstate st) dflags' stmt
376 setGHCiState st{cmstate = new_cmstate}
378 CmRunFailed -> return []
379 CmRunException e -> showException e >> return []
380 CmRunOk names -> return names
382 -- possibly print the type and revert CAFs after evaluating an expression
384 = do b <- isOptionSet ShowType
385 cmstate <- getCmState
386 when b (mapM_ (showTypeOfName cmstate) names)
389 b <- isOptionSet RevertCAFs
390 io (when b revertCAFs)
393 showTypeOfName :: CmState -> Name -> GHCi ()
394 showTypeOfName cmstate n
395 = do maybe_str <- io (cmTypeOfName cmstate n)
398 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
400 specialCommand :: String -> GHCi Bool
401 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
402 specialCommand str = do
403 let (cmd,rest) = break isSpace str
404 cmds <- io (readIORef commands)
405 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
406 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
407 ++ shortHelpText) >> return False)
408 [(_,f)] -> f (dropWhile isSpace rest)
409 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
410 " matches multiple commands (" ++
411 foldr1 (\a b -> a ++ ',':b) (map fst cs)
412 ++ ")") >> return False)
414 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
417 -----------------------------------------------------------------------------
418 -- To flush buffers for the *interpreted* computation we need
419 -- to refer to *its* stdout/stderr handles
421 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
422 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
424 no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++
425 " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
426 flush_cmd = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr"
428 initInterpBuffering :: CmState -> DynFlags -> IO CmState
429 initInterpBuffering cmstate dflags
430 = do (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags no_buf_cmd
433 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
434 other -> panic "interactiveUI:setBuffering"
436 (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags flush_cmd
438 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
439 _ -> panic "interactiveUI:flush"
441 turnOffBuffering -- Turn it off right now
446 flushInterpBuffers :: GHCi ()
448 = io $ do Monad.join (readIORef flush_interp)
451 turnOffBuffering :: IO ()
453 = do Monad.join (readIORef turn_off_buffering)
456 -----------------------------------------------------------------------------
459 help :: String -> GHCi ()
460 help _ = io (putStr helpText)
462 info :: String -> GHCi ()
463 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
466 init_cms <- getCmState
467 dflags <- io getDynFlags
469 infoThings cms [] = return cms
470 infoThings cms (name:names) = do
471 (cms, stuff) <- io (cmInfoThing cms dflags name)
472 io (putStrLn (showSDocForUser unqual (
473 vcat (intersperse (text "") (map showThing stuff))))
477 unqual = cmGetPrintUnqual init_cms
479 showThing (ty_thing, fixity)
480 = vcat [ text "-- " <> showTyThing ty_thing,
481 showFixity fixity (getName ty_thing),
482 ppr (ifaceTyThing ty_thing) ]
485 | fix == defaultFixity = empty
486 | otherwise = ppr fix <+>
487 (if isSymOcc (nameOccName name)
489 else char '`' <> ppr name <> char '`')
491 showTyThing (AClass cl)
492 = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
493 showTyThing (ATyCon ty)
495 = hcat [ppr ty, text " is a primitive type constructor"]
497 = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
498 showTyThing (AnId id)
499 = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
502 | isRecordSelector id =
503 case tyConClass_maybe (fieldLabelTyCon (
504 recordSelectorFieldLabel id)) of
505 Nothing -> text "record selector"
506 Just c -> text "method in class " <> ppr c
507 | isDataConWrapId id = text "data constructor"
508 | otherwise = text "variable"
510 -- also print out the source location for home things
512 | isHomePackageName name && isGoodSrcLoc loc
513 = hsep [ text ", defined at", ppr loc ]
516 where loc = nameSrcLoc name
518 cms <- infoThings init_cms names
522 addModule :: String -> GHCi ()
524 let files = words str
525 state <- getGHCiState
526 dflags <- io (getDynFlags)
527 io (revertCAFs) -- always revert CAFs on load/add.
528 let new_targets = files ++ targets state
529 graph <- io (cmDepAnal (cmstate state) dflags new_targets)
530 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
531 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
532 setContextAfterLoad mods
533 modulesLoadedMsg ok mods dflags
535 changeDirectory :: String -> GHCi ()
536 changeDirectory ('~':d) = do
537 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
538 io (setCurrentDirectory (tilde ++ '/':d))
539 changeDirectory d = io (setCurrentDirectory d)
541 defineMacro :: String -> GHCi ()
543 let (macro_name, definition) = break isSpace s
544 cmds <- io (readIORef commands)
546 then throwDyn (CmdLineError "invalid macro name")
548 if (macro_name `elem` map fst cmds)
549 then throwDyn (CmdLineError
550 ("command `" ++ macro_name ++ "' is already defined"))
553 -- give the expression a type signature, so we can be sure we're getting
554 -- something of the right type.
555 let new_expr = '(' : definition ++ ") :: String -> IO String"
557 -- compile the expression
559 dflags <- io getDynFlags
560 (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
561 setCmState new_cmstate
564 Just hv -> io (writeIORef commands --
565 ((macro_name, keepGoing (runMacro hv)) : cmds))
567 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
569 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
570 stringLoop (lines str)
572 undefineMacro :: String -> GHCi ()
573 undefineMacro macro_name = do
574 cmds <- io (readIORef commands)
575 if (macro_name `elem` map fst builtin_commands)
576 then throwDyn (CmdLineError
577 ("command `" ++ macro_name ++ "' cannot be undefined"))
579 if (macro_name `notElem` map fst cmds)
580 then throwDyn (CmdLineError
581 ("command `" ++ macro_name ++ "' not defined"))
583 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
586 loadModule :: String -> GHCi ()
587 loadModule str = timeIt (loadModule' str)
590 let files = words str
591 state <- getGHCiState
592 dflags <- io getDynFlags
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 files)
598 -- Dependency anal ok, now unload everything
599 cmstate1 <- io (cmUnload (cmstate state) dflags)
600 setGHCiState state{ cmstate = cmstate1, targets = [] }
602 io (revertCAFs) -- always revert CAFs on load.
603 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
604 setGHCiState state{ cmstate = cmstate2, targets = files }
606 setContextAfterLoad mods
607 modulesLoadedMsg ok mods dflags
610 reloadModule :: String -> GHCi ()
612 state <- getGHCiState
613 dflags <- io getDynFlags
614 case targets state of
615 [] -> io (putStr "no current target\n")
617 -- do the dependency anal first, so that if it fails we don't throw
618 -- away the current set of modules.
619 graph <- io (cmDepAnal (cmstate state) dflags paths)
621 io (revertCAFs) -- always revert CAFs on reload.
623 <- io (cmLoadModules (cmstate state) dflags graph)
624 setGHCiState state{ cmstate=cmstate1 }
625 setContextAfterLoad mods
626 modulesLoadedMsg ok mods dflags
628 reloadModule _ = noArgs ":reload"
630 setContextAfterLoad [] = setContext prel
631 setContextAfterLoad (m:_) = do
632 cmstate <- getCmState
633 b <- io (cmModuleIsInterpreted cmstate m)
634 if b then setContext ('*':m) else setContext m
636 modulesLoadedMsg ok mods dflags =
637 when (verbosity dflags > 0) $ do
639 | null mods = text "none."
641 punctuate comma (map text mods)) <> text "."
644 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
646 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
649 typeOfExpr :: String -> GHCi ()
651 = do cms <- getCmState
652 dflags <- io getDynFlags
653 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
654 setCmState new_cmstate
657 Just tystr -> io (putStrLn tystr)
659 quit :: String -> GHCi Bool
662 shellEscape :: String -> GHCi Bool
663 shellEscape str = io (system str >> return False)
665 -----------------------------------------------------------------------------
666 -- Browing a module's contents
668 browseCmd :: String -> GHCi ()
671 ['*':m] | looksLikeModuleName m -> browseModule m False
672 [m] | looksLikeModuleName m -> browseModule m True
673 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
675 browseModule m exports_only = do
677 dflags <- io getDynFlags
679 is_interpreted <- io (cmModuleIsInterpreted cms m)
680 when (not is_interpreted && not exports_only) $
681 throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
683 -- temporarily set the context to the module we're interested in,
684 -- just so we can get an appropriate PrintUnqualified
685 (as,bs) <- io (cmGetContext cms)
686 cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m]
687 else cmSetContext cms dflags [m] [])
688 cms2 <- io (cmSetContext cms1 dflags as bs)
690 (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)
694 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
696 things' = filter wantToSee things
698 wantToSee (AnId id) = not (isDataConId id || isDataConWrapId id)
701 thing_names = map getName things
703 thingDecl thing@(AnId id) = ifaceTyThing thing
705 thingDecl thing@(AClass c) =
706 let rn_decl = ifaceTyThing thing in
708 ClassDecl { tcdSigs = cons } ->
709 rn_decl{ tcdSigs = filter methodIsVisible cons }
712 methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
714 thingDecl thing@(ATyCon t) =
715 let rn_decl = ifaceTyThing thing in
717 TyData { tcdCons = DataCons cons } ->
718 rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
721 conIsVisible (ConDecl n _ _ _ _) = n `elem` thing_names
723 io (putStrLn (showSDocForUser unqual (
724 vcat (map (ppr . thingDecl) things')))
729 -----------------------------------------------------------------------------
730 -- Setting the module context
733 | all sensible mods = fn mods
734 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
736 (fn, mods) = case str of
737 '+':stuff -> (addToContext, words stuff)
738 '-':stuff -> (removeFromContext, words stuff)
739 stuff -> (newContext, words stuff)
741 sensible ('*':m) = looksLikeModuleName m
742 sensible m = looksLikeModuleName m
746 dflags <- io getDynFlags
747 (as,bs) <- separate cms mods [] []
748 let bs' = if null as && prel `notElem` bs then prel:bs else bs
749 cms' <- io (cmSetContext cms dflags as bs')
752 separate cmstate [] as bs = return (as,bs)
753 separate cmstate (('*':m):ms) as bs = do
754 b <- io (cmModuleIsInterpreted cmstate m)
755 if b then separate cmstate ms (m:as) bs
756 else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
757 separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
762 addToContext mods = do
764 dflags <- io getDynFlags
765 (as,bs) <- io (cmGetContext cms)
767 (as',bs') <- separate cms mods [] []
769 let as_to_add = as' \\ (as ++ bs)
770 bs_to_add = bs' \\ (as ++ bs)
772 cms' <- io (cmSetContext cms dflags
773 (as ++ as_to_add) (bs ++ bs_to_add))
777 removeFromContext mods = do
779 dflags <- io getDynFlags
780 (as,bs) <- io (cmGetContext cms)
782 (as_to_remove,bs_to_remove) <- separate cms mods [] []
784 let as' = as \\ (as_to_remove ++ bs_to_remove)
785 bs' = bs \\ (as_to_remove ++ bs_to_remove)
787 cms' <- io (cmSetContext cms dflags as' bs')
790 ----------------------------------------------------------------------------
793 -- set options in the interpreter. Syntax is exactly the same as the
794 -- ghc command line, except that certain options aren't available (-C,
797 -- This is pretty fragile: most options won't work as expected. ToDo:
798 -- figure out which ones & disallow them.
800 setCmd :: String -> GHCi ()
802 = do st <- getGHCiState
803 let opts = options st
804 io $ putStrLn (showSDoc (
805 text "options currently set: " <>
808 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
812 ("args":args) -> setArgs args
813 ("prog":prog) -> setProg prog
814 wds -> setOptions wds
818 setGHCiState st{ args = args }
822 setGHCiState st{ progname = prog }
824 io (hPutStrLn stderr "syntax: :set prog <progname>")
827 do -- first, deal with the GHCi opts (+s, +t, etc.)
828 let (plus_opts, minus_opts) = partition isPlus wds
829 mapM_ setOpt plus_opts
831 -- now, the GHC flags
832 pkgs_before <- io (readIORef v_Packages)
833 leftovers <- io (processArgs static_flags minus_opts [])
834 pkgs_after <- io (readIORef v_Packages)
836 -- update things if the users wants more packages
837 when (pkgs_before /= pkgs_after) $
838 newPackages (pkgs_after \\ pkgs_before)
840 -- then, dynamic flags
843 leftovers <- processArgs dynamic_flags leftovers []
846 if (not (null leftovers))
847 then throwDyn (CmdLineError ("unrecognised flags: " ++
852 unsetOptions :: String -> GHCi ()
854 = do -- first, deal with the GHCi opts (+s, +t, etc.)
856 (minus_opts, rest1) = partition isMinus opts
857 (plus_opts, rest2) = partition isPlus rest1
859 if (not (null rest2))
860 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
863 mapM_ unsetOpt plus_opts
865 -- can't do GHC flags for now
866 if (not (null minus_opts))
867 then throwDyn (CmdLineError "can't unset GHC command-line flags")
870 isMinus ('-':s) = True
873 isPlus ('+':s) = True
877 = case strToGHCiOpt str of
878 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
879 Just o -> setOption o
882 = case strToGHCiOpt str of
883 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
884 Just o -> unsetOption o
886 strToGHCiOpt :: String -> (Maybe GHCiOption)
887 strToGHCiOpt "s" = Just ShowTiming
888 strToGHCiOpt "t" = Just ShowType
889 strToGHCiOpt "r" = Just RevertCAFs
890 strToGHCiOpt _ = Nothing
892 optToStr :: GHCiOption -> String
893 optToStr ShowTiming = "s"
894 optToStr ShowType = "t"
895 optToStr RevertCAFs = "r"
897 newPackages new_pkgs = do -- The new packages are already in v_Packages
898 state <- getGHCiState
899 dflags <- io getDynFlags
900 cmstate1 <- io (cmUnload (cmstate state) dflags)
901 setGHCiState state{ cmstate = cmstate1, targets = [] }
903 io $ do pkgs <- getPackageInfo
904 flushPackageCache pkgs
906 setContextAfterLoad []
908 -----------------------------------------------------------------------------
913 ["modules" ] -> showModules
914 ["bindings"] -> showBindings
915 ["linker"] -> io showLinkerState
916 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
920 let (mg, hpt) = cmGetModInfo cms
921 mapM_ (showModule hpt) mg
924 showModule :: HomePackageTable -> ModSummary -> GHCi ()
925 showModule hpt mod_summary
926 = case lookupModuleEnv hpt mod of
927 Nothing -> panic "missing linkable"
928 Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
930 obj_linkable = isObjectLinkable (hm_linkable mod_info)
932 mod = ms_mod mod_summary
933 locn = ms_location mod_summary
938 unqual = cmGetPrintUnqual cms
939 showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
941 io (mapM_ showBinding (cmGetBindings cms))
945 -----------------------------------------------------------------------------
948 data GHCiState = GHCiState
952 targets :: [FilePath],
954 options :: [GHCiOption]
958 = ShowTiming -- show time/allocs after evaluation
959 | ShowType -- show the type of expressions
960 | RevertCAFs -- revert CAFs after every evaluation
963 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
965 startGHCi :: GHCi a -> GHCiState -> IO a
966 startGHCi g state = do ref <- newIORef state; unGHCi g ref
968 instance Monad GHCi where
969 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
970 return a = GHCi $ \s -> return a
972 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
973 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
974 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
976 getGHCiState = GHCi $ \r -> readIORef r
977 setGHCiState s = GHCi $ \r -> writeIORef r s
979 -- for convenience...
980 getCmState = getGHCiState >>= return . cmstate
981 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
983 isOptionSet :: GHCiOption -> GHCi Bool
985 = do st <- getGHCiState
986 return (opt `elem` options st)
988 setOption :: GHCiOption -> GHCi ()
990 = do st <- getGHCiState
991 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
993 unsetOption :: GHCiOption -> GHCi ()
995 = do st <- getGHCiState
996 setGHCiState (st{ options = filter (/= opt) (options st) })
999 io m = GHCi { unGHCi = \s -> m >>= return }
1001 -----------------------------------------------------------------------------
1002 -- recursive exception handlers
1004 -- Don't forget to unblock async exceptions in the handler, or if we're
1005 -- in an exception loop (eg. let a = error a in a) the ^C exception
1006 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1008 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1009 ghciHandle h (GHCi m) = GHCi $ \s ->
1010 Exception.catch (m s)
1011 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
1013 ghciUnblock :: GHCi a -> GHCi a
1014 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1016 -----------------------------------------------------------------------------
1017 -- timing & statistics
1019 timeIt :: GHCi a -> GHCi a
1021 = do b <- isOptionSet ShowTiming
1024 else do allocs1 <- io $ getAllocations
1025 time1 <- io $ getCPUTime
1027 allocs2 <- io $ getAllocations
1028 time2 <- io $ getCPUTime
1029 io $ printTimes (allocs2 - allocs1) (time2 - time1)
1032 foreign import ccall "getAllocations" getAllocations :: IO Int
1034 printTimes :: Int -> Integer -> IO ()
1035 printTimes allocs psecs
1036 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1037 secs_str = showFFloat (Just 2) secs
1038 putStrLn (showSDoc (
1039 parens (text (secs_str "") <+> text "secs" <> comma <+>
1040 int allocs <+> text "bytes")))
1042 -----------------------------------------------------------------------------
1045 looksLikeModuleName [] = False
1046 looksLikeModuleName (c:cs) = isUpper c && all isAlphaNumEx cs
1048 isAlphaNumEx c = isAlphaNum c || c == '_' || c == '.'
1050 -----------------------------------------------------------------------------
1057 -- Have to turn off buffering again, because we just
1058 -- reverted stdout, stderr & stdin to their defaults.
1060 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1061 -- Make it "safe", just in case