1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.179 2004/11/12 15:51:37 simonmar Exp $
5 -- GHC Interactive User Interface
7 -- (c) The GHC Team 2004
9 -----------------------------------------------------------------------------
10 module InteractiveUI (
11 interactiveUI, -- :: CmState -> [FilePath] -> IO ()
15 #include "../includes/ghcconfig.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 IfaceInst(..), 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
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
71 import Foreign.StablePtr ( newStablePtr )
73 import GHC.Exts ( unsafeCoerce# )
75 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
77 import System.Posix.Internals ( 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", keepGoingPaths 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", keepGoingPaths loadModule),
100 ("module", keepGoing setContext),
101 ("reload", keepGoing reloadModule),
102 ("set", keepGoing setCmd),
103 ("show", keepGoing showCmd),
104 ("type", keepGoing typeOfExpr),
105 ("kind", keepGoing kindOfType),
106 ("unset", keepGoing unsetOptions),
107 ("undef", keepGoing undefineMacro),
111 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
112 keepGoing a str = a str >> return False
114 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
115 keepGoingPaths a str = a (toArgs str) >> return False
117 shortHelpText = "use :? for help.\n"
119 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
121 " Commands available from the prompt:\n" ++
123 " <stmt> evaluate/run <stmt>\n" ++
124 " :add <filename> ... add module(s) to the current target set\n" ++
125 " :browse [*]<module> display the names defined by <module>\n" ++
126 " :cd <dir> change directory to <dir>\n" ++
127 " :def <cmd> <expr> define a command :<cmd>\n" ++
128 " :help, :? display this list of commands\n" ++
129 " :info [<name> ...] display information about the given names\n" ++
130 " :load <filename> ... load module(s) and their dependents\n" ++
131 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
132 " :reload reload the current module set\n" ++
134 " :set <option> ... set options\n" ++
135 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
136 " :set prog <progname> set the value returned by System.getProgName\n" ++
138 " :show modules show the currently loaded modules\n" ++
139 " :show bindings show the current bindings made at the prompt\n" ++
141 " :type <expr> show the type of <expr>\n" ++
142 " :kind <type> show the kind of <type>\n" ++
143 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
144 " :unset <option> ... unset options\n" ++
145 " :quit exit GHCi\n" ++
146 " :!<command> run the shell command <command>\n" ++
148 " Options for ':set' and ':unset':\n" ++
150 " +r revert top-level expressions after each evaluation\n" ++
151 " +s print timing/memory stats after each evaluation\n" ++
152 " +t print type after evaluation\n" ++
153 " -<flags> most GHC command line flags can also be set here\n" ++
154 " (eg. -v2, -fglasgow-exts, etc.)\n"
157 interactiveUI :: [FilePath] -> Maybe String -> IO ()
158 interactiveUI srcs maybe_expr = do
159 dflags <- getDynFlags
161 cmstate <- cmInit Interactive dflags;
163 -- HACK! If we happen to get into an infinite loop (eg the user
164 -- types 'let x=x in x' at the prompt), then the thread will block
165 -- on a blackhole, and become unreachable during GC. The GC will
166 -- detect that it is unreachable and send it the NonTermination
167 -- exception. However, since the thread is unreachable, everything
168 -- it refers to might be finalized, including the standard Handles.
169 -- This sounds like a bug, but we don't have a good solution right
176 hSetBuffering stdout NoBuffering
178 -- Initialise buffering for the *interpreted* I/O system
179 initInterpBuffering cmstate
181 -- We don't want the cmd line to buffer any input that might be
182 -- intended for the program, so unbuffer stdin.
183 hSetBuffering stdin NoBuffering
185 -- initial context is just the Prelude
186 cmstate <- cmSetContext cmstate [] ["Prelude"]
192 startGHCi (runGHCi srcs dflags maybe_expr)
193 GHCiState{ progname = "<interactive>",
200 Readline.resetTerminal Nothing
205 runGHCi :: [FilePath] -> DynFlags -> Maybe String -> GHCi ()
206 runGHCi paths dflags maybe_expr = do
207 read_dot_files <- io (readIORef v_Read_DotGHCi)
209 when (read_dot_files) $ do
212 exists <- io (doesFileExist file)
214 dir_ok <- io (checkPerms ".")
215 file_ok <- io (checkPerms file)
216 when (dir_ok && file_ok) $ do
217 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
220 Right hdl -> fileLoop hdl False
222 when (read_dot_files) $ do
223 -- Read in $HOME/.ghci
224 either_dir <- io (IO.try (getEnv "HOME"))
228 cwd <- io (getCurrentDirectory)
229 when (dir /= cwd) $ do
230 let file = dir ++ "/.ghci"
231 ok <- io (checkPerms file)
233 either_hdl <- io (IO.try (openFile file ReadMode))
236 Right hdl -> fileLoop hdl False
238 -- Perform a :load for files given on the GHCi command line
239 when (not (null paths)) $
240 ghciHandle showException $
243 -- if verbosity is greater than 0, or we are connected to a
244 -- terminal, display the prompt in the interactive loop.
245 is_tty <- io (hIsTerminalDevice stdin)
246 let show_prompt = verbosity dflags > 0 || is_tty
250 -- enter the interactive loop
251 interactiveLoop is_tty show_prompt
253 -- just evaluate the expression we were given
258 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
261 interactiveLoop is_tty show_prompt = do
262 -- Ignore ^C exceptions caught here
263 ghciHandleDyn (\e -> case e of
264 Interrupted -> ghciUnblock (interactiveLoop is_tty show_prompt)
265 _other -> return ()) $ do
267 -- read commands from stdin
271 else fileLoop stdin show_prompt
273 fileLoop stdin show_prompt
277 -- NOTE: We only read .ghci files if they are owned by the current user,
278 -- and aren't world writable. Otherwise, we could be accidentally
279 -- running code planted by a malicious third party.
281 -- Furthermore, We only read ./.ghci if . is owned by the current user
282 -- and isn't writable by anyone else. I think this is sufficient: we
283 -- don't need to check .. and ../.. etc. because "." always refers to
284 -- the same directory while a process is running.
286 checkPerms :: String -> IO Bool
288 #ifdef mingw32_HOST_OS
291 DriverUtil.handle (\_ -> return False) $ do
292 st <- getFileStatus name
294 if fileOwner st /= me then do
295 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
298 let mode = fileMode st
299 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
300 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
302 putStrLn $ "*** WARNING: " ++ name ++
303 " is writable by someone else, IGNORING!"
308 fileLoop :: Handle -> Bool -> GHCi ()
309 fileLoop hdl prompt = do
310 cmstate <- getCmState
311 (mod,imports) <- io (cmGetContext cmstate)
312 when prompt (io (putStr (mkPrompt mod imports)))
313 l <- io (IO.try (hGetLine hdl))
315 Left e | isEOFError e -> return ()
316 | otherwise -> io (ioError e)
318 case remove_spaces l of
319 "" -> fileLoop hdl prompt
320 l -> do quit <- runCommand l
321 if quit then return () else fileLoop hdl prompt
323 stringLoop :: [String] -> GHCi ()
324 stringLoop [] = return ()
325 stringLoop (s:ss) = do
326 case remove_spaces s of
328 l -> do quit <- runCommand l
329 if quit then return () else stringLoop ss
331 mkPrompt toplevs exports
332 = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
335 readlineLoop :: GHCi ()
337 cmstate <- getCmState
338 (mod,imports) <- io (cmGetContext cmstate)
340 l <- io (readline (mkPrompt mod imports)
341 `finally` setNonBlockingFD 0)
342 -- readline sometimes puts stdin into blocking mode,
343 -- so we need to put it back for the IO library
347 case remove_spaces l of
352 if quit then return () else readlineLoop
355 runCommand :: String -> GHCi Bool
356 runCommand c = ghciHandle handler (doCommand c)
358 -- This is the exception handler for exceptions generated by the
359 -- user's code; it normally just prints out the exception. The
360 -- handler must be recursive, in case showing the exception causes
361 -- more exceptions to be raised.
363 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
364 -- raising another exception. We therefore don't put the recursive
365 -- handler arond the flushing operation, so if stderr is closed
366 -- GHCi will just die gracefully rather than going into an infinite loop.
367 handler :: Exception -> GHCi Bool
368 handler exception = do
370 io installSignalHandlers
371 ghciHandle handler (showException exception >> return False)
373 showException (DynException dyn) =
374 case fromDynamic dyn of
375 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
376 Just Interrupted -> io (putStrLn "Interrupted.")
377 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
378 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
379 Just other_ghc_ex -> io (print other_ghc_ex)
381 showException other_exception
382 = io (putStrLn ("*** Exception: " ++ show other_exception))
384 doCommand (':' : command) = specialCommand command
386 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
389 runStmt :: String -> GHCi [Name]
391 | null (filter (not.isSpace) stmt) = return []
393 = do st <- getGHCiState
394 dflags <- io getDynFlags
395 let cm_state' = cmSetDFlags (cmstate st)
396 (dopt_unset dflags Opt_WarnUnusedBinds)
397 (new_cmstate, result) <-
398 io $ withProgName (progname st) $ withArgs (args st) $
399 cmRunStmt cm_state' stmt
400 setGHCiState st{cmstate = new_cmstate}
402 CmRunFailed -> return []
403 CmRunException e -> showException e >> return []
404 CmRunOk names -> return names
406 -- possibly print the type and revert CAFs after evaluating an expression
408 = do b <- isOptionSet ShowType
409 cmstate <- getCmState
410 when b (mapM_ (showTypeOfName cmstate) names)
413 io installSignalHandlers
414 b <- isOptionSet RevertCAFs
415 io (when b revertCAFs)
418 showTypeOfName :: CmState -> Name -> GHCi ()
419 showTypeOfName cmstate n
420 = do maybe_str <- io (cmTypeOfName cmstate n)
423 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
425 specialCommand :: String -> GHCi Bool
426 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
427 specialCommand str = do
428 let (cmd,rest) = break isSpace str
429 cmds <- io (readIORef commands)
430 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
431 [] -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
432 ++ shortHelpText) >> return False)
433 [(_,f)] -> f (dropWhile isSpace rest)
434 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
435 " matches multiple commands (" ++
436 foldr1 (\a b -> a ++ ',':b) (map fst cs)
437 ++ ")") >> return False)
439 noArgs c = throwDyn (CmdLineError ("command '" ++ c ++ "' takes no arguments"))
442 -----------------------------------------------------------------------------
443 -- To flush buffers for the *interpreted* computation we need
444 -- to refer to *its* stdout/stderr handles
446 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
447 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
449 no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++
450 " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
451 flush_cmd = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr"
453 initInterpBuffering :: CmState -> IO ()
454 initInterpBuffering cmstate
455 = do maybe_hval <- cmCompileExpr cmstate no_buf_cmd
458 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
459 other -> panic "interactiveUI:setBuffering"
461 maybe_hval <- cmCompileExpr cmstate flush_cmd
463 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
464 _ -> panic "interactiveUI:flush"
466 turnOffBuffering -- Turn it off right now
471 flushInterpBuffers :: GHCi ()
473 = io $ do Monad.join (readIORef flush_interp)
476 turnOffBuffering :: IO ()
478 = do Monad.join (readIORef turn_off_buffering)
481 -----------------------------------------------------------------------------
484 help :: String -> GHCi ()
485 help _ = io (putStr helpText)
487 info :: String -> GHCi ()
488 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
489 info s = do { let names = words s
490 ; init_cms <- getCmState
491 ; mapM_ (infoThing init_cms) names }
494 = do { stuff <- io (cmGetInfo cms name)
495 ; io (putStrLn (showSDocForUser (cmGetPrintUnqual cms) $
496 vcat (intersperse (text "") (map showThing stuff)))) }
498 showThing :: GetInfoResult -> SDoc
499 showThing (wanted_str, (thing, fixity, src_loc, insts))
500 = vcat [ showDecl want_name thing,
503 vcat (map show_inst insts)]
505 want_name occ = wanted_str == occNameUserString occ
508 | fix == defaultFixity = empty
509 | otherwise = ppr fix <+> text wanted_str
511 show_loc loc -- The ppr function for SrcLocs is a bit wonky
512 | isGoodSrcLoc loc = comment <+> ptext SLIT("Defined at") <+> ppr loc
513 | otherwise = comment <+> ppr loc
514 comment = ptext SLIT("--")
516 show_inst (iface_inst, loc)
517 = hang (ptext SLIT("instance") <+> ppr (ifInstHead iface_inst))
518 2 (char '\t' <> show_loc loc)
519 -- The tab tries to make them line up a bit
521 -- Now there is rather a lot of goop just to print declarations in a
522 -- civilised way with "..." for the parts we are less interested in.
524 showDecl :: (OccName -> Bool) -> IfaceDecl -> SDoc
525 showDecl want_name (IfaceForeign {ifName = tc})
526 = ppr tc <+> ptext SLIT("is a foreign type")
528 showDecl want_name (IfaceId {ifName = var, ifType = ty})
529 = ppr var <+> dcolon <+> ppr ty
531 showDecl want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty})
532 = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
533 2 (equals <+> ppr mono_ty)
535 showDecl want_name (IfaceData {ifName = tycon,
536 ifTyVars = tyvars, ifCons = condecls})
537 = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
538 2 (add_bars (ppr_trim show_con cs))
540 show_con (IfVanillaCon { ifConOcc = con_name, ifConInfix = is_infix, ifConArgTys = tys,
541 ifConStricts = strs, ifConFields = flds})
542 | want_name tycon || want_name con_name || any want_name flds
543 = Just (show_guts con_name is_infix tys_w_strs flds)
544 | otherwise = Nothing
546 tys_w_strs = tys `zip` (strs ++ repeat NotMarkedStrict)
547 show_con (IfGadtCon { ifConOcc = con_name, ifConTyVars = tvs, ifConCtxt = theta,
548 ifConArgTys = arg_tys, ifConResTys = res_tys, ifConStricts = strs })
549 | want_name tycon || want_name con_name
550 = Just (ppr_bndr con_name <+> colon <+> pprIfaceForAllPart tvs theta pp_tau)
551 | otherwise = Nothing
553 tys_w_strs = arg_tys `zip` (strs ++ repeat NotMarkedStrict)
554 pp_tau = foldr add pp_res_ty tys_w_strs
555 pp_res_ty = ppr_bndr tycon <+> hsep (map pprParendIfaceType res_tys)
556 add bty pp_ty = ppr_bangty bty <+> arrow <+> pp_ty
558 show_guts con True [ty1, ty2] flds = sep [ppr_bangty ty1, ppr con, ppr_bangty ty2]
559 show_guts con _ tys [] = ppr_bndr con <+> sep (map ppr_bangty tys)
560 show_guts con _ tys flds
561 = ppr_bndr con <+> braces (sep (punctuate comma (ppr_trim show_fld (tys `zip` flds))))
563 show_fld (bty, fld) | want_name tycon || want_name con || want_name fld
564 = Just (ppr_bndr fld <+> dcolon <+> ppr_bangty bty)
565 | otherwise = Nothing
567 (pp_nd, context, cs) = case condecls of
568 IfAbstractTyCon -> (ptext SLIT("data"), [], [])
569 IfDataTyCon (Just cxt) cs -> (ptext SLIT("data"), cxt, cs)
570 IfDataTyCon Nothing cs -> (ptext SLIT("data"), [], cs)
571 IfNewTyCon c -> (ptext SLIT("newtype"), [], [c])
574 add_bars [c] = equals <+> c
575 add_bars (c:cs) = equals <+> sep (c : map (char '|' <+>) cs)
577 ppr_bangty (ty, str) = ppr_str str <> pprParendIfaceType ty
578 ppr_str MarkedStrict = char '!'
579 ppr_str MarkedUnboxed = ptext SLIT("!!")
580 ppr_str NotMarkedStrict = empty
582 showDecl want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
583 ifFDs = fds, ifSigs = sigs})
584 = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars
585 <+> pprFundeps fds <+> ptext SLIT("where"))
586 2 (vcat (ppr_trim show_op sigs))
588 show_op (IfaceClassOp op dm ty)
589 | want_name clas || want_name op = Just (ppr_bndr op <+> dcolon <+> ppr ty)
590 | otherwise = Nothing
592 ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc]
594 = snd (foldr go (False, []) xs)
596 go x (eliding, so_far)
597 | Just doc <- show x = (False, doc : so_far)
598 | otherwise = if eliding then (True, so_far)
599 else (True, ptext SLIT("...") : so_far)
601 ppr_bndr :: OccName -> SDoc
602 -- Wrap operators in ()
603 ppr_bndr occ | isSymOcc occ = parens (ppr occ)
604 | otherwise = ppr occ
607 -----------------------------------------------------------------------------
610 addModule :: [FilePath] -> GHCi ()
612 state <- getGHCiState
613 io (revertCAFs) -- always revert CAFs on load/add.
614 files <- mapM expandPath files
615 let new_targets = files ++ targets state
616 graph <- io (cmDepAnal (cmstate state) new_targets)
617 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) graph)
618 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
619 setContextAfterLoad mods
620 dflags <- io getDynFlags
621 modulesLoadedMsg ok mods dflags
623 changeDirectory :: String -> GHCi ()
624 changeDirectory dir = do
625 state <- getGHCiState
626 when (targets state /= []) $
627 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
628 cmstate1 <- io (cmUnload (cmstate state))
629 setGHCiState state{ cmstate = cmstate1, targets = [] }
630 setContextAfterLoad []
631 dir <- expandPath dir
632 io (setCurrentDirectory dir)
634 defineMacro :: String -> GHCi ()
636 let (macro_name, definition) = break isSpace s
637 cmds <- io (readIORef commands)
639 then throwDyn (CmdLineError "invalid macro name")
641 if (macro_name `elem` map fst cmds)
642 then throwDyn (CmdLineError
643 ("command '" ++ macro_name ++ "' is already defined"))
646 -- give the expression a type signature, so we can be sure we're getting
647 -- something of the right type.
648 let new_expr = '(' : definition ++ ") :: String -> IO String"
650 -- compile the expression
652 maybe_hv <- io (cmCompileExpr cms new_expr)
655 Just hv -> io (writeIORef commands --
656 ((macro_name, keepGoing (runMacro hv)) : cmds))
658 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
660 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
661 stringLoop (lines str)
663 undefineMacro :: String -> GHCi ()
664 undefineMacro macro_name = do
665 cmds <- io (readIORef commands)
666 if (macro_name `elem` map fst builtin_commands)
667 then throwDyn (CmdLineError
668 ("command '" ++ macro_name ++ "' cannot be undefined"))
670 if (macro_name `notElem` map fst cmds)
671 then throwDyn (CmdLineError
672 ("command '" ++ macro_name ++ "' not defined"))
674 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
677 loadModule :: [FilePath] -> GHCi ()
678 loadModule fs = timeIt (loadModule' fs)
680 loadModule' :: [FilePath] -> GHCi ()
681 loadModule' files = do
682 state <- getGHCiState
685 files <- mapM expandPath files
687 -- do the dependency anal first, so that if it fails we don't throw
688 -- away the current set of modules.
689 graph <- io (cmDepAnal (cmstate state) files)
691 -- Dependency anal ok, now unload everything
692 cmstate1 <- io (cmUnload (cmstate state))
693 setGHCiState state{ cmstate = cmstate1, targets = [] }
695 io (revertCAFs) -- always revert CAFs on load.
696 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 graph)
697 setGHCiState state{ cmstate = cmstate2, targets = files }
699 setContextAfterLoad mods
700 dflags <- io (getDynFlags)
701 modulesLoadedMsg ok mods dflags
704 reloadModule :: String -> GHCi ()
706 state <- getGHCiState
707 case targets state of
708 [] -> io (putStr "no current target\n")
710 -- do the dependency anal first, so that if it fails we don't throw
711 -- away the current set of modules.
712 graph <- io (cmDepAnal (cmstate state) paths)
714 io (revertCAFs) -- always revert CAFs on reload.
716 <- io (cmLoadModules (cmstate state) graph)
717 setGHCiState state{ cmstate=cmstate1 }
718 setContextAfterLoad mods
719 dflags <- io getDynFlags
720 modulesLoadedMsg ok mods dflags
722 reloadModule _ = noArgs ":reload"
724 setContextAfterLoad [] = setContext prel
725 setContextAfterLoad (m:_) = do
726 cmstate <- getCmState
727 b <- io (cmModuleIsInterpreted cmstate m)
728 if b then setContext ('*':m) else setContext m
730 modulesLoadedMsg ok mods dflags =
731 when (verbosity dflags > 0) $ do
733 | null mods = text "none."
735 punctuate comma (map text mods)) <> text "."
738 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
740 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
743 typeOfExpr :: String -> GHCi ()
745 = do cms <- getCmState
746 maybe_tystr <- io (cmTypeOfExpr cms str)
749 Just tystr -> io (putStrLn tystr)
751 kindOfType :: String -> GHCi ()
753 = do cms <- getCmState
754 maybe_tystr <- io (cmKindOfType cms str)
757 Just tystr -> io (putStrLn tystr)
759 quit :: String -> GHCi Bool
762 shellEscape :: String -> GHCi Bool
763 shellEscape str = io (system str >> return False)
765 -----------------------------------------------------------------------------
766 -- Browsing a module's contents
768 browseCmd :: String -> GHCi ()
771 ['*':m] | looksLikeModuleName m -> browseModule m False
772 [m] | looksLikeModuleName m -> browseModule m True
773 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
775 browseModule m exports_only = do
778 is_interpreted <- io (cmModuleIsInterpreted cms m)
779 when (not is_interpreted && not exports_only) $
780 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
782 -- Temporarily set the context to the module we're interested in,
783 -- just so we can get an appropriate PrintUnqualified
784 (as,bs) <- io (cmGetContext cms)
785 cms1 <- io (if exports_only then cmSetContext cms [] [prel,m]
786 else cmSetContext cms [m] [])
787 cms2 <- io (cmSetContext cms1 as bs)
789 things <- io (cmBrowseModule cms2 m exports_only)
791 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
793 io (putStrLn (showSDocForUser unqual (
794 vcat (map (showDecl (const True)) things)
797 -----------------------------------------------------------------------------
798 -- Setting the module context
801 | all sensible mods = fn mods
802 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
804 (fn, mods) = case str of
805 '+':stuff -> (addToContext, words stuff)
806 '-':stuff -> (removeFromContext, words stuff)
807 stuff -> (newContext, words stuff)
809 sensible ('*':m) = looksLikeModuleName m
810 sensible m = looksLikeModuleName m
814 (as,bs) <- separate cms mods [] []
815 let bs' = if null as && prel `notElem` bs then prel:bs else bs
816 cms' <- io (cmSetContext cms as bs')
819 separate cmstate [] as bs = return (as,bs)
820 separate cmstate (('*':m):ms) as bs = do
821 b <- io (cmModuleIsInterpreted cmstate m)
822 if b then separate cmstate ms (m:as) bs
823 else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
824 separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
829 addToContext mods = do
831 (as,bs) <- io (cmGetContext cms)
833 (as',bs') <- separate cms mods [] []
835 let as_to_add = as' \\ (as ++ bs)
836 bs_to_add = bs' \\ (as ++ bs)
838 cms' <- io (cmSetContext cms
839 (as ++ as_to_add) (bs ++ bs_to_add))
843 removeFromContext mods = do
845 (as,bs) <- io (cmGetContext cms)
847 (as_to_remove,bs_to_remove) <- separate cms mods [] []
849 let as' = as \\ (as_to_remove ++ bs_to_remove)
850 bs' = bs \\ (as_to_remove ++ bs_to_remove)
852 cms' <- io (cmSetContext cms as' bs')
855 ----------------------------------------------------------------------------
858 -- set options in the interpreter. Syntax is exactly the same as the
859 -- ghc command line, except that certain options aren't available (-C,
862 -- This is pretty fragile: most options won't work as expected. ToDo:
863 -- figure out which ones & disallow them.
865 setCmd :: String -> GHCi ()
867 = do st <- getGHCiState
868 let opts = options st
869 io $ putStrLn (showSDoc (
870 text "options currently set: " <>
873 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
877 ("args":args) -> setArgs args
878 ("prog":prog) -> setProg prog
879 wds -> setOptions wds
883 setGHCiState st{ args = args }
887 setGHCiState st{ progname = prog }
889 io (hPutStrLn stderr "syntax: :set prog <progname>")
892 do -- first, deal with the GHCi opts (+s, +t, etc.)
893 let (plus_opts, minus_opts) = partition isPlus wds
894 mapM_ setOpt plus_opts
896 -- now, the GHC flags
897 pkgs_before <- io (readIORef v_ExplicitPackages)
898 leftovers <- io (processArgs static_flags minus_opts [])
899 pkgs_after <- io (readIORef v_ExplicitPackages)
901 -- update things if the users wants more packages
902 let new_packages = pkgs_after \\ pkgs_before
903 when (not (null new_packages)) $
904 newPackages new_packages
906 -- don't forget about the extra command-line flags from the
907 -- extra_ghc_opts fields in the new packages
908 new_package_details <- io (getPackageDetails new_packages)
910 -- then, dynamic flags
913 leftovers <- processArgs dynamic_flags leftovers []
916 if (not (null leftovers))
917 then throwDyn (CmdLineError ("unrecognised flags: " ++
922 unsetOptions :: String -> GHCi ()
924 = do -- first, deal with the GHCi opts (+s, +t, etc.)
926 (minus_opts, rest1) = partition isMinus opts
927 (plus_opts, rest2) = partition isPlus rest1
929 if (not (null rest2))
930 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
933 mapM_ unsetOpt plus_opts
935 -- can't do GHC flags for now
936 if (not (null minus_opts))
937 then throwDyn (CmdLineError "can't unset GHC command-line flags")
940 isMinus ('-':s) = True
943 isPlus ('+':s) = True
947 = case strToGHCiOpt str of
948 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
949 Just o -> setOption o
952 = case strToGHCiOpt str of
953 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
954 Just o -> unsetOption o
956 strToGHCiOpt :: String -> (Maybe GHCiOption)
957 strToGHCiOpt "s" = Just ShowTiming
958 strToGHCiOpt "t" = Just ShowType
959 strToGHCiOpt "r" = Just RevertCAFs
960 strToGHCiOpt _ = Nothing
962 optToStr :: GHCiOption -> String
963 optToStr ShowTiming = "s"
964 optToStr ShowType = "t"
965 optToStr RevertCAFs = "r"
967 newPackages new_pkgs = do -- The new packages are already in v_Packages
968 state <- getGHCiState
969 cmstate1 <- io (cmUnload (cmstate state))
970 setGHCiState state{ cmstate = cmstate1, targets = [] }
971 dflags <- io getDynFlags
972 io (linkPackages dflags new_pkgs)
973 setContextAfterLoad []
975 -- ---------------------------------------------------------------------------
980 ["modules" ] -> showModules
981 ["bindings"] -> showBindings
982 ["linker"] -> io showLinkerState
983 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
987 let (mg, hpt) = cmGetModInfo cms
988 mapM_ (showModule hpt) mg
991 showModule :: HomePackageTable -> ModSummary -> GHCi ()
992 showModule hpt mod_summary
993 = case lookupModuleEnv hpt mod of
994 Nothing -> panic "missing linkable"
995 Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
997 obj_linkable = isObjectLinkable (hm_linkable mod_info)
999 mod = ms_mod mod_summary
1000 locn = ms_location mod_summary
1005 unqual = cmGetPrintUnqual cms
1006 -- showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
1007 showBinding b = putStrLn (showSDocForUser unqual (ppr (getName b)))
1009 io (mapM_ showBinding (cmGetBindings cms))
1013 -----------------------------------------------------------------------------
1016 data GHCiState = GHCiState
1020 targets :: [FilePath],
1022 options :: [GHCiOption]
1026 = ShowTiming -- show time/allocs after evaluation
1027 | ShowType -- show the type of expressions
1028 | RevertCAFs -- revert CAFs after every evaluation
1031 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1033 startGHCi :: GHCi a -> GHCiState -> IO a
1034 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1036 instance Monad GHCi where
1037 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1038 return a = GHCi $ \s -> return a
1040 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1041 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1042 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1044 getGHCiState = GHCi $ \r -> readIORef r
1045 setGHCiState s = GHCi $ \r -> writeIORef r s
1047 -- for convenience...
1048 getCmState = getGHCiState >>= return . cmstate
1049 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
1051 isOptionSet :: GHCiOption -> GHCi Bool
1053 = do st <- getGHCiState
1054 return (opt `elem` options st)
1056 setOption :: GHCiOption -> GHCi ()
1058 = do st <- getGHCiState
1059 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1061 unsetOption :: GHCiOption -> GHCi ()
1063 = do st <- getGHCiState
1064 setGHCiState (st{ options = filter (/= opt) (options st) })
1066 io :: IO a -> GHCi a
1067 io m = GHCi { unGHCi = \s -> m >>= return }
1069 -----------------------------------------------------------------------------
1070 -- recursive exception handlers
1072 -- Don't forget to unblock async exceptions in the handler, or if we're
1073 -- in an exception loop (eg. let a = error a in a) the ^C exception
1074 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1076 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1077 ghciHandle h (GHCi m) = GHCi $ \s ->
1078 Exception.catch (m s)
1079 (\e -> unGHCi (ghciUnblock (h e)) s)
1081 ghciUnblock :: GHCi a -> GHCi a
1082 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1084 -----------------------------------------------------------------------------
1085 -- timing & statistics
1087 timeIt :: GHCi a -> GHCi a
1089 = do b <- isOptionSet ShowTiming
1092 else do allocs1 <- io $ getAllocations
1093 time1 <- io $ getCPUTime
1095 allocs2 <- io $ getAllocations
1096 time2 <- io $ getCPUTime
1097 io $ printTimes (fromIntegral (allocs2 - allocs1))
1101 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1102 -- defined in ghc/rts/Stats.c
1104 printTimes :: Integer -> Integer -> IO ()
1105 printTimes allocs psecs
1106 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1107 secs_str = showFFloat (Just 2) secs
1108 putStrLn (showSDoc (
1109 parens (text (secs_str "") <+> text "secs" <> comma <+>
1110 text (show allocs) <+> text "bytes")))
1112 -----------------------------------------------------------------------------
1119 -- Have to turn off buffering again, because we just
1120 -- reverted stdout, stderr & stdin to their defaults.
1122 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1123 -- Make it "safe", just in case
1125 -- -----------------------------------------------------------------------------
1128 expandPath :: String -> GHCi String
1130 case dropWhile isSpace path of
1132 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1133 return (tilde ++ '/':d)