1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.183 2005/01/18 12:18:19 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/ghcconfig.h"
16 #include "HsVersions.h"
19 import HscTypes ( HomeModInfo(hm_linkable), HomePackageTable,
20 isObjectLinkable, GhciMode(..) )
21 import IfaceSyn ( 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 Name ( Name, NamedThing(..) )
30 import OccName ( OccName, isSymOcc, occNameUserString )
31 import BasicTypes ( StrictnessMark(..), defaultFixity, SuccessFlag(..) )
33 import CmdLineOpts ( DynFlag(..), DynFlags(..), dopt_unset )
34 import Panic hiding ( showException )
36 import SrcLoc ( SrcLoc, isGoodSrcLoc )
38 #ifndef mingw32_HOST_OS
39 import DriverUtil( handle )
41 #if __GLASGOW_HASKELL__ > 504
47 import Control.Concurrent ( yield ) -- Used in readline loop
48 import System.Console.Readline as Readline
53 import Control.Exception as Exception
55 import Control.Concurrent
59 import Data.Int ( Int64 )
62 import System.Environment
63 import System.Directory
65 import System.IO.Error as IO
67 import Control.Monad as Monad
68 import Foreign.StablePtr ( newStablePtr )
70 import GHC.Exts ( unsafeCoerce# )
72 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
74 import System.Posix.Internals ( setNonBlockingFD )
76 -----------------------------------------------------------------------------
80 " / _ \\ /\\ /\\/ __(_)\n"++
81 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
82 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
83 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
85 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
87 builtin_commands :: [(String, String -> GHCi Bool)]
89 ("add", keepGoingPaths addModule),
90 ("browse", keepGoing browseCmd),
91 ("cd", keepGoing changeDirectory),
92 ("def", keepGoing defineMacro),
93 ("help", keepGoing help),
94 ("?", keepGoing help),
95 ("info", keepGoing info),
96 ("load", keepGoingPaths loadModule),
97 ("module", keepGoing setContext),
98 ("reload", keepGoing reloadModule),
99 ("set", keepGoing setCmd),
100 ("show", keepGoing showCmd),
101 ("type", keepGoing typeOfExpr),
102 ("kind", keepGoing kindOfType),
103 ("unset", keepGoing unsetOptions),
104 ("undef", keepGoing undefineMacro),
108 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
109 keepGoing a str = a str >> return False
111 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
112 keepGoingPaths a str = a (toArgs str) >> return False
114 shortHelpText = "use :? for help.\n"
116 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
118 " Commands available from the prompt:\n" ++
120 " <stmt> evaluate/run <stmt>\n" ++
121 " :add <filename> ... add module(s) to the current target set\n" ++
122 " :browse [*]<module> display the names defined by <module>\n" ++
123 " :cd <dir> change directory to <dir>\n" ++
124 " :def <cmd> <expr> define a command :<cmd>\n" ++
125 " :help, :? display this list of commands\n" ++
126 " :info [<name> ...] display information about the given names\n" ++
127 " :load <filename> ... load module(s) and their dependents\n" ++
128 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
129 " :reload reload the current module set\n" ++
131 " :set <option> ... set options\n" ++
132 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
133 " :set prog <progname> set the value returned by System.getProgName\n" ++
135 " :show modules show the currently loaded modules\n" ++
136 " :show bindings show the current bindings made at the prompt\n" ++
138 " :type <expr> show the type of <expr>\n" ++
139 " :kind <type> show the kind of <type>\n" ++
140 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
141 " :unset <option> ... unset options\n" ++
142 " :quit exit GHCi\n" ++
143 " :!<command> run the shell command <command>\n" ++
145 " Options for ':set' and ':unset':\n" ++
147 " +r revert top-level expressions after each evaluation\n" ++
148 " +s print timing/memory stats after each evaluation\n" ++
149 " +t print type after evaluation\n" ++
150 " -<flags> most GHC command line flags can also be set here\n" ++
151 " (eg. -v2, -fglasgow-exts, etc.)\n"
154 interactiveUI :: DynFlags -> [FilePath] -> Maybe String -> IO ()
155 interactiveUI dflags srcs maybe_expr = do
157 cmstate <- cmInit Interactive dflags;
159 -- HACK! If we happen to get into an infinite loop (eg the user
160 -- types 'let x=x in x' at the prompt), then the thread will block
161 -- on a blackhole, and become unreachable during GC. The GC will
162 -- detect that it is unreachable and send it the NonTermination
163 -- exception. However, since the thread is unreachable, everything
164 -- it refers to might be finalized, including the standard Handles.
165 -- This sounds like a bug, but we don't have a good solution right
172 hSetBuffering stdout NoBuffering
174 -- Initialise buffering for the *interpreted* I/O system
175 initInterpBuffering cmstate
177 -- We don't want the cmd line to buffer any input that might be
178 -- intended for the program, so unbuffer stdin.
179 hSetBuffering stdin NoBuffering
181 -- initial context is just the Prelude
182 cmstate <- cmSetContext cmstate [] ["Prelude"]
188 startGHCi (runGHCi srcs dflags maybe_expr)
189 GHCiState{ progname = "<interactive>",
196 Readline.resetTerminal Nothing
201 runGHCi :: [FilePath] -> DynFlags -> Maybe String -> GHCi ()
202 runGHCi paths dflags maybe_expr = do
203 read_dot_files <- io (readIORef v_Read_DotGHCi)
205 when (read_dot_files) $ do
208 exists <- io (doesFileExist file)
210 dir_ok <- io (checkPerms ".")
211 file_ok <- io (checkPerms file)
212 when (dir_ok && file_ok) $ do
213 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
216 Right hdl -> fileLoop hdl False
218 when (read_dot_files) $ do
219 -- Read in $HOME/.ghci
220 either_dir <- io (IO.try (getEnv "HOME"))
224 cwd <- io (getCurrentDirectory)
225 when (dir /= cwd) $ do
226 let file = dir ++ "/.ghci"
227 ok <- io (checkPerms file)
229 either_hdl <- io (IO.try (openFile file ReadMode))
232 Right hdl -> fileLoop hdl False
234 -- Perform a :load for files given on the GHCi command line
235 when (not (null paths)) $
236 ghciHandle showException $
239 -- if verbosity is greater than 0, or we are connected to a
240 -- terminal, display the prompt in the interactive loop.
241 is_tty <- io (hIsTerminalDevice stdin)
242 let show_prompt = verbosity dflags > 0 || is_tty
246 -- enter the interactive loop
247 interactiveLoop is_tty show_prompt
249 -- just evaluate the expression we were given
254 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
257 interactiveLoop is_tty show_prompt = do
258 -- Ignore ^C exceptions caught here
259 ghciHandleDyn (\e -> case e of
260 Interrupted -> ghciUnblock (interactiveLoop is_tty show_prompt)
261 _other -> return ()) $ do
263 -- read commands from stdin
267 else fileLoop stdin show_prompt
269 fileLoop stdin show_prompt
273 -- NOTE: We only read .ghci files if they are owned by the current user,
274 -- and aren't world writable. Otherwise, we could be accidentally
275 -- running code planted by a malicious third party.
277 -- Furthermore, We only read ./.ghci if . is owned by the current user
278 -- and isn't writable by anyone else. I think this is sufficient: we
279 -- don't need to check .. and ../.. etc. because "." always refers to
280 -- the same directory while a process is running.
282 checkPerms :: String -> IO Bool
284 #ifdef mingw32_HOST_OS
287 DriverUtil.handle (\_ -> return False) $ do
288 st <- getFileStatus name
290 if fileOwner st /= me then do
291 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
294 let mode = fileMode st
295 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
296 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
298 putStrLn $ "*** WARNING: " ++ name ++
299 " is writable by someone else, IGNORING!"
304 fileLoop :: Handle -> Bool -> GHCi ()
305 fileLoop hdl prompt = do
306 cmstate <- getCmState
307 (mod,imports) <- io (cmGetContext cmstate)
308 when prompt (io (putStr (mkPrompt mod imports)))
309 l <- io (IO.try (hGetLine hdl))
311 Left e | isEOFError e -> return ()
312 | otherwise -> io (ioError e)
314 case remove_spaces l of
315 "" -> fileLoop hdl prompt
316 l -> do quit <- runCommand l
317 if quit then return () else fileLoop hdl prompt
319 stringLoop :: [String] -> GHCi ()
320 stringLoop [] = return ()
321 stringLoop (s:ss) = do
322 case remove_spaces s of
324 l -> do quit <- runCommand l
325 if quit then return () else stringLoop ss
327 mkPrompt toplevs exports
328 = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
331 readlineLoop :: GHCi ()
333 cmstate <- getCmState
334 (mod,imports) <- io (cmGetContext cmstate)
336 l <- io (readline (mkPrompt mod imports)
337 `finally` setNonBlockingFD 0)
338 -- readline sometimes puts stdin into blocking mode,
339 -- so we need to put it back for the IO library
343 case remove_spaces l of
348 if quit then return () else readlineLoop
351 runCommand :: String -> GHCi Bool
352 runCommand c = ghciHandle handler (doCommand c)
354 -- This is the exception handler for exceptions generated by the
355 -- user's code; it normally just prints out the exception. The
356 -- handler must be recursive, in case showing the exception causes
357 -- more exceptions to be raised.
359 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
360 -- raising another exception. We therefore don't put the recursive
361 -- handler arond the flushing operation, so if stderr is closed
362 -- GHCi will just die gracefully rather than going into an infinite loop.
363 handler :: Exception -> GHCi Bool
364 handler exception = do
366 io installSignalHandlers
367 ghciHandle handler (showException exception >> return False)
369 showException (DynException dyn) =
370 case fromDynamic dyn of
371 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
372 Just Interrupted -> io (putStrLn "Interrupted.")
373 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
374 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
375 Just other_ghc_ex -> io (print other_ghc_ex)
377 showException other_exception
378 = io (putStrLn ("*** Exception: " ++ show other_exception))
380 doCommand (':' : command) = specialCommand command
382 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
385 runStmt :: String -> GHCi [Name]
387 | null (filter (not.isSpace) stmt) = return []
389 = do st <- getGHCiState
390 cmstate <- getCmState
391 (new_cmstate, result) <-
392 io $ withProgName (progname st) $ withArgs (args st) $
393 cmRunStmt cmstate stmt
394 setGHCiState st{cmstate = new_cmstate}
396 CmRunFailed -> return []
397 CmRunException e -> showException e >> return []
398 CmRunOk names -> return names
400 -- possibly print the type and revert CAFs after evaluating an expression
402 = do b <- isOptionSet ShowType
403 cmstate <- getCmState
404 when b (mapM_ (showTypeOfName cmstate) names)
407 io installSignalHandlers
408 b <- isOptionSet RevertCAFs
409 io (when b revertCAFs)
412 showTypeOfName :: CmState -> Name -> GHCi ()
413 showTypeOfName cmstate n
414 = do maybe_str <- io (cmTypeOfName cmstate n)
417 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
419 specialCommand :: String -> GHCi Bool
420 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
421 specialCommand str = do
422 let (cmd,rest) = break isSpace str
423 cmds <- io (readIORef commands)
424 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
425 [] -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
426 ++ shortHelpText) >> return False)
427 [(_,f)] -> f (dropWhile isSpace rest)
428 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
429 " matches multiple commands (" ++
430 foldr1 (\a b -> a ++ ',':b) (map fst cs)
431 ++ ")") >> return False)
433 noArgs c = throwDyn (CmdLineError ("command '" ++ c ++ "' takes no arguments"))
436 -----------------------------------------------------------------------------
437 -- To flush buffers for the *interpreted* computation we need
438 -- to refer to *its* stdout/stderr handles
440 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
441 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
443 no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++
444 " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
445 flush_cmd = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr"
447 initInterpBuffering :: CmState -> IO ()
448 initInterpBuffering cmstate
449 = do maybe_hval <- cmCompileExpr cmstate no_buf_cmd
452 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
453 other -> panic "interactiveUI:setBuffering"
455 maybe_hval <- cmCompileExpr cmstate flush_cmd
457 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
458 _ -> panic "interactiveUI:flush"
460 turnOffBuffering -- Turn it off right now
465 flushInterpBuffers :: GHCi ()
467 = io $ do Monad.join (readIORef flush_interp)
470 turnOffBuffering :: IO ()
472 = do Monad.join (readIORef turn_off_buffering)
475 -----------------------------------------------------------------------------
478 help :: String -> GHCi ()
479 help _ = io (putStr helpText)
481 info :: String -> GHCi ()
482 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
483 info s = do { let names = words s
484 ; init_cms <- getCmState
485 ; mapM_ (infoThing init_cms) names }
488 = do { stuff <- io (cmGetInfo cms name)
489 ; io (putStrLn (showSDocForUser (cmGetPrintUnqual cms) $
490 vcat (intersperse (text "") (map showThing stuff)))) }
492 showThing :: GetInfoResult -> SDoc
493 showThing (wanted_str, (thing, fixity, src_loc, insts))
494 = vcat [ showDecl want_name thing,
497 vcat (map show_inst insts)]
499 want_name occ = wanted_str == occNameUserString occ
502 | fix == defaultFixity = empty
503 | otherwise = ppr fix <+> text wanted_str
505 show_loc loc -- The ppr function for SrcLocs is a bit wonky
506 | isGoodSrcLoc loc = comment <+> ptext SLIT("Defined at") <+> ppr loc
507 | otherwise = comment <+> ppr loc
508 comment = ptext SLIT("--")
510 show_inst (iface_inst, loc)
511 = hang (ptext SLIT("instance") <+> ppr (ifInstHead iface_inst))
512 2 (char '\t' <> show_loc loc)
513 -- The tab tries to make them line up a bit
515 -- Now there is rather a lot of goop just to print declarations in a
516 -- civilised way with "..." for the parts we are less interested in.
518 showDecl :: (OccName -> Bool) -> IfaceDecl -> SDoc
519 showDecl want_name (IfaceForeign {ifName = tc})
520 = ppr tc <+> ptext SLIT("is a foreign type")
522 showDecl want_name (IfaceId {ifName = var, ifType = ty})
523 = ppr var <+> dcolon <+> ppr ty
525 showDecl want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty})
526 = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
527 2 (equals <+> ppr mono_ty)
529 showDecl want_name (IfaceData {ifName = tycon,
530 ifTyVars = tyvars, ifCons = condecls})
531 = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
532 2 (add_bars (ppr_trim show_con cs))
534 show_con (IfVanillaCon { ifConOcc = con_name, ifConInfix = is_infix, ifConArgTys = tys,
535 ifConStricts = strs, ifConFields = flds})
536 | want_name tycon || want_name con_name || any want_name flds
537 = Just (show_guts con_name is_infix tys_w_strs flds)
538 | otherwise = Nothing
540 tys_w_strs = tys `zip` (strs ++ repeat NotMarkedStrict)
541 show_con (IfGadtCon { ifConOcc = con_name, ifConTyVars = tvs, ifConCtxt = theta,
542 ifConArgTys = arg_tys, ifConResTys = res_tys, ifConStricts = strs })
543 | want_name tycon || want_name con_name
544 = Just (ppr_bndr con_name <+> colon <+> pprIfaceForAllPart tvs theta pp_tau)
545 | otherwise = Nothing
547 tys_w_strs = arg_tys `zip` (strs ++ repeat NotMarkedStrict)
548 pp_tau = foldr add pp_res_ty tys_w_strs
549 pp_res_ty = ppr_bndr tycon <+> hsep (map pprParendIfaceType res_tys)
550 add bty pp_ty = ppr_bangty bty <+> arrow <+> pp_ty
552 show_guts con True [ty1, ty2] flds = sep [ppr_bangty ty1, ppr con, ppr_bangty ty2]
553 show_guts con _ tys [] = ppr_bndr con <+> sep (map ppr_bangty tys)
554 show_guts con _ tys flds
555 = ppr_bndr con <+> braces (sep (punctuate comma (ppr_trim show_fld (tys `zip` flds))))
557 show_fld (bty, fld) | want_name tycon || want_name con || want_name fld
558 = Just (ppr_bndr fld <+> dcolon <+> ppr_bangty bty)
559 | otherwise = Nothing
561 (pp_nd, context, cs) = case condecls of
562 IfAbstractTyCon -> (ptext SLIT("data"), [], [])
563 IfDataTyCon (Just cxt) cs -> (ptext SLIT("data"), cxt, cs)
564 IfDataTyCon Nothing cs -> (ptext SLIT("data"), [], cs)
565 IfNewTyCon c -> (ptext SLIT("newtype"), [], [c])
568 add_bars [c] = equals <+> c
569 add_bars (c:cs) = equals <+> sep (c : map (char '|' <+>) cs)
571 ppr_bangty (ty, str) = ppr_str str <> pprParendIfaceType ty
572 ppr_str MarkedStrict = char '!'
573 ppr_str MarkedUnboxed = ptext SLIT("!!")
574 ppr_str NotMarkedStrict = empty
576 showDecl want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
577 ifFDs = fds, ifSigs = sigs})
578 = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars
579 <+> pprFundeps fds <+> ptext SLIT("where"))
580 2 (vcat (ppr_trim show_op sigs))
582 show_op (IfaceClassOp op dm ty)
583 | want_name clas || want_name op = Just (ppr_bndr op <+> dcolon <+> ppr ty)
584 | otherwise = Nothing
586 ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc]
588 = snd (foldr go (False, []) xs)
590 go x (eliding, so_far)
591 | Just doc <- show x = (False, doc : so_far)
592 | otherwise = if eliding then (True, so_far)
593 else (True, ptext SLIT("...") : so_far)
595 ppr_bndr :: OccName -> SDoc
596 -- Wrap operators in ()
597 ppr_bndr occ | isSymOcc occ = parens (ppr occ)
598 | otherwise = ppr occ
601 -----------------------------------------------------------------------------
604 addModule :: [FilePath] -> GHCi ()
606 state <- getGHCiState
607 io (revertCAFs) -- always revert CAFs on load/add.
608 files <- mapM expandPath files
609 let new_targets = files ++ targets state
610 graph <- io (cmDepAnal (cmstate state) new_targets)
611 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) graph)
612 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
613 setContextAfterLoad mods
614 dflags <- getDynFlags
615 modulesLoadedMsg ok mods dflags
617 changeDirectory :: String -> GHCi ()
618 changeDirectory dir = do
619 state <- getGHCiState
620 when (targets state /= []) $
621 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
622 cmstate1 <- io (cmUnload (cmstate state))
623 setGHCiState state{ cmstate = cmstate1, targets = [] }
624 setContextAfterLoad []
625 dir <- expandPath dir
626 io (setCurrentDirectory dir)
628 defineMacro :: String -> GHCi ()
630 let (macro_name, definition) = break isSpace s
631 cmds <- io (readIORef commands)
633 then throwDyn (CmdLineError "invalid macro name")
635 if (macro_name `elem` map fst cmds)
636 then throwDyn (CmdLineError
637 ("command '" ++ macro_name ++ "' is already defined"))
640 -- give the expression a type signature, so we can be sure we're getting
641 -- something of the right type.
642 let new_expr = '(' : definition ++ ") :: String -> IO String"
644 -- compile the expression
646 maybe_hv <- io (cmCompileExpr cms new_expr)
649 Just hv -> io (writeIORef commands --
650 ((macro_name, keepGoing (runMacro hv)) : cmds))
652 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
654 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
655 stringLoop (lines str)
657 undefineMacro :: String -> GHCi ()
658 undefineMacro macro_name = do
659 cmds <- io (readIORef commands)
660 if (macro_name `elem` map fst builtin_commands)
661 then throwDyn (CmdLineError
662 ("command '" ++ macro_name ++ "' cannot be undefined"))
664 if (macro_name `notElem` map fst cmds)
665 then throwDyn (CmdLineError
666 ("command '" ++ macro_name ++ "' not defined"))
668 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
671 loadModule :: [FilePath] -> GHCi ()
672 loadModule fs = timeIt (loadModule' fs)
674 loadModule' :: [FilePath] -> GHCi ()
675 loadModule' files = do
676 state <- getGHCiState
679 files <- mapM expandPath files
681 -- do the dependency anal first, so that if it fails we don't throw
682 -- away the current set of modules.
683 graph <- io (cmDepAnal (cmstate state) files)
685 -- Dependency anal ok, now unload everything
686 cmstate1 <- io (cmUnload (cmstate state))
687 setGHCiState state{ cmstate = cmstate1, targets = [] }
689 io (revertCAFs) -- always revert CAFs on load.
690 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 graph)
691 setGHCiState state{ cmstate = cmstate2, targets = files }
693 setContextAfterLoad mods
694 dflags <- getDynFlags
695 modulesLoadedMsg ok mods dflags
698 reloadModule :: String -> GHCi ()
700 state <- getGHCiState
701 case targets state of
702 [] -> io (putStr "no current target\n")
704 -- do the dependency anal first, so that if it fails we don't throw
705 -- away the current set of modules.
706 graph <- io (cmDepAnal (cmstate state) paths)
708 io (revertCAFs) -- always revert CAFs on reload.
710 <- io (cmLoadModules (cmstate state) graph)
711 setGHCiState state{ cmstate=cmstate1 }
712 setContextAfterLoad mods
713 dflags <- getDynFlags
714 modulesLoadedMsg ok mods dflags
716 reloadModule _ = noArgs ":reload"
718 setContextAfterLoad [] = setContext prel
719 setContextAfterLoad (m:_) = do
720 cmstate <- getCmState
721 b <- io (cmModuleIsInterpreted cmstate m)
722 if b then setContext ('*':m) else setContext m
724 modulesLoadedMsg ok mods dflags =
725 when (verbosity dflags > 0) $ do
727 | null mods = text "none."
729 punctuate comma (map text mods)) <> text "."
732 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
734 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
737 typeOfExpr :: String -> GHCi ()
739 = do cms <- getCmState
740 maybe_tystr <- io (cmTypeOfExpr cms str)
743 Just tystr -> io (putStrLn tystr)
745 kindOfType :: String -> GHCi ()
747 = do cms <- getCmState
748 maybe_tystr <- io (cmKindOfType cms str)
751 Just tystr -> io (putStrLn tystr)
753 quit :: String -> GHCi Bool
756 shellEscape :: String -> GHCi Bool
757 shellEscape str = io (system str >> return False)
759 -----------------------------------------------------------------------------
760 -- Browsing a module's contents
762 browseCmd :: String -> GHCi ()
765 ['*':m] | looksLikeModuleName m -> browseModule m False
766 [m] | looksLikeModuleName m -> browseModule m True
767 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
769 browseModule m exports_only = do
772 is_interpreted <- io (cmModuleIsInterpreted cms m)
773 when (not is_interpreted && not exports_only) $
774 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
776 -- Temporarily set the context to the module we're interested in,
777 -- just so we can get an appropriate PrintUnqualified
778 (as,bs) <- io (cmGetContext cms)
779 cms1 <- io (if exports_only then cmSetContext cms [] [prel,m]
780 else cmSetContext cms [m] [])
781 cms2 <- io (cmSetContext cms1 as bs)
783 things <- io (cmBrowseModule cms2 m exports_only)
785 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
787 io (putStrLn (showSDocForUser unqual (
788 vcat (map (showDecl (const True)) things)
791 -----------------------------------------------------------------------------
792 -- Setting the module context
795 | all sensible mods = fn mods
796 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
798 (fn, mods) = case str of
799 '+':stuff -> (addToContext, words stuff)
800 '-':stuff -> (removeFromContext, words stuff)
801 stuff -> (newContext, words stuff)
803 sensible ('*':m) = looksLikeModuleName m
804 sensible m = looksLikeModuleName m
808 (as,bs) <- separate cms mods [] []
809 let bs' = if null as && prel `notElem` bs then prel:bs else bs
810 cms' <- io (cmSetContext cms as bs')
813 separate cmstate [] as bs = return (as,bs)
814 separate cmstate (('*':m):ms) as bs = do
815 b <- io (cmModuleIsInterpreted cmstate m)
816 if b then separate cmstate ms (m:as) bs
817 else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
818 separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
823 addToContext mods = do
825 (as,bs) <- io (cmGetContext cms)
827 (as',bs') <- separate cms mods [] []
829 let as_to_add = as' \\ (as ++ bs)
830 bs_to_add = bs' \\ (as ++ bs)
832 cms' <- io (cmSetContext cms
833 (as ++ as_to_add) (bs ++ bs_to_add))
837 removeFromContext mods = do
839 (as,bs) <- io (cmGetContext cms)
841 (as_to_remove,bs_to_remove) <- separate cms mods [] []
843 let as' = as \\ (as_to_remove ++ bs_to_remove)
844 bs' = bs \\ (as_to_remove ++ bs_to_remove)
846 cms' <- io (cmSetContext cms as' bs')
849 ----------------------------------------------------------------------------
852 -- set options in the interpreter. Syntax is exactly the same as the
853 -- ghc command line, except that certain options aren't available (-C,
856 -- This is pretty fragile: most options won't work as expected. ToDo:
857 -- figure out which ones & disallow them.
859 setCmd :: String -> GHCi ()
861 = do st <- getGHCiState
862 let opts = options st
863 io $ putStrLn (showSDoc (
864 text "options currently set: " <>
867 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
871 ("args":args) -> setArgs args
872 ("prog":prog) -> setProg prog
873 wds -> setOptions wds
877 setGHCiState st{ args = args }
881 setGHCiState st{ progname = prog }
883 io (hPutStrLn stderr "syntax: :set prog <progname>")
886 do -- first, deal with the GHCi opts (+s, +t, etc.)
887 let (plus_opts, minus_opts) = partition isPlus wds
888 mapM_ setOpt plus_opts
890 -- now, the GHC flags
891 leftovers <- io $ processStaticFlags minus_opts
893 -- then, dynamic flags
894 dflags <- getDynFlags
895 (dflags',leftovers) <- io $ processDynamicFlags leftovers dflags
898 -- update things if the users wants more packages
900 let new_packages = pkgs_after \\ pkgs_before
901 when (not (null new_packages)) $
902 newPackages new_packages
905 if (not (null leftovers))
906 then throwDyn (CmdLineError ("unrecognised flags: " ++
911 unsetOptions :: String -> GHCi ()
913 = do -- first, deal with the GHCi opts (+s, +t, etc.)
915 (minus_opts, rest1) = partition isMinus opts
916 (plus_opts, rest2) = partition isPlus rest1
918 if (not (null rest2))
919 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
922 mapM_ unsetOpt plus_opts
924 -- can't do GHC flags for now
925 if (not (null minus_opts))
926 then throwDyn (CmdLineError "can't unset GHC command-line flags")
929 isMinus ('-':s) = True
932 isPlus ('+':s) = True
936 = case strToGHCiOpt str of
937 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
938 Just o -> setOption o
941 = case strToGHCiOpt str of
942 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
943 Just o -> unsetOption o
945 strToGHCiOpt :: String -> (Maybe GHCiOption)
946 strToGHCiOpt "s" = Just ShowTiming
947 strToGHCiOpt "t" = Just ShowType
948 strToGHCiOpt "r" = Just RevertCAFs
949 strToGHCiOpt _ = Nothing
951 optToStr :: GHCiOption -> String
952 optToStr ShowTiming = "s"
953 optToStr ShowType = "t"
954 optToStr RevertCAFs = "r"
956 newPackages new_pkgs = do -- The new packages are already in v_Packages
957 state <- getGHCiState
958 cmstate1 <- io (cmUnload (cmstate state))
959 setGHCiState state{ cmstate = cmstate1, targets = [] }
960 dflags <- getDynFlags
961 io (linkPackages dflags new_pkgs)
962 setContextAfterLoad []
964 -- ---------------------------------------------------------------------------
969 ["modules" ] -> showModules
970 ["bindings"] -> showBindings
971 ["linker"] -> io showLinkerState
972 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
975 = do { cms <- getCmState
976 ; let show_one ms = io (putStrLn (cmShowModule cms ms))
977 ; mapM_ show_one (cmGetModuleGraph cms) }
982 unqual = cmGetPrintUnqual cms
983 -- showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
984 showBinding b = putStrLn (showSDocForUser unqual (ppr (getName b)))
986 io (mapM_ showBinding (cmGetBindings cms))
990 -----------------------------------------------------------------------------
993 data GHCiState = GHCiState
997 targets :: [FilePath],
999 options :: [GHCiOption]
1003 = ShowTiming -- show time/allocs after evaluation
1004 | ShowType -- show the type of expressions
1005 | RevertCAFs -- revert CAFs after every evaluation
1008 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1010 startGHCi :: GHCi a -> GHCiState -> IO a
1011 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1013 instance Monad GHCi where
1014 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1015 return a = GHCi $ \s -> return a
1017 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1018 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1019 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1021 getGHCiState = GHCi $ \r -> readIORef r
1022 setGHCiState s = GHCi $ \r -> writeIORef r s
1024 -- for convenience...
1025 getCmState = getGHCiState >>= return . cmstate
1026 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
1028 getDynFlags = getCmState >>= return . cmGetDFlags
1030 setDynFlags dflags = do s <- getCmState; setCmState (cmSetDFlags s dflags)
1032 isOptionSet :: GHCiOption -> GHCi Bool
1034 = do st <- getGHCiState
1035 return (opt `elem` options st)
1037 setOption :: GHCiOption -> GHCi ()
1039 = do st <- getGHCiState
1040 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1042 unsetOption :: GHCiOption -> GHCi ()
1044 = do st <- getGHCiState
1045 setGHCiState (st{ options = filter (/= opt) (options st) })
1047 io :: IO a -> GHCi a
1048 io m = GHCi { unGHCi = \s -> m >>= return }
1050 -----------------------------------------------------------------------------
1051 -- recursive exception handlers
1053 -- Don't forget to unblock async exceptions in the handler, or if we're
1054 -- in an exception loop (eg. let a = error a in a) the ^C exception
1055 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1057 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1058 ghciHandle h (GHCi m) = GHCi $ \s ->
1059 Exception.catch (m s)
1060 (\e -> unGHCi (ghciUnblock (h e)) s)
1062 ghciUnblock :: GHCi a -> GHCi a
1063 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1065 -----------------------------------------------------------------------------
1066 -- timing & statistics
1068 timeIt :: GHCi a -> GHCi a
1070 = do b <- isOptionSet ShowTiming
1073 else do allocs1 <- io $ getAllocations
1074 time1 <- io $ getCPUTime
1076 allocs2 <- io $ getAllocations
1077 time2 <- io $ getCPUTime
1078 io $ printTimes (fromIntegral (allocs2 - allocs1))
1082 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1083 -- defined in ghc/rts/Stats.c
1085 printTimes :: Integer -> Integer -> IO ()
1086 printTimes allocs psecs
1087 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1088 secs_str = showFFloat (Just 2) secs
1089 putStrLn (showSDoc (
1090 parens (text (secs_str "") <+> text "secs" <> comma <+>
1091 text (show allocs) <+> text "bytes")))
1093 -----------------------------------------------------------------------------
1100 -- Have to turn off buffering again, because we just
1101 -- reverted stdout, stderr & stdin to their defaults.
1103 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1104 -- Make it "safe", just in case
1106 -- -----------------------------------------------------------------------------
1109 expandPath :: String -> GHCi String
1111 case dropWhile isSpace path of
1113 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1114 return (tilde ++ '/':d)