1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.169 2004/07/30 08:40:11 simonpj Exp $
5 -- GHC Interactive User Interface
7 -- (c) The GHC Team 2004
9 -----------------------------------------------------------------------------
10 module InteractiveUI (
11 interactiveUI, -- :: CmState -> [FilePath] -> IO ()
15 #include "../includes/config.h"
16 #include "HsVersions.h"
19 import HscTypes ( TyThing(..), HomeModInfo(hm_linkable), HomePackageTable,
20 isObjectLinkable, GhciMode(..) )
21 import IfaceSyn ( IfaceType, IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceConDecl(..),
22 pprIfaceDeclHead, pprParendIfaceType, pprIfaceForAllPart )
23 import FunDeps ( pprFundeps )
26 import DriverUtil ( remove_spaces )
27 import Linker ( showLinkerState, linkPackages )
29 import Module ( showModMsg, lookupModuleEnv )
30 import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName,
32 import OccName ( OccName, isSymOcc, occNameUserString )
33 import BasicTypes ( StrictnessMark(..), Fixity, defaultFixity, SuccessFlag(..) )
36 import CmdLineOpts ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags,
37 restoreDynFlags, dopt_unset )
38 import Panic hiding ( showException )
40 import SrcLoc ( SrcLoc, isGoodSrcLoc )
42 #ifndef mingw32_HOST_OS
43 import DriverUtil( handle )
45 #if __GLASGOW_HASKELL__ > 504
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
63 import Data.Int ( Int64 )
66 import System.Environment
67 import System.Directory
68 import System.IO as IO
70 import Control.Monad as Monad
72 import GHC.Exts ( unsafeCoerce# )
74 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
76 import System.Posix.Internals ( setNonBlockingFD )
78 -----------------------------------------------------------------------------
82 \ / _ \\ /\\ /\\/ __(_)\n\
83 \ / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
84 \/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n\
85 \\\____/\\/ /_/\\____/|_| Type :? for help.\n"
87 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
89 builtin_commands :: [(String, String -> GHCi Bool)]
91 ("add", keepGoingPaths addModule),
92 ("browse", keepGoing browseCmd),
93 ("cd", keepGoing changeDirectory),
94 ("def", keepGoing defineMacro),
95 ("help", keepGoing help),
96 ("?", keepGoing help),
97 ("info", keepGoing info),
98 ("load", keepGoingPaths loadModule),
99 ("module", keepGoing setContext),
100 ("reload", keepGoing reloadModule),
101 ("set", keepGoing setCmd),
102 ("show", keepGoing showCmd),
103 ("type", keepGoing typeOfExpr),
104 ("kind", keepGoing kindOfType),
105 ("unset", keepGoing unsetOptions),
106 ("undef", keepGoing undefineMacro),
110 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
111 keepGoing a str = a str >> return False
113 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
114 keepGoingPaths a str = a (toArgs str) >> return False
116 shortHelpText = "use :? for help.\n"
118 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
120 \ Commands available from the prompt:\n\
122 \ <stmt> evaluate/run <stmt>\n\
123 \ :add <filename> ... add module(s) to the current target set\n\
124 \ :browse [*]<module> display the names defined by <module>\n\
125 \ :cd <dir> change directory to <dir>\n\
126 \ :def <cmd> <expr> define a command :<cmd>\n\
127 \ :help, :? display this list of commands\n\
128 \ :info [<name> ...] display information about the given names\n\
129 \ :load <filename> ... load module(s) and their dependents\n\
130 \ :module [+/-] [*]<mod> ... set the context for expression evaluation\n\
131 \ :reload reload the current module set\n\
133 \ :set <option> ... set options\n\
134 \ :set args <arg> ... set the arguments returned by System.getArgs\n\
135 \ :set prog <progname> set the value returned by System.getProgName\n\
137 \ :show modules show the currently loaded modules\n\
138 \ :show bindings show the current bindings made at the prompt\n\
140 \ :type <expr> show the type of <expr>\n\
141 \ :kind <type> show the kind of <type>\n\
142 \ :undef <cmd> undefine user-defined command :<cmd>\n\
143 \ :unset <option> ... unset options\n\
145 \ :!<command> run the shell command <command>\n\
147 \ Options for `:set' and `:unset':\n\
149 \ +r revert top-level expressions after each evaluation\n\
150 \ +s print timing/memory stats after each evaluation\n\
151 \ +t print type after evaluation\n\
152 \ -<flags> most GHC command line flags can also be set here\n\
153 \ (eg. -v2, -fglasgow-exts, etc.)\n\
156 interactiveUI :: [FilePath] -> Maybe String -> IO ()
157 interactiveUI srcs maybe_expr = do
158 dflags <- getDynFlags
160 cmstate <- cmInit Interactive dflags;
163 hSetBuffering stdout NoBuffering
165 -- Initialise buffering for the *interpreted* I/O system
166 initInterpBuffering cmstate
168 -- We don't want the cmd line to buffer any input that might be
169 -- intended for the program, so unbuffer stdin.
170 hSetBuffering stdin NoBuffering
172 -- initial context is just the Prelude
173 cmstate <- cmSetContext cmstate [] ["Prelude"]
175 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
179 startGHCi (runGHCi srcs dflags maybe_expr)
180 GHCiState{ progname = "<interactive>",
186 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
187 Readline.resetTerminal Nothing
192 runGHCi :: [FilePath] -> DynFlags -> Maybe String -> GHCi ()
193 runGHCi paths dflags maybe_expr = do
194 read_dot_files <- io (readIORef v_Read_DotGHCi)
196 when (read_dot_files) $ do
199 exists <- io (doesFileExist file)
201 dir_ok <- io (checkPerms ".")
202 file_ok <- io (checkPerms file)
203 when (dir_ok && file_ok) $ do
204 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
207 Right hdl -> fileLoop hdl False
209 when (read_dot_files) $ do
210 -- Read in $HOME/.ghci
211 either_dir <- io (IO.try (getEnv "HOME"))
215 cwd <- io (getCurrentDirectory)
216 when (dir /= cwd) $ do
217 let file = dir ++ "/.ghci"
218 ok <- io (checkPerms file)
220 either_hdl <- io (IO.try (openFile file ReadMode))
223 Right hdl -> fileLoop hdl False
225 -- Perform a :load for files given on the GHCi command line
226 when (not (null paths)) $
227 ghciHandle showException $
230 -- if verbosity is greater than 0, or we are connected to a
231 -- terminal, display the prompt in the interactive loop.
232 is_tty <- io (hIsTerminalDevice stdin)
233 let show_prompt = verbosity dflags > 0 || is_tty
237 -- enter the interactive loop
238 interactiveLoop is_tty show_prompt
240 -- just evaluate the expression we were given
245 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
248 interactiveLoop is_tty show_prompt = do
249 -- Ignore ^C exceptions caught here
250 ghciHandleDyn (\e -> case e of
251 Interrupted -> ghciUnblock (interactiveLoop is_tty show_prompt)
252 _other -> return ()) $ do
254 -- read commands from stdin
255 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
258 else fileLoop stdin show_prompt
260 fileLoop stdin show_prompt
264 -- NOTE: We only read .ghci files if they are owned by the current user,
265 -- and aren't world writable. Otherwise, we could be accidentally
266 -- running code planted by a malicious third party.
268 -- Furthermore, We only read ./.ghci if . is owned by the current user
269 -- and isn't writable by anyone else. I think this is sufficient: we
270 -- don't need to check .. and ../.. etc. because "." always refers to
271 -- the same directory while a process is running.
273 checkPerms :: String -> IO Bool
275 #ifdef mingw32_HOST_OS
278 DriverUtil.handle (\_ -> return False) $ do
279 st <- getFileStatus name
281 if fileOwner st /= me then do
282 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
285 let mode = fileMode st
286 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
287 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
289 putStrLn $ "*** WARNING: " ++ name ++
290 " is writable by someone else, IGNORING!"
295 fileLoop :: Handle -> Bool -> GHCi ()
296 fileLoop hdl prompt = do
297 cmstate <- getCmState
298 (mod,imports) <- io (cmGetContext cmstate)
299 when prompt (io (putStr (mkPrompt mod imports)))
300 l <- io (IO.try (hGetLine hdl))
302 Left e | isEOFError e -> return ()
303 | otherwise -> io (ioError e)
305 case remove_spaces l of
306 "" -> fileLoop hdl prompt
307 l -> do quit <- runCommand l
308 if quit then return () else fileLoop hdl prompt
310 stringLoop :: [String] -> GHCi ()
311 stringLoop [] = return ()
312 stringLoop (s:ss) = do
313 case remove_spaces s of
315 l -> do quit <- runCommand l
316 if quit then return () else stringLoop ss
318 mkPrompt toplevs exports
319 = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
321 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
322 readlineLoop :: GHCi ()
324 cmstate <- getCmState
325 (mod,imports) <- io (cmGetContext cmstate)
327 l <- io (readline (mkPrompt mod imports)
328 `finally` setNonBlockingFD 0)
329 -- readline sometimes puts stdin into blocking mode,
330 -- so we need to put it back for the IO library
334 case remove_spaces l of
339 if quit then return () else readlineLoop
342 runCommand :: String -> GHCi Bool
343 runCommand c = ghciHandle handler (doCommand c)
345 -- This is the exception handler for exceptions generated by the
346 -- user's code; it normally just prints out the exception. The
347 -- handler must be recursive, in case showing the exception causes
348 -- more exceptions to be raised.
350 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
351 -- raising another exception. We therefore don't put the recursive
352 -- handler arond the flushing operation, so if stderr is closed
353 -- GHCi will just die gracefully rather than going into an infinite loop.
354 handler :: Exception -> GHCi Bool
355 handler exception = do
357 io installSignalHandlers
358 ghciHandle handler (showException exception >> return False)
360 showException (DynException dyn) =
361 case fromDynamic dyn of
362 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
363 Just Interrupted -> io (putStrLn "Interrupted.")
364 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
365 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
366 Just other_ghc_ex -> io (print other_ghc_ex)
368 showException other_exception
369 = io (putStrLn ("*** Exception: " ++ show other_exception))
371 doCommand (':' : command) = specialCommand command
373 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
376 runStmt :: String -> GHCi [Name]
378 | null (filter (not.isSpace) stmt) = return []
380 = do st <- getGHCiState
381 dflags <- io getDynFlags
382 let cm_state' = cmSetDFlags (cmstate st)
383 (dopt_unset dflags Opt_WarnUnusedBinds)
384 (new_cmstate, result) <-
385 io $ withProgName (progname st) $ withArgs (args st) $
386 cmRunStmt cm_state' 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)
400 io installSignalHandlers
401 b <- isOptionSet RevertCAFs
402 io (when b revertCAFs)
405 showTypeOfName :: CmState -> Name -> GHCi ()
406 showTypeOfName cmstate n
407 = do maybe_str <- io (cmTypeOfName cmstate n)
410 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
412 specialCommand :: String -> GHCi Bool
413 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
414 specialCommand str = do
415 let (cmd,rest) = break isSpace str
416 cmds <- io (readIORef commands)
417 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
418 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
419 ++ shortHelpText) >> return False)
420 [(_,f)] -> f (dropWhile isSpace rest)
421 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
422 " matches multiple commands (" ++
423 foldr1 (\a b -> a ++ ',':b) (map fst cs)
424 ++ ")") >> return False)
426 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
429 -----------------------------------------------------------------------------
430 -- To flush buffers for the *interpreted* computation we need
431 -- to refer to *its* stdout/stderr handles
433 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
434 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
436 no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++
437 " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
438 flush_cmd = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr"
440 initInterpBuffering :: CmState -> IO ()
441 initInterpBuffering cmstate
442 = do maybe_hval <- cmCompileExpr cmstate no_buf_cmd
445 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
446 other -> panic "interactiveUI:setBuffering"
448 maybe_hval <- cmCompileExpr cmstate flush_cmd
450 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
451 _ -> panic "interactiveUI:flush"
453 turnOffBuffering -- Turn it off right now
458 flushInterpBuffers :: GHCi ()
460 = io $ do Monad.join (readIORef flush_interp)
463 turnOffBuffering :: IO ()
465 = do Monad.join (readIORef turn_off_buffering)
468 -----------------------------------------------------------------------------
471 help :: String -> GHCi ()
472 help _ = io (putStr helpText)
474 info :: String -> GHCi ()
475 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
476 info s = do { let names = words s
477 ; init_cms <- getCmState
478 ; mapM_ (infoThing init_cms) names }
481 = do { stuff <- io (cmInfoThing cms name)
482 ; io (putStrLn (showSDocForUser (cmGetPrintUnqual cms) $
483 vcat (intersperse (text "") (map (showThing name) stuff)))) }
485 showThing :: String -> (IfaceDecl, Fixity, SrcLoc) -> SDoc
486 showThing name (thing, fixity, src_loc)
487 = vcat [ showDecl (\occ -> name == occNameUserString occ) thing,
492 | fix == defaultFixity = empty
493 | otherwise = ppr fix <+> text name
495 showLoc loc -- The ppr function for SrcLocs is a bit wonky
496 | isGoodSrcLoc loc = ptext SLIT("Defined at") <+> ppr loc
497 | otherwise = ppr loc
499 -- Now there is rather a lot of goop just to print declarations in a civilised way
500 -- with "..." for the parts we are less interested in.
502 showDecl :: (OccName -> Bool) -> IfaceDecl -> SDoc
503 showDecl want_name (IfaceForeign {ifName = tc})
504 = ppr tc <+> ptext SLIT("is a foreign type")
506 showDecl want_name (IfaceId {ifName = var, ifType = ty})
507 = ppr var <+> dcolon <+> ppr ty
509 showDecl want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty})
510 = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
511 2 (equals <+> ppr mono_ty)
513 showDecl want_name (IfaceData {ifCtxt = context, ifName = tycon,
514 ifTyVars = tyvars, ifCons = condecls})
515 = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
516 2 (add_bars (ppr_trim show_con cs))
518 show_con (IfaceConDecl con_name is_infix ex_tvs ex_cxt tys strs flds)
519 | want_name tycon || want_name con_name || any want_name flds
520 = Just (pprIfaceForAllPart ex_tvs ex_cxt (show_guts con_name is_infix tys_w_strs flds))
521 | otherwise = Nothing
523 tys_w_strs = tys `zip` (strs ++ repeat NotMarkedStrict)
525 show_guts con True [ty1, ty2] flds = sep [ppr_bangty ty1, ppr con, ppr_bangty ty2]
526 show_guts con _ tys [] = ppr_bndr con <+> sep (map ppr_bangty tys)
527 show_guts con _ tys flds
528 = ppr_bndr con <+> braces (sep (punctuate comma (ppr_trim show_fld (tys `zip` flds))))
530 show_fld (bty, fld) | want_name tycon || want_name con || want_name fld
531 = Just (ppr_bndr fld <+> dcolon <+> ppr_bangty bty)
532 | otherwise = Nothing
534 (pp_nd, cs) = case condecls of
535 IfAbstractTyCon -> (ptext SLIT("data"), [])
536 IfDataTyCon cs -> (ptext SLIT("data"), cs)
537 IfNewTyCon c -> (ptext SLIT("newtype"), [c])
540 add_bars [c] = equals <+> c
541 add_bars (c:cs) = equals <+> sep (c : map (char '|' <+>) cs)
543 ppr_bangty (ty, str) = ppr_str str <> pprParendIfaceType ty
544 ppr_str MarkedStrict = char '!'
545 ppr_str MarkedUnboxed = ptext SLIT("!!")
546 ppr_str NotMarkedStrict = empty
548 showDecl want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
549 ifFDs = fds, ifSigs = sigs})
550 = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars
551 <+> pprFundeps fds <+> ptext SLIT("where"))
552 2 (vcat (ppr_trim show_op sigs))
554 show_op (IfaceClassOp op dm ty)
555 | want_name clas || want_name op = Just (ppr_bndr op <+> dcolon <+> ppr ty)
556 | otherwise = Nothing
558 ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc]
560 = snd (foldr go (False, []) xs)
562 go x (eliding, so_far)
563 | Just doc <- show x = (False, doc : so_far)
564 | otherwise = if eliding then (True, so_far)
565 else (True, ptext SLIT("...") : so_far)
567 ppr_bndr :: OccName -> SDoc
568 -- Wrap operators in ()
569 ppr_bndr occ | isSymOcc occ = parens (ppr occ)
570 | otherwise = ppr occ
573 -----------------------------------------------------------------------------
576 addModule :: [FilePath] -> GHCi ()
578 state <- getGHCiState
579 io (revertCAFs) -- always revert CAFs on load/add.
580 files <- mapM expandPath files
581 let new_targets = files ++ targets state
582 graph <- io (cmDepAnal (cmstate state) new_targets)
583 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) graph)
584 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
585 setContextAfterLoad mods
586 dflags <- io getDynFlags
587 modulesLoadedMsg ok mods dflags
589 changeDirectory :: String -> GHCi ()
590 changeDirectory dir = do
591 state <- getGHCiState
592 when (targets state /= []) $
593 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded, \n\
594 \because the search path has changed.\n"
595 cmstate1 <- io (cmUnload (cmstate state))
596 setGHCiState state{ cmstate = cmstate1, targets = [] }
597 setContextAfterLoad []
598 dir <- expandPath dir
599 io (setCurrentDirectory dir)
601 defineMacro :: String -> GHCi ()
603 let (macro_name, definition) = break isSpace s
604 cmds <- io (readIORef commands)
606 then throwDyn (CmdLineError "invalid macro name")
608 if (macro_name `elem` map fst cmds)
609 then throwDyn (CmdLineError
610 ("command `" ++ macro_name ++ "' is already defined"))
613 -- give the expression a type signature, so we can be sure we're getting
614 -- something of the right type.
615 let new_expr = '(' : definition ++ ") :: String -> IO String"
617 -- compile the expression
619 maybe_hv <- io (cmCompileExpr cms new_expr)
622 Just hv -> io (writeIORef commands --
623 ((macro_name, keepGoing (runMacro hv)) : cmds))
625 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
627 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
628 stringLoop (lines str)
630 undefineMacro :: String -> GHCi ()
631 undefineMacro macro_name = do
632 cmds <- io (readIORef commands)
633 if (macro_name `elem` map fst builtin_commands)
634 then throwDyn (CmdLineError
635 ("command `" ++ macro_name ++ "' cannot be undefined"))
637 if (macro_name `notElem` map fst cmds)
638 then throwDyn (CmdLineError
639 ("command `" ++ macro_name ++ "' not defined"))
641 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
644 loadModule :: [FilePath] -> GHCi ()
645 loadModule fs = timeIt (loadModule' fs)
647 loadModule' :: [FilePath] -> GHCi ()
648 loadModule' files = do
649 state <- getGHCiState
652 files <- mapM expandPath files
654 -- do the dependency anal first, so that if it fails we don't throw
655 -- away the current set of modules.
656 graph <- io (cmDepAnal (cmstate state) files)
658 -- Dependency anal ok, now unload everything
659 cmstate1 <- io (cmUnload (cmstate state))
660 setGHCiState state{ cmstate = cmstate1, targets = [] }
662 io (revertCAFs) -- always revert CAFs on load.
663 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 graph)
664 setGHCiState state{ cmstate = cmstate2, targets = files }
666 setContextAfterLoad mods
667 dflags <- io (getDynFlags)
668 modulesLoadedMsg ok mods dflags
671 reloadModule :: String -> GHCi ()
673 state <- getGHCiState
674 case targets state of
675 [] -> io (putStr "no current target\n")
677 -- do the dependency anal first, so that if it fails we don't throw
678 -- away the current set of modules.
679 graph <- io (cmDepAnal (cmstate state) paths)
681 io (revertCAFs) -- always revert CAFs on reload.
683 <- io (cmLoadModules (cmstate state) graph)
684 setGHCiState state{ cmstate=cmstate1 }
685 setContextAfterLoad mods
686 dflags <- io getDynFlags
687 modulesLoadedMsg ok mods dflags
689 reloadModule _ = noArgs ":reload"
691 setContextAfterLoad [] = setContext prel
692 setContextAfterLoad (m:_) = do
693 cmstate <- getCmState
694 b <- io (cmModuleIsInterpreted cmstate m)
695 if b then setContext ('*':m) else setContext m
697 modulesLoadedMsg ok mods dflags =
698 when (verbosity dflags > 0) $ do
700 | null mods = text "none."
702 punctuate comma (map text mods)) <> text "."
705 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
707 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
710 typeOfExpr :: String -> GHCi ()
712 = do cms <- getCmState
713 maybe_tystr <- io (cmTypeOfExpr cms str)
716 Just tystr -> io (putStrLn tystr)
718 kindOfType :: String -> GHCi ()
720 = do cms <- getCmState
721 maybe_tystr <- io (cmKindOfType cms str)
724 Just tystr -> io (putStrLn tystr)
726 quit :: String -> GHCi Bool
729 shellEscape :: String -> GHCi Bool
730 shellEscape str = io (system str >> return False)
732 -----------------------------------------------------------------------------
733 -- Browsing a module's contents
735 browseCmd :: String -> GHCi ()
738 ['*':m] | looksLikeModuleName m -> browseModule m False
739 [m] | looksLikeModuleName m -> browseModule m True
740 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
742 browseModule m exports_only = do
745 is_interpreted <- io (cmModuleIsInterpreted cms m)
746 when (not is_interpreted && not exports_only) $
747 throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
749 -- Temporarily set the context to the module we're interested in,
750 -- just so we can get an appropriate PrintUnqualified
751 (as,bs) <- io (cmGetContext cms)
752 cms1 <- io (if exports_only then cmSetContext cms [] [prel,m]
753 else cmSetContext cms [m] [])
754 cms2 <- io (cmSetContext cms1 as bs)
756 things <- io (cmBrowseModule cms2 m exports_only)
758 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
760 io (putStrLn (showSDocForUser unqual (
761 vcat (map (showDecl (const True)) things)
764 -----------------------------------------------------------------------------
765 -- Setting the module context
768 | all sensible mods = fn mods
769 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
771 (fn, mods) = case str of
772 '+':stuff -> (addToContext, words stuff)
773 '-':stuff -> (removeFromContext, words stuff)
774 stuff -> (newContext, words stuff)
776 sensible ('*':m) = looksLikeModuleName m
777 sensible m = looksLikeModuleName m
781 (as,bs) <- separate cms mods [] []
782 let bs' = if null as && prel `notElem` bs then prel:bs else bs
783 cms' <- io (cmSetContext cms as bs')
786 separate cmstate [] as bs = return (as,bs)
787 separate cmstate (('*':m):ms) as bs = do
788 b <- io (cmModuleIsInterpreted cmstate m)
789 if b then separate cmstate ms (m:as) bs
790 else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
791 separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
796 addToContext mods = do
798 (as,bs) <- io (cmGetContext cms)
800 (as',bs') <- separate cms mods [] []
802 let as_to_add = as' \\ (as ++ bs)
803 bs_to_add = bs' \\ (as ++ bs)
805 cms' <- io (cmSetContext cms
806 (as ++ as_to_add) (bs ++ bs_to_add))
810 removeFromContext mods = do
812 (as,bs) <- io (cmGetContext cms)
814 (as_to_remove,bs_to_remove) <- separate cms mods [] []
816 let as' = as \\ (as_to_remove ++ bs_to_remove)
817 bs' = bs \\ (as_to_remove ++ bs_to_remove)
819 cms' <- io (cmSetContext cms as' bs')
822 ----------------------------------------------------------------------------
825 -- set options in the interpreter. Syntax is exactly the same as the
826 -- ghc command line, except that certain options aren't available (-C,
829 -- This is pretty fragile: most options won't work as expected. ToDo:
830 -- figure out which ones & disallow them.
832 setCmd :: String -> GHCi ()
834 = do st <- getGHCiState
835 let opts = options st
836 io $ putStrLn (showSDoc (
837 text "options currently set: " <>
840 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
844 ("args":args) -> setArgs args
845 ("prog":prog) -> setProg prog
846 wds -> setOptions wds
850 setGHCiState st{ args = args }
854 setGHCiState st{ progname = prog }
856 io (hPutStrLn stderr "syntax: :set prog <progname>")
859 do -- first, deal with the GHCi opts (+s, +t, etc.)
860 let (plus_opts, minus_opts) = partition isPlus wds
861 mapM_ setOpt plus_opts
863 -- now, the GHC flags
864 pkgs_before <- io (readIORef v_ExplicitPackages)
865 leftovers <- io (processArgs static_flags minus_opts [])
866 pkgs_after <- io (readIORef v_ExplicitPackages)
868 -- update things if the users wants more packages
869 let new_packages = pkgs_after \\ pkgs_before
870 when (not (null new_packages)) $
871 newPackages new_packages
873 -- don't forget about the extra command-line flags from the
874 -- extra_ghc_opts fields in the new packages
875 new_package_details <- io (getPackageDetails new_packages)
876 let pkg_extra_opts = concatMap extra_ghc_opts new_package_details
877 pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts [])
879 -- then, dynamic flags
882 leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) []
885 if (not (null leftovers))
886 then throwDyn (CmdLineError ("unrecognised flags: " ++
891 unsetOptions :: String -> GHCi ()
893 = do -- first, deal with the GHCi opts (+s, +t, etc.)
895 (minus_opts, rest1) = partition isMinus opts
896 (plus_opts, rest2) = partition isPlus rest1
898 if (not (null rest2))
899 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
902 mapM_ unsetOpt plus_opts
904 -- can't do GHC flags for now
905 if (not (null minus_opts))
906 then throwDyn (CmdLineError "can't unset GHC command-line flags")
909 isMinus ('-':s) = True
912 isPlus ('+':s) = True
916 = case strToGHCiOpt str of
917 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
918 Just o -> setOption o
921 = case strToGHCiOpt str of
922 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
923 Just o -> unsetOption o
925 strToGHCiOpt :: String -> (Maybe GHCiOption)
926 strToGHCiOpt "s" = Just ShowTiming
927 strToGHCiOpt "t" = Just ShowType
928 strToGHCiOpt "r" = Just RevertCAFs
929 strToGHCiOpt _ = Nothing
931 optToStr :: GHCiOption -> String
932 optToStr ShowTiming = "s"
933 optToStr ShowType = "t"
934 optToStr RevertCAFs = "r"
936 newPackages new_pkgs = do -- The new packages are already in v_Packages
937 state <- getGHCiState
938 cmstate1 <- io (cmUnload (cmstate state))
939 setGHCiState state{ cmstate = cmstate1, targets = [] }
940 dflags <- io getDynFlags
941 io (linkPackages dflags new_pkgs)
942 setContextAfterLoad []
944 -- ---------------------------------------------------------------------------
949 ["modules" ] -> showModules
950 ["bindings"] -> showBindings
951 ["linker"] -> io showLinkerState
952 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
956 let (mg, hpt) = cmGetModInfo cms
957 mapM_ (showModule hpt) mg
960 showModule :: HomePackageTable -> ModSummary -> GHCi ()
961 showModule hpt mod_summary
962 = case lookupModuleEnv hpt mod of
963 Nothing -> panic "missing linkable"
964 Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
966 obj_linkable = isObjectLinkable (hm_linkable mod_info)
968 mod = ms_mod mod_summary
969 locn = ms_location mod_summary
974 unqual = cmGetPrintUnqual cms
975 -- showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
976 showBinding b = putStrLn (showSDocForUser unqual (ppr (getName b)))
978 io (mapM_ showBinding (cmGetBindings cms))
982 -----------------------------------------------------------------------------
985 data GHCiState = GHCiState
989 targets :: [FilePath],
991 options :: [GHCiOption]
995 = ShowTiming -- show time/allocs after evaluation
996 | ShowType -- show the type of expressions
997 | RevertCAFs -- revert CAFs after every evaluation
1000 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1002 startGHCi :: GHCi a -> GHCiState -> IO a
1003 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1005 instance Monad GHCi where
1006 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1007 return a = GHCi $ \s -> return a
1009 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1010 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1011 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1013 getGHCiState = GHCi $ \r -> readIORef r
1014 setGHCiState s = GHCi $ \r -> writeIORef r s
1016 -- for convenience...
1017 getCmState = getGHCiState >>= return . cmstate
1018 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
1020 isOptionSet :: GHCiOption -> GHCi Bool
1022 = do st <- getGHCiState
1023 return (opt `elem` options st)
1025 setOption :: GHCiOption -> GHCi ()
1027 = do st <- getGHCiState
1028 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1030 unsetOption :: GHCiOption -> GHCi ()
1032 = do st <- getGHCiState
1033 setGHCiState (st{ options = filter (/= opt) (options st) })
1035 io :: IO a -> GHCi a
1036 io m = GHCi { unGHCi = \s -> m >>= return }
1038 -----------------------------------------------------------------------------
1039 -- recursive exception handlers
1041 -- Don't forget to unblock async exceptions in the handler, or if we're
1042 -- in an exception loop (eg. let a = error a in a) the ^C exception
1043 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1045 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1046 ghciHandle h (GHCi m) = GHCi $ \s ->
1047 Exception.catch (m s)
1048 (\e -> unGHCi (ghciUnblock (h e)) s)
1050 ghciUnblock :: GHCi a -> GHCi a
1051 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1053 -----------------------------------------------------------------------------
1054 -- timing & statistics
1056 timeIt :: GHCi a -> GHCi a
1058 = do b <- isOptionSet ShowTiming
1061 else do allocs1 <- io $ getAllocations
1062 time1 <- io $ getCPUTime
1064 allocs2 <- io $ getAllocations
1065 time2 <- io $ getCPUTime
1066 io $ printTimes (fromIntegral (allocs2 - allocs1))
1070 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1071 -- defined in ghc/rts/Stats.c
1073 printTimes :: Integer -> Integer -> IO ()
1074 printTimes allocs psecs
1075 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1076 secs_str = showFFloat (Just 2) secs
1077 putStrLn (showSDoc (
1078 parens (text (secs_str "") <+> text "secs" <> comma <+>
1079 text (show allocs) <+> text "bytes")))
1081 -----------------------------------------------------------------------------
1088 -- Have to turn off buffering again, because we just
1089 -- reverted stdout, stderr & stdin to their defaults.
1091 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1092 -- Make it "safe", just in case
1094 -- -----------------------------------------------------------------------------
1097 expandPath :: String -> GHCi String
1099 case dropWhile isSpace path of
1101 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1102 return (tilde ++ '/':d)