1 {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.134 2002/09/13 15:02:32 simonpj 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 -----------------------------------------------------------------------------
81 \ / _ \\ /\\ /\\/ __(_)\n\
82 \ / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
83 \/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n\
84 \\\____/\\/ /_/\\____/|_| Type :? for help.\n"
86 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
88 builtin_commands :: [(String, String -> GHCi Bool)]
90 ("add", keepGoing addModule),
91 ("browse", keepGoing browseCmd),
92 ("cd", keepGoing changeDirectory),
93 ("def", keepGoing defineMacro),
94 ("help", keepGoing help),
95 ("?", keepGoing help),
96 ("info", keepGoing info),
97 ("load", keepGoing loadModule),
98 ("module", keepGoing setContext),
99 ("reload", keepGoing reloadModule),
100 ("set", keepGoing setCmd),
101 ("show", keepGoing showCmd),
102 ("type", keepGoing typeOfExpr),
103 ("unset", keepGoing unsetOptions),
104 ("undef", keepGoing undefineMacro),
108 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
109 keepGoing a str = a str >> return False
111 shortHelpText = "use :? for help.\n"
113 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
115 \ Commands available from the prompt:\n\
117 \ <stmt> evaluate/run <stmt>\n\
118 \ :add <filename> ... add module(s) to the current target set\n\
119 \ :browse [*]<module> display the names defined by <module>\n\
120 \ :cd <dir> change directory to <dir>\n\
121 \ :def <cmd> <expr> define a command :<cmd>\n\
122 \ :help, :? display this list of commands\n\
123 \ :info [<name> ...] display information about the given names\n\
124 \ :load <filename> ... load module(s) and their dependents\n\
125 \ :module [+/-] [*]<mod> ... set the context for expression evaluation\n\
126 \ :reload reload the current module set\n\
128 \ :set <option> ... set options\n\
129 \ :set args <arg> ... set the arguments returned by System.getArgs\n\
130 \ :set prog <progname> set the value returned by System.getProgName\n\
132 \ :show modules show the currently loaded modules\n\
133 \ :show bindings show the current bindings made at the prompt\n\
135 \ :type <expr> show the type of <expr>\n\
136 \ :undef <cmd> undefine user-defined command :<cmd>\n\
137 \ :unset <option> ... unset options\n\
139 \ :!<command> run the shell command <command>\n\
141 \ Options for `:set' and `:unset':\n\
143 \ +r revert top-level expressions after each evaluation\n\
144 \ +s print timing/memory stats after each evaluation\n\
145 \ +t print type after evaluation\n\
146 \ -<flags> most GHC command line flags can also be set here\n\
147 \ (eg. -v2, -fglasgow-exts, etc.)\n\
150 interactiveUI :: CmState -> [FilePath] -> [FilePath] -> IO ()
151 interactiveUI cmstate paths cmdline_objs = do
153 hSetBuffering stdout NoBuffering
155 dflags <- getDynFlags
157 -- Link in the available packages
159 -- Now that demand-loading works, we don't really need to pre-load the packages
160 -- pkgs <- getPackages
161 -- linkPackages dflags pkgs
162 linkLibraries dflags cmdline_objs
164 -- Initialise buffering for the *interpreted* I/O system
165 cmstate <- initInterpBuffering cmstate dflags
167 -- We don't want the cmd line to buffer any input that might be
168 -- intended for the program, so unbuffer stdin.
169 hSetBuffering stdin NoBuffering
171 -- initial context is just the Prelude
172 cmstate <- cmSetContext cmstate dflags [] ["Prelude"]
174 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
178 startGHCi (runGHCi paths dflags)
179 GHCiState{ progname = "<interactive>",
185 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
186 Readline.resetTerminal Nothing
191 runGHCi :: [FilePath] -> DynFlags -> GHCi ()
192 runGHCi paths dflags = do
193 read_dot_files <- io (readIORef v_Read_DotGHCi)
195 when (read_dot_files) $ do
198 exists <- io (doesFileExist file)
200 dir_ok <- io (checkPerms ".")
201 file_ok <- io (checkPerms file)
202 when (dir_ok && file_ok) $ do
203 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
206 Right hdl -> fileLoop hdl False
208 when (read_dot_files) $ do
209 -- Read in $HOME/.ghci
210 either_dir <- io (IO.try (getEnv "HOME"))
214 cwd <- io (getCurrentDirectory)
215 when (dir /= cwd) $ do
216 let file = dir ++ "/.ghci"
217 ok <- io (checkPerms file)
219 either_hdl <- io (IO.try (openFile file ReadMode))
222 Right hdl -> fileLoop hdl False
224 -- perform a :load for files given on the GHCi command line
225 when (not (null paths)) $
226 ghciHandle showException $
227 loadModule (unwords paths)
229 -- enter the interactive loop
230 #if defined(mingw32_TARGET_OS)
231 -- always show prompt, since hIsTerminalDevice returns True for Consoles
232 -- only, which we may or may not be running under (cf. Emacs sub-shells.)
235 is_tty <- io (hIsTerminalDevice stdin)
236 interactiveLoop is_tty
240 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
243 interactiveLoop is_tty = do
244 -- ignore ^C exceptions caught here
245 ghciHandleDyn (\e -> case e of
246 Interrupted -> ghciUnblock (interactiveLoop is_tty)
247 _other -> return ()) $ do
249 -- read commands from stdin
250 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
253 else fileLoop stdin False -- turn off prompt for non-TTY input
255 fileLoop stdin is_tty
259 -- NOTE: We only read .ghci files if they are owned by the current user,
260 -- and aren't world writable. Otherwise, we could be accidentally
261 -- running code planted by a malicious third party.
263 -- Furthermore, We only read ./.ghci if . is owned by the current user
264 -- and isn't writable by anyone else. I think this is sufficient: we
265 -- don't need to check .. and ../.. etc. because "." always refers to
266 -- the same directory while a process is running.
268 checkPerms :: String -> IO Bool
270 #ifdef mingw32_TARGET_OS
273 DriverUtil.handle (\_ -> return False) $ do
274 st <- getFileStatus name
276 if fileOwner st /= me then do
277 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
280 let mode = fileMode st
281 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
282 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
284 putStrLn $ "*** WARNING: " ++ name ++
285 " is writable by someone else, IGNORING!"
290 fileLoop :: Handle -> Bool -> GHCi ()
291 fileLoop hdl prompt = do
292 cmstate <- getCmState
293 (mod,imports) <- io (cmGetContext cmstate)
294 when prompt (io (putStr (mkPrompt mod imports)))
295 l <- io (IO.try (hGetLine hdl))
297 Left e | isEOFError e -> return ()
298 | otherwise -> throw e
300 case remove_spaces l of
301 "" -> fileLoop hdl prompt
302 l -> do quit <- runCommand l
303 if quit then return () else fileLoop hdl prompt
305 stringLoop :: [String] -> GHCi ()
306 stringLoop [] = return ()
307 stringLoop (s:ss) = do
308 case remove_spaces s of
310 l -> do quit <- runCommand l
311 if quit then return () else stringLoop ss
313 mkPrompt toplevs exports
314 = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
316 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
317 readlineLoop :: GHCi ()
319 cmstate <- getCmState
320 (mod,imports) <- io (cmGetContext cmstate)
322 l <- io (readline (mkPrompt mod imports))
326 case remove_spaces l of
331 if quit then return () else readlineLoop
334 -- Top level exception handler, just prints out the exception
336 runCommand :: String -> GHCi Bool
338 ghciHandle ( \exception -> do
340 showException exception
345 showException (DynException dyn) =
346 case fromDynamic dyn of
347 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
348 Just Interrupted -> io (putStrLn "Interrupted.")
349 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
350 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
351 Just other_ghc_ex -> io (print other_ghc_ex)
353 showException other_exception
354 = io (putStrLn ("*** Exception: " ++ show other_exception))
356 doCommand (':' : command) = specialCommand command
358 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
361 runStmt :: String -> GHCi [Name]
363 | null (filter (not.isSpace) stmt) = return []
365 = do st <- getGHCiState
366 dflags <- io getDynFlags
367 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
368 (new_cmstate, result) <-
369 io $ withProgName (progname st) $ withArgs (args st) $
370 cmRunStmt (cmstate st) dflags' stmt
371 setGHCiState st{cmstate = new_cmstate}
373 CmRunFailed -> return []
374 CmRunException e -> showException e >> return []
375 CmRunOk names -> return names
377 -- possibly print the type and revert CAFs after evaluating an expression
379 = do b <- isOptionSet ShowType
380 cmstate <- getCmState
381 when b (mapM_ (showTypeOfName cmstate) names)
384 b <- isOptionSet RevertCAFs
385 io (when b revertCAFs)
388 showTypeOfName :: CmState -> Name -> GHCi ()
389 showTypeOfName cmstate n
390 = do maybe_str <- io (cmTypeOfName cmstate n)
393 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
395 specialCommand :: String -> GHCi Bool
396 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
397 specialCommand str = do
398 let (cmd,rest) = break isSpace str
399 cmds <- io (readIORef commands)
400 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
401 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
402 ++ shortHelpText) >> return False)
403 [(_,f)] -> f (dropWhile isSpace rest)
404 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
405 " matches multiple commands (" ++
406 foldr1 (\a b -> a ++ ',':b) (map fst cs)
407 ++ ")") >> return False)
409 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
412 -----------------------------------------------------------------------------
413 -- To flush buffers for the *interpreted* computation we need
414 -- to refer to *its* stdout/stderr handles
416 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
417 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
419 no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++
420 " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
421 flush_cmd = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr"
423 initInterpBuffering :: CmState -> DynFlags -> IO CmState
424 initInterpBuffering cmstate dflags
425 = do (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags no_buf_cmd
428 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
429 other -> panic "interactiveUI:setBuffering"
431 (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags flush_cmd
433 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
434 _ -> panic "interactiveUI:flush"
436 turnOffBuffering -- Turn it off right now
441 flushInterpBuffers :: GHCi ()
443 = io $ do Monad.join (readIORef flush_interp)
446 turnOffBuffering :: IO ()
448 = do Monad.join (readIORef turn_off_buffering)
451 -----------------------------------------------------------------------------
454 help :: String -> GHCi ()
455 help _ = io (putStr helpText)
457 info :: String -> GHCi ()
458 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
461 init_cms <- getCmState
462 dflags <- io getDynFlags
464 infoThings cms [] = return cms
465 infoThings cms (name:names) = do
466 (cms, stuff) <- io (cmInfoThing cms dflags name)
467 io (putStrLn (showSDocForUser unqual (
468 vcat (intersperse (text "") (map showThing stuff))))
472 unqual = cmGetPrintUnqual init_cms
474 showThing (ty_thing, fixity)
475 = vcat [ text "-- " <> showTyThing ty_thing,
476 showFixity fixity (getName ty_thing),
477 ppr (ifaceTyThing ty_thing) ]
480 | fix == defaultFixity = empty
481 | otherwise = ppr fix <+>
482 (if isSymOcc (nameOccName name)
484 else char '`' <> ppr name <> char '`')
486 showTyThing (AClass cl)
487 = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
488 showTyThing (ATyCon ty)
490 = hcat [ppr ty, text " is a primitive type constructor"]
492 = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
493 showTyThing (AnId id)
494 = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
497 | isRecordSelector id =
498 case tyConClass_maybe (fieldLabelTyCon (
499 recordSelectorFieldLabel id)) of
500 Nothing -> text "record selector"
501 Just c -> text "method in class " <> ppr c
502 | isDataConWrapId id = text "data constructor"
503 | otherwise = text "variable"
505 -- also print out the source location for home things
507 | isHomePackageName name && isGoodSrcLoc loc
508 = hsep [ text ", defined at", ppr loc ]
511 where loc = nameSrcLoc name
513 cms <- infoThings init_cms names
517 addModule :: String -> GHCi ()
519 let files = words str
520 state <- getGHCiState
521 dflags <- io (getDynFlags)
522 io (revertCAFs) -- always revert CAFs on load/add.
523 let new_targets = files ++ targets state
524 graph <- io (cmDepAnal (cmstate state) dflags new_targets)
525 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
526 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
527 setContextAfterLoad mods
528 modulesLoadedMsg ok mods dflags
530 changeDirectory :: String -> GHCi ()
531 changeDirectory ('~':d) = do
532 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
533 io (setCurrentDirectory (tilde ++ '/':d))
534 changeDirectory d = io (setCurrentDirectory d)
536 defineMacro :: String -> GHCi ()
538 let (macro_name, definition) = break isSpace s
539 cmds <- io (readIORef commands)
541 then throwDyn (CmdLineError "invalid macro name")
543 if (macro_name `elem` map fst cmds)
544 then throwDyn (CmdLineError
545 ("command `" ++ macro_name ++ "' is already defined"))
548 -- give the expression a type signature, so we can be sure we're getting
549 -- something of the right type.
550 let new_expr = '(' : definition ++ ") :: String -> IO String"
552 -- compile the expression
554 dflags <- io getDynFlags
555 (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
556 setCmState new_cmstate
559 Just hv -> io (writeIORef commands --
560 ((macro_name, keepGoing (runMacro hv)) : cmds))
562 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
564 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
565 stringLoop (lines str)
567 undefineMacro :: String -> GHCi ()
568 undefineMacro macro_name = do
569 cmds <- io (readIORef commands)
570 if (macro_name `elem` map fst builtin_commands)
571 then throwDyn (CmdLineError
572 ("command `" ++ macro_name ++ "' cannot be undefined"))
574 if (macro_name `notElem` map fst cmds)
575 then throwDyn (CmdLineError
576 ("command `" ++ macro_name ++ "' not defined"))
578 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
581 loadModule :: String -> GHCi ()
582 loadModule str = timeIt (loadModule' str)
585 let files = words str
586 state <- getGHCiState
587 dflags <- io getDynFlags
589 -- do the dependency anal first, so that if it fails we don't throw
590 -- away the current set of modules.
591 graph <- io (cmDepAnal (cmstate state) dflags files)
593 -- Dependency anal ok, now unload everything
594 cmstate1 <- io (cmUnload (cmstate state) dflags)
595 setGHCiState state{ cmstate = cmstate1, targets = [] }
597 io (revertCAFs) -- always revert CAFs on load.
598 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
599 setGHCiState state{ cmstate = cmstate2, targets = files }
601 setContextAfterLoad mods
602 modulesLoadedMsg ok mods dflags
605 reloadModule :: String -> GHCi ()
607 state <- getGHCiState
608 dflags <- io getDynFlags
609 case targets state of
610 [] -> io (putStr "no current target\n")
612 -- do the dependency anal first, so that if it fails we don't throw
613 -- away the current set of modules.
614 graph <- io (cmDepAnal (cmstate state) dflags paths)
616 io (revertCAFs) -- always revert CAFs on reload.
618 <- io (cmLoadModules (cmstate state) dflags graph)
619 setGHCiState state{ cmstate=cmstate1 }
620 setContextAfterLoad mods
621 modulesLoadedMsg ok mods dflags
623 reloadModule _ = noArgs ":reload"
625 setContextAfterLoad [] = setContext prel
626 setContextAfterLoad (m:_) = do
627 cmstate <- getCmState
628 b <- io (cmModuleIsInterpreted cmstate m)
629 if b then setContext ('*':m) else setContext m
631 modulesLoadedMsg ok mods dflags =
632 when (verbosity dflags > 0) $ do
634 | null mods = text "none."
636 punctuate comma (map text mods)) <> text "."
639 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
641 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
644 typeOfExpr :: String -> GHCi ()
646 = do cms <- getCmState
647 dflags <- io getDynFlags
648 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
649 setCmState new_cmstate
652 Just tystr -> io (putStrLn tystr)
654 quit :: String -> GHCi Bool
657 shellEscape :: String -> GHCi Bool
658 shellEscape str = io (system str >> return False)
660 -----------------------------------------------------------------------------
661 -- Browing a module's contents
663 browseCmd :: String -> GHCi ()
666 ['*':m] | looksLikeModuleName m -> browseModule m False
667 [m] | looksLikeModuleName m -> browseModule m True
668 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
670 browseModule m exports_only = do
672 dflags <- io getDynFlags
674 is_interpreted <- io (cmModuleIsInterpreted cms m)
675 when (not is_interpreted && not exports_only) $
676 throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
678 -- temporarily set the context to the module we're interested in,
679 -- just so we can get an appropriate PrintUnqualified
680 (as,bs) <- io (cmGetContext cms)
681 cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m]
682 else cmSetContext cms dflags [m] [])
683 cms2 <- io (cmSetContext cms1 dflags as bs)
685 (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)
689 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
691 things' = filter wantToSee things
693 wantToSee (AnId id) = not (isDataConId id || isDataConWrapId id)
696 thing_names = map getName things
698 thingDecl thing@(AnId id) = ifaceTyThing thing
700 thingDecl thing@(AClass c) =
701 let rn_decl = ifaceTyThing thing in
703 ClassDecl { tcdSigs = cons } ->
704 rn_decl{ tcdSigs = filter methodIsVisible cons }
707 methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
709 thingDecl thing@(ATyCon t) =
710 let rn_decl = ifaceTyThing thing in
712 TyData { tcdCons = DataCons cons } ->
713 rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
716 conIsVisible (ConDecl n _ _ _ _) = n `elem` thing_names
718 io (putStrLn (showSDocForUser unqual (
719 vcat (map (ppr . thingDecl) things')))
724 -----------------------------------------------------------------------------
725 -- Setting the module context
728 | all sensible mods = fn mods
729 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
731 (fn, mods) = case str of
732 '+':stuff -> (addToContext, words stuff)
733 '-':stuff -> (removeFromContext, words stuff)
734 stuff -> (newContext, words stuff)
736 sensible ('*':m) = looksLikeModuleName m
737 sensible m = looksLikeModuleName m
741 dflags <- io getDynFlags
742 (as,bs) <- separate cms mods [] []
743 let bs' = if null as && prel `notElem` bs then prel:bs else bs
744 cms' <- io (cmSetContext cms dflags as bs')
747 separate cmstate [] as bs = return (as,bs)
748 separate cmstate (('*':m):ms) as bs = do
749 b <- io (cmModuleIsInterpreted cmstate m)
750 if b then separate cmstate ms (m:as) bs
751 else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
752 separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
757 addToContext mods = do
759 dflags <- io getDynFlags
760 (as,bs) <- io (cmGetContext cms)
762 (as',bs') <- separate cms mods [] []
764 let as_to_add = as' \\ (as ++ bs)
765 bs_to_add = bs' \\ (as ++ bs)
767 cms' <- io (cmSetContext cms dflags
768 (as ++ as_to_add) (bs ++ bs_to_add))
772 removeFromContext mods = do
774 dflags <- io getDynFlags
775 (as,bs) <- io (cmGetContext cms)
777 (as_to_remove,bs_to_remove) <- separate cms mods [] []
779 let as' = as \\ (as_to_remove ++ bs_to_remove)
780 bs' = bs \\ (as_to_remove ++ bs_to_remove)
782 cms' <- io (cmSetContext cms dflags as' bs')
785 ----------------------------------------------------------------------------
788 -- set options in the interpreter. Syntax is exactly the same as the
789 -- ghc command line, except that certain options aren't available (-C,
792 -- This is pretty fragile: most options won't work as expected. ToDo:
793 -- figure out which ones & disallow them.
795 setCmd :: String -> GHCi ()
797 = do st <- getGHCiState
798 let opts = options st
799 io $ putStrLn (showSDoc (
800 text "options currently set: " <>
803 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
807 ("args":args) -> setArgs args
808 ("prog":prog) -> setProg prog
809 wds -> setOptions wds
813 setGHCiState st{ args = args }
817 setGHCiState st{ progname = prog }
819 io (hPutStrLn stderr "syntax: :set prog <progname>")
822 do -- first, deal with the GHCi opts (+s, +t, etc.)
823 let (plus_opts, minus_opts) = partition isPlus wds
824 mapM_ setOpt plus_opts
826 -- now, the GHC flags
827 pkgs_before <- io (readIORef v_Packages)
828 leftovers <- io (processArgs static_flags minus_opts [])
829 pkgs_after <- io (readIORef v_Packages)
831 -- update things if the users wants more packages
832 when (pkgs_before /= pkgs_after) $
833 newPackages (pkgs_after \\ pkgs_before)
835 -- then, dynamic flags
838 leftovers <- processArgs dynamic_flags leftovers []
841 if (not (null leftovers))
842 then throwDyn (CmdLineError ("unrecognised flags: " ++
847 unsetOptions :: String -> GHCi ()
849 = do -- first, deal with the GHCi opts (+s, +t, etc.)
851 (minus_opts, rest1) = partition isMinus opts
852 (plus_opts, rest2) = partition isPlus rest1
854 if (not (null rest2))
855 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
858 mapM_ unsetOpt plus_opts
860 -- can't do GHC flags for now
861 if (not (null minus_opts))
862 then throwDyn (CmdLineError "can't unset GHC command-line flags")
865 isMinus ('-':s) = True
868 isPlus ('+':s) = True
872 = case strToGHCiOpt str of
873 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
874 Just o -> setOption o
877 = case strToGHCiOpt str of
878 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
879 Just o -> unsetOption o
881 strToGHCiOpt :: String -> (Maybe GHCiOption)
882 strToGHCiOpt "s" = Just ShowTiming
883 strToGHCiOpt "t" = Just ShowType
884 strToGHCiOpt "r" = Just RevertCAFs
885 strToGHCiOpt _ = Nothing
887 optToStr :: GHCiOption -> String
888 optToStr ShowTiming = "s"
889 optToStr ShowType = "t"
890 optToStr RevertCAFs = "r"
892 newPackages new_pkgs = do -- The new packages are already in v_Packages
893 state <- getGHCiState
894 dflags <- io getDynFlags
895 cmstate1 <- io (cmUnload (cmstate state) dflags)
896 setGHCiState state{ cmstate = cmstate1, targets = [] }
898 io $ do pkgs <- getPackageInfo
899 flushPackageCache pkgs
901 setContextAfterLoad []
903 -----------------------------------------------------------------------------
908 ["modules" ] -> showModules
909 ["bindings"] -> showBindings
910 ["linker"] -> io showLinkerState
911 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
915 let (mg, hpt) = cmGetModInfo cms
916 mapM_ (showModule hpt) mg
919 showModule :: HomePackageTable -> ModSummary -> GHCi ()
920 showModule hpt mod_summary
921 = case lookupModuleEnv hpt mod of
922 Nothing -> panic "missing linkable"
923 Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
925 obj_linkable = isObjectLinkable (hm_linkable mod_info)
927 mod = ms_mod mod_summary
928 locn = ms_location mod_summary
933 unqual = cmGetPrintUnqual cms
934 showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
936 io (mapM_ showBinding (cmGetBindings cms))
940 -----------------------------------------------------------------------------
943 data GHCiState = GHCiState
947 targets :: [FilePath],
949 options :: [GHCiOption]
953 = ShowTiming -- show time/allocs after evaluation
954 | ShowType -- show the type of expressions
955 | RevertCAFs -- revert CAFs after every evaluation
958 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
960 startGHCi :: GHCi a -> GHCiState -> IO a
961 startGHCi g state = do ref <- newIORef state; unGHCi g ref
963 instance Monad GHCi where
964 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
965 return a = GHCi $ \s -> return a
967 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
968 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
969 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
971 getGHCiState = GHCi $ \r -> readIORef r
972 setGHCiState s = GHCi $ \r -> writeIORef r s
974 -- for convenience...
975 getCmState = getGHCiState >>= return . cmstate
976 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
978 isOptionSet :: GHCiOption -> GHCi Bool
980 = do st <- getGHCiState
981 return (opt `elem` options st)
983 setOption :: GHCiOption -> GHCi ()
985 = do st <- getGHCiState
986 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
988 unsetOption :: GHCiOption -> GHCi ()
990 = do st <- getGHCiState
991 setGHCiState (st{ options = filter (/= opt) (options st) })
994 io m = GHCi { unGHCi = \s -> m >>= return }
996 -----------------------------------------------------------------------------
997 -- recursive exception handlers
999 -- Don't forget to unblock async exceptions in the handler, or if we're
1000 -- in an exception loop (eg. let a = error a in a) the ^C exception
1001 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1003 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1004 ghciHandle h (GHCi m) = GHCi $ \s ->
1005 Exception.catch (m s)
1006 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
1008 ghciUnblock :: GHCi a -> GHCi a
1009 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1011 -----------------------------------------------------------------------------
1012 -- timing & statistics
1014 timeIt :: GHCi a -> GHCi a
1016 = do b <- isOptionSet ShowTiming
1019 else do allocs1 <- io $ getAllocations
1020 time1 <- io $ getCPUTime
1022 allocs2 <- io $ getAllocations
1023 time2 <- io $ getCPUTime
1024 io $ printTimes (allocs2 - allocs1) (time2 - time1)
1027 foreign import ccall "getAllocations" getAllocations :: IO Int
1029 printTimes :: Int -> Integer -> IO ()
1030 printTimes allocs psecs
1031 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1032 secs_str = showFFloat (Just 2) secs
1033 putStrLn (showSDoc (
1034 parens (text (secs_str "") <+> text "secs" <> comma <+>
1035 int allocs <+> text "bytes")))
1037 -----------------------------------------------------------------------------
1040 looksLikeModuleName [] = False
1041 looksLikeModuleName (c:cs) = isUpper c && all isAlphaNumEx cs
1043 isAlphaNumEx c = isAlphaNum c || c == '_' || c == '.'
1045 -----------------------------------------------------------------------------
1052 -- Have to turn off buffering again, because we just
1053 -- reverted stdout, stderr & stdin to their defaults.
1055 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1056 -- Make it "safe", just in case