1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005
8 -----------------------------------------------------------------------------
14 #include "HsVersions.h"
18 import GHC ( Session, verbosity, dopt, DynFlag(..), Target(..),
19 TargetId(..), DynFlags(..),
20 pprModule, Type, Module, SuccessFlag(..),
21 TyThing(..), Name, LoadHowMuch(..), Phase,
22 GhcException(..), showGhcException,
23 CheckedModule(..), SrcLoc )
24 import Packages ( PackageState(..) )
25 import PackageConfig ( InstalledPackageInfo(..) )
26 import UniqFM ( eltsUFM )
30 -- for createtags (should these come via GHC?)
31 import Module ( moduleString )
32 import Name ( nameSrcLoc, nameModule, nameOccName )
33 import OccName ( pprOccName )
34 import SrcLoc ( isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol )
36 -- Other random utilities
37 import Digraph ( flattenSCCs )
38 import BasicTypes ( failed, successIf )
39 import Panic ( panic, installSignalHandlers )
41 import StaticFlags ( opt_IgnoreDotGhci )
42 import Linker ( showLinkerState )
43 import Util ( removeSpaces, handle, global, toArgs,
44 looksLikeModuleName, prefixMatch, sortLe )
46 #ifndef mingw32_HOST_OS
48 #if __GLASGOW_HASKELL__ > 504
52 import GHC.ConsoleHandler ( flushConsole )
56 import Control.Concurrent ( yield ) -- Used in readline loop
57 import System.Console.Readline as Readline
62 import Control.Exception as Exception
64 -- import Control.Concurrent
68 import Data.Int ( Int64 )
69 import Data.Maybe ( isJust, fromMaybe, catMaybes )
72 import System.Environment
73 import System.Exit ( exitWith, ExitCode(..) )
74 import System.Directory
76 import System.IO.Error as IO
78 import Control.Monad as Monad
79 import Foreign.StablePtr ( newStablePtr )
82 import GHC.Exts ( unsafeCoerce# )
83 import GHC.IOBase ( IOErrorType(InvalidArgument) )
85 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
87 import System.Posix.Internals ( setNonBlockingFD )
89 -----------------------------------------------------------------------------
93 " / _ \\ /\\ /\\/ __(_)\n"++
94 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
95 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
96 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
98 type Command = (String, String -> GHCi Bool, String -> IO [String])
101 GLOBAL_VAR(commands, builtin_commands, [Command])
103 builtin_commands :: [Command]
105 ("add", keepGoingPaths addModule, completeFilename),
106 ("browse", keepGoing browseCmd, completeModule),
107 ("cd", keepGoing changeDirectory, completeFilename),
108 ("def", keepGoing defineMacro, completeIdentifier),
109 ("help", keepGoing help, completeNone),
110 ("?", keepGoing help, completeNone),
111 ("info", keepGoing info, completeIdentifier),
112 ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),
113 ("module", keepGoing setContext, completeModule),
114 ("main", keepGoing runMain, completeIdentifier),
115 ("reload", keepGoing reloadModule, completeNone),
116 ("check", keepGoing checkModule, completeHomeModule),
117 ("set", keepGoing setCmd, completeNone), -- ToDo
118 ("show", keepGoing showCmd, completeNone),
119 ("etags", keepGoing createETagsFileCmd, completeFilename),
120 ("ctags", keepGoing createCTagsFileCmd, completeFilename),
121 ("type", keepGoing typeOfExpr, completeIdentifier),
122 ("kind", keepGoing kindOfType, completeIdentifier),
123 ("unset", keepGoing unsetOptions, completeNone), -- ToDo
124 ("undef", keepGoing undefineMacro, completeNone), -- ToDo
125 ("quit", quit, completeNone)
128 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
129 keepGoing a str = a str >> return False
131 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
132 keepGoingPaths a str = a (toArgs str) >> return False
134 shortHelpText = "use :? for help.\n"
136 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
138 " Commands available from the prompt:\n" ++
140 " <stmt> evaluate/run <stmt>\n" ++
141 " :add <filename> ... add module(s) to the current target set\n" ++
142 " :browse [*]<module> display the names defined by <module>\n" ++
143 " :cd <dir> change directory to <dir>\n" ++
144 " :def <cmd> <expr> define a command :<cmd>\n" ++
145 " :help, :? display this list of commands\n" ++
146 " :info [<name> ...] display information about the given names\n" ++
147 " :load <filename> ... load module(s) and their dependents\n" ++
148 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
149 " :main [<arguments> ...] run the main function with the given arguments\n" ++
150 " :reload reload the current module set\n" ++
152 " :set <option> ... set options\n" ++
153 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
154 " :set prog <progname> set the value returned by System.getProgName\n" ++
156 " :show modules show the currently loaded modules\n" ++
157 " :show bindings show the current bindings made at the prompt\n" ++
159 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
160 " :etags [<file>] create tags file for Emacs (defauilt: \"TAGS\")\n" ++
161 " :type <expr> show the type of <expr>\n" ++
162 " :kind <type> show the kind of <type>\n" ++
163 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
164 " :unset <option> ... unset options\n" ++
165 " :quit exit GHCi\n" ++
166 " :!<command> run the shell command <command>\n" ++
168 " Options for ':set' and ':unset':\n" ++
170 " +r revert top-level expressions after each evaluation\n" ++
171 " +s print timing/memory stats after each evaluation\n" ++
172 " +t print type after evaluation\n" ++
173 " -<flags> most GHC command line flags can also be set here\n" ++
174 " (eg. -v2, -fglasgow-exts, etc.)\n"
177 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
178 interactiveUI session srcs maybe_expr = do
180 -- HACK! If we happen to get into an infinite loop (eg the user
181 -- types 'let x=x in x' at the prompt), then the thread will block
182 -- on a blackhole, and become unreachable during GC. The GC will
183 -- detect that it is unreachable and send it the NonTermination
184 -- exception. However, since the thread is unreachable, everything
185 -- it refers to might be finalized, including the standard Handles.
186 -- This sounds like a bug, but we don't have a good solution right
193 hSetBuffering stdout NoBuffering
195 -- Initialise buffering for the *interpreted* I/O system
196 initInterpBuffering session
198 -- We don't want the cmd line to buffer any input that might be
199 -- intended for the program, so unbuffer stdin.
200 hSetBuffering stdin NoBuffering
202 -- initial context is just the Prelude
203 GHC.setContext session [] [prelude_mod]
207 Readline.setAttemptedCompletionFunction (Just completeWord)
208 --Readline.parseAndBind "set show-all-if-ambiguous 1"
210 let symbols = "!#$%&*+/<=>?@\\^|-~"
211 specials = "(),;[]`{}"
213 word_break_chars = spaces ++ specials ++ symbols
215 Readline.setBasicWordBreakCharacters word_break_chars
216 Readline.setCompleterWordBreakCharacters word_break_chars
219 startGHCi (runGHCi srcs maybe_expr)
220 GHCiState{ progname = "<interactive>",
226 Readline.resetTerminal Nothing
231 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
232 runGHCi paths maybe_expr = do
233 let read_dot_files = not opt_IgnoreDotGhci
235 when (read_dot_files) $ do
238 exists <- io (doesFileExist file)
240 dir_ok <- io (checkPerms ".")
241 file_ok <- io (checkPerms file)
242 when (dir_ok && file_ok) $ do
243 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
246 Right hdl -> fileLoop hdl False
248 when (read_dot_files) $ do
249 -- Read in $HOME/.ghci
250 either_dir <- io (IO.try (getEnv "HOME"))
254 cwd <- io (getCurrentDirectory)
255 when (dir /= cwd) $ do
256 let file = dir ++ "/.ghci"
257 ok <- io (checkPerms file)
259 either_hdl <- io (IO.try (openFile file ReadMode))
262 Right hdl -> fileLoop hdl False
264 -- Perform a :load for files given on the GHCi command line
265 -- When in -e mode, if the load fails then we want to stop
266 -- immediately rather than going on to evaluate the expression.
267 when (not (null paths)) $ do
268 ok <- ghciHandle (\e -> do showException e; return Failed) $
270 when (isJust maybe_expr && failed ok) $
271 io (exitWith (ExitFailure 1))
273 -- if verbosity is greater than 0, or we are connected to a
274 -- terminal, display the prompt in the interactive loop.
275 is_tty <- io (hIsTerminalDevice stdin)
276 dflags <- getDynFlags
277 let show_prompt = verbosity dflags > 0 || is_tty
281 #if defined(mingw32_HOST_OS)
283 -- The win32 Console API mutates the first character of
284 -- type-ahead when reading from it in a non-buffered manner. Work
285 -- around this by flushing the input buffer of type-ahead characters,
286 -- but only if stdin is available.
287 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
289 Left err | isDoesNotExistError err -> return ()
290 | otherwise -> io (ioError err)
291 Right () -> return ()
293 -- enter the interactive loop
294 interactiveLoop is_tty show_prompt
296 -- just evaluate the expression we were given
301 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
304 interactiveLoop is_tty show_prompt =
305 -- Ignore ^C exceptions caught here
306 ghciHandleDyn (\e -> case e of
308 #if defined(mingw32_HOST_OS)
311 interactiveLoop is_tty show_prompt
312 _other -> return ()) $
314 ghciUnblock $ do -- unblock necessary if we recursed from the
315 -- exception handler above.
317 -- read commands from stdin
321 else fileLoop stdin show_prompt
323 fileLoop stdin show_prompt
327 -- NOTE: We only read .ghci files if they are owned by the current user,
328 -- and aren't world writable. Otherwise, we could be accidentally
329 -- running code planted by a malicious third party.
331 -- Furthermore, We only read ./.ghci if . is owned by the current user
332 -- and isn't writable by anyone else. I think this is sufficient: we
333 -- don't need to check .. and ../.. etc. because "." always refers to
334 -- the same directory while a process is running.
336 checkPerms :: String -> IO Bool
338 #ifdef mingw32_HOST_OS
341 Util.handle (\_ -> return False) $ do
342 st <- getFileStatus name
344 if fileOwner st /= me then do
345 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
348 let mode = fileMode st
349 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
350 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
352 putStrLn $ "*** WARNING: " ++ name ++
353 " is writable by someone else, IGNORING!"
358 fileLoop :: Handle -> Bool -> GHCi ()
359 fileLoop hdl prompt = do
360 session <- getSession
361 (mod,imports) <- io (GHC.getContext session)
362 when prompt (io (putStr (mkPrompt mod imports)))
363 l <- io (IO.try (hGetLine hdl))
365 Left e | isEOFError e -> return ()
366 | InvalidArgument <- etype -> return ()
367 | otherwise -> io (ioError e)
368 where etype = ioeGetErrorType e
369 -- treat InvalidArgument in the same way as EOF:
370 -- this can happen if the user closed stdin, or
371 -- perhaps did getContents which closes stdin at
374 case removeSpaces l of
375 "" -> fileLoop hdl prompt
376 l -> do quit <- runCommand l
377 if quit then return () else fileLoop hdl prompt
379 stringLoop :: [String] -> GHCi ()
380 stringLoop [] = return ()
381 stringLoop (s:ss) = do
382 case removeSpaces s of
384 l -> do quit <- runCommand l
385 if quit then return () else stringLoop ss
387 mkPrompt toplevs exports
388 = showSDoc (hsep (map (\m -> char '*' <> pprModule m) toplevs)
389 <+> hsep (map pprModule exports)
393 readlineLoop :: GHCi ()
395 session <- getSession
396 (mod,imports) <- io (GHC.getContext session)
398 saveSession -- for use by completion
399 l <- io (readline (mkPrompt mod imports)
400 `finally` setNonBlockingFD 0)
401 -- readline sometimes puts stdin into blocking mode,
402 -- so we need to put it back for the IO library
407 case removeSpaces l of
412 if quit then return () else readlineLoop
415 runCommand :: String -> GHCi Bool
416 runCommand c = ghciHandle handler (doCommand c)
418 doCommand (':' : command) = specialCommand command
420 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
423 -- This version is for the GHC command-line option -e. The only difference
424 -- from runCommand is that it catches the ExitException exception and
425 -- exits, rather than printing out the exception.
426 runCommandEval c = ghciHandle handleEval (doCommand c)
428 handleEval (ExitException code) = io (exitWith code)
429 handleEval e = do showException e
430 io (exitWith (ExitFailure 1))
432 doCommand (':' : command) = specialCommand command
434 = do nms <- runStmt stmt
436 Nothing -> io (exitWith (ExitFailure 1))
437 -- failure to run the command causes exit(1) for ghc -e.
438 _ -> finishEvalExpr nms
440 -- This is the exception handler for exceptions generated by the
441 -- user's code; it normally just prints out the exception. The
442 -- handler must be recursive, in case showing the exception causes
443 -- more exceptions to be raised.
445 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
446 -- raising another exception. We therefore don't put the recursive
447 -- handler arond the flushing operation, so if stderr is closed
448 -- GHCi will just die gracefully rather than going into an infinite loop.
449 handler :: Exception -> GHCi Bool
450 handler exception = do
452 io installSignalHandlers
453 ghciHandle handler (showException exception >> return False)
455 showException (DynException dyn) =
456 case fromDynamic dyn of
457 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
458 Just Interrupted -> io (putStrLn "Interrupted.")
459 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
460 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
461 Just other_ghc_ex -> io (print other_ghc_ex)
463 showException other_exception
464 = io (putStrLn ("*** Exception: " ++ show other_exception))
466 runStmt :: String -> GHCi (Maybe [Name])
468 | null (filter (not.isSpace) stmt) = return (Just [])
470 = do st <- getGHCiState
471 session <- getSession
472 result <- io $ withProgName (progname st) $ withArgs (args st) $
473 GHC.runStmt session stmt
475 GHC.RunFailed -> return Nothing
476 GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
477 GHC.RunOk names -> return (Just names)
479 -- possibly print the type and revert CAFs after evaluating an expression
480 finishEvalExpr mb_names
481 = do b <- isOptionSet ShowType
482 session <- getSession
485 Just names -> when b (mapM_ (showTypeOfName session) names)
488 io installSignalHandlers
489 b <- isOptionSet RevertCAFs
490 io (when b revertCAFs)
493 showTypeOfName :: Session -> Name -> GHCi ()
494 showTypeOfName session n
495 = do maybe_tything <- io (GHC.lookupName session n)
496 case maybe_tything of
498 Just thing -> showTyThing thing
500 showForUser :: SDoc -> GHCi String
502 session <- getSession
503 unqual <- io (GHC.getPrintUnqual session)
504 return $! showSDocForUser unqual doc
506 specialCommand :: String -> GHCi Bool
507 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
508 specialCommand str = do
509 let (cmd,rest) = break isSpace str
510 maybe_cmd <- io (lookupCommand cmd)
512 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
513 ++ shortHelpText) >> return False)
514 Just (_,f,_) -> f (dropWhile isSpace rest)
516 lookupCommand :: String -> IO (Maybe Command)
517 lookupCommand str = do
518 cmds <- readIORef commands
519 -- look for exact match first, then the first prefix match
520 case [ c | c <- cmds, str == cmdName c ] of
521 c:_ -> return (Just c)
522 [] -> case [ c | c@(s,_,_) <- cmds, prefixMatch str s ] of
524 c:_ -> return (Just c)
526 -----------------------------------------------------------------------------
527 -- To flush buffers for the *interpreted* computation we need
528 -- to refer to *its* stdout/stderr handles
530 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
531 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
533 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
534 " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
535 flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
537 initInterpBuffering :: Session -> IO ()
538 initInterpBuffering session
539 = do maybe_hval <- GHC.compileExpr session no_buf_cmd
542 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
543 other -> panic "interactiveUI:setBuffering"
545 maybe_hval <- GHC.compileExpr session flush_cmd
547 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
548 _ -> panic "interactiveUI:flush"
550 turnOffBuffering -- Turn it off right now
555 flushInterpBuffers :: GHCi ()
557 = io $ do Monad.join (readIORef flush_interp)
560 turnOffBuffering :: IO ()
562 = do Monad.join (readIORef turn_off_buffering)
565 -----------------------------------------------------------------------------
568 help :: String -> GHCi ()
569 help _ = io (putStr helpText)
571 info :: String -> GHCi ()
572 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
573 info s = do { let names = words s
574 ; session <- getSession
575 ; dflags <- getDynFlags
576 ; let exts = dopt Opt_GlasgowExts dflags
577 ; mapM_ (infoThing exts session) names }
579 infoThing exts session str = io $ do
580 names <- GHC.parseName session str
581 let filtered = filterOutChildren names
582 mb_stuffs <- mapM (GHC.getInfo session) filtered
583 unqual <- GHC.getPrintUnqual session
584 putStrLn (showSDocForUser unqual $
585 vcat (intersperse (text "") $
586 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
588 -- Filter out names whose parent is also there Good
589 -- example is '[]', which is both a type and data
590 -- constructor in the same type
591 filterOutChildren :: [Name] -> [Name]
592 filterOutChildren names = filter (not . parent_is_there) names
593 where parent_is_there n
594 | Just p <- GHC.nameParent_maybe n = p `elem` names
597 pprInfo exts (thing, fixity, insts)
598 = pprTyThingInContextLoc exts thing
599 $$ show_fixity fixity
600 $$ vcat (map GHC.pprInstance insts)
603 | fix == GHC.defaultFixity = empty
604 | otherwise = ppr fix <+> ppr (GHC.getName thing)
606 -----------------------------------------------------------------------------
609 runMain :: String -> GHCi ()
611 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
612 runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
615 addModule :: [FilePath] -> GHCi ()
617 io (revertCAFs) -- always revert CAFs on load/add.
618 files <- mapM expandPath files
619 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
620 session <- getSession
621 io (mapM_ (GHC.addTarget session) targets)
622 ok <- io (GHC.load session LoadAllTargets)
625 changeDirectory :: String -> GHCi ()
626 changeDirectory dir = do
627 session <- getSession
628 graph <- io (GHC.getModuleGraph session)
629 when (not (null graph)) $
630 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
631 io (GHC.setTargets session [])
632 io (GHC.load session LoadAllTargets)
633 setContextAfterLoad session []
634 io (GHC.workingDirectoryChanged session)
635 dir <- expandPath dir
636 io (setCurrentDirectory dir)
638 defineMacro :: String -> GHCi ()
640 let (macro_name, definition) = break isSpace s
641 cmds <- io (readIORef commands)
643 then throwDyn (CmdLineError "invalid macro name")
645 if (macro_name `elem` map cmdName cmds)
646 then throwDyn (CmdLineError
647 ("command '" ++ macro_name ++ "' is already defined"))
650 -- give the expression a type signature, so we can be sure we're getting
651 -- something of the right type.
652 let new_expr = '(' : definition ++ ") :: String -> IO String"
654 -- compile the expression
656 maybe_hv <- io (GHC.compileExpr cms new_expr)
659 Just hv -> io (writeIORef commands --
660 (cmds ++ [(macro_name, keepGoing (runMacro hv), completeNone)]))
662 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi ()
664 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
665 stringLoop (lines str)
667 undefineMacro :: String -> GHCi ()
668 undefineMacro macro_name = do
669 cmds <- io (readIORef commands)
670 if (macro_name `elem` map cmdName builtin_commands)
671 then throwDyn (CmdLineError
672 ("command '" ++ macro_name ++ "' cannot be undefined"))
674 if (macro_name `notElem` map cmdName cmds)
675 then throwDyn (CmdLineError
676 ("command '" ++ macro_name ++ "' not defined"))
678 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
681 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
682 loadModule fs = timeIt (loadModule' fs)
684 loadModule_ :: [FilePath] -> GHCi ()
685 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
687 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
688 loadModule' files = do
689 session <- getSession
692 io (GHC.setTargets session [])
693 io (GHC.load session LoadAllTargets)
696 let (filenames, phases) = unzip files
697 exp_filenames <- mapM expandPath filenames
698 let files' = zip exp_filenames phases
699 targets <- io (mapM (uncurry GHC.guessTarget) files')
701 -- NOTE: we used to do the dependency anal first, so that if it
702 -- fails we didn't throw away the current set of modules. This would
703 -- require some re-working of the GHC interface, so we'll leave it
704 -- as a ToDo for now.
706 io (GHC.setTargets session targets)
707 ok <- io (GHC.load session LoadAllTargets)
711 checkModule :: String -> GHCi ()
713 let modl = GHC.mkModule m
714 session <- getSession
715 result <- io (GHC.checkModule session modl)
717 Nothing -> io $ putStrLn "Nothing"
718 Just r -> io $ putStrLn (showSDoc (
719 case checkedModuleInfo r of
720 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
722 (local,global) = partition ((== modl) . GHC.nameModule) scope
724 (text "global names: " <+> ppr global) $$
725 (text "local names: " <+> ppr local)
727 afterLoad (successIf (isJust result)) session
729 reloadModule :: String -> GHCi ()
731 io (revertCAFs) -- always revert CAFs on reload.
732 session <- getSession
733 ok <- io (GHC.load session LoadAllTargets)
736 io (revertCAFs) -- always revert CAFs on reload.
737 session <- getSession
738 ok <- io (GHC.load session (LoadUpTo (GHC.mkModule m)))
741 afterLoad ok session = do
742 io (revertCAFs) -- always revert CAFs on load.
743 graph <- io (GHC.getModuleGraph session)
744 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod) graph
745 setContextAfterLoad session graph'
746 modulesLoadedMsg ok (map GHC.ms_mod graph')
748 setContextAfterLoad session [] = do
749 io (GHC.setContext session [] [prelude_mod])
750 setContextAfterLoad session ms = do
751 -- load a target if one is available, otherwise load the topmost module.
752 targets <- io (GHC.getTargets session)
753 case [ m | Just m <- map (findTarget ms) targets ] of
755 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
756 load_this (last graph')
761 = case filter (`matches` t) ms of
765 summary `matches` Target (TargetModule m) _
766 = GHC.ms_mod summary == m
767 summary `matches` Target (TargetFile f _) _
768 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
769 summary `matches` target
772 load_this summary | m <- GHC.ms_mod summary = do
773 b <- io (GHC.moduleIsInterpreted session m)
774 if b then io (GHC.setContext session [m] [])
775 else io (GHC.setContext session [] [prelude_mod,m])
778 modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi ()
779 modulesLoadedMsg ok mods = do
780 dflags <- getDynFlags
781 when (verbosity dflags > 0) $ do
783 | null mods = text "none."
785 punctuate comma (map pprModule mods)) <> text "."
788 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
790 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
793 typeOfExpr :: String -> GHCi ()
795 = do cms <- getSession
796 maybe_ty <- io (GHC.exprType cms str)
799 Just ty -> do ty' <- cleanType ty
800 tystr <- showForUser (ppr ty')
801 io (putStrLn (str ++ " :: " ++ tystr))
803 kindOfType :: String -> GHCi ()
805 = do cms <- getSession
806 maybe_ty <- io (GHC.typeKind cms str)
809 Just ty -> do tystr <- showForUser (ppr ty)
810 io (putStrLn (str ++ " :: " ++ tystr))
812 quit :: String -> GHCi Bool
815 shellEscape :: String -> GHCi Bool
816 shellEscape str = io (system str >> return False)
818 -----------------------------------------------------------------------------
819 -- create tags file for currently loaded modules.
821 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
823 createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
824 createCTagsFileCmd file = ghciCreateTagsFile CTags file
826 createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
827 createETagsFileCmd file = ghciCreateTagsFile ETags file
829 data TagsKind = ETags | CTags
831 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
832 ghciCreateTagsFile kind file = do
833 session <- getSession
834 io $ createTagsFile session kind file
837 -- - remove restriction that all modules must be interpreted
838 -- (problem: we don't know source locations for entities unless
839 -- we compiled the module.
841 -- - extract createTagsFile so it can be used from the command-line
842 -- (probably need to fix first problem before this is useful).
844 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
845 createTagsFile session tagskind tagFile = do
846 graph <- GHC.getModuleGraph session
847 let ms = map GHC.ms_mod graph
849 is_interpreted <- GHC.moduleIsInterpreted session m
850 -- should we just skip these?
851 when (not is_interpreted) $
852 throwDyn (CmdLineError ("module '" ++ moduleString m ++ "' is not interpreted"))
854 mbModInfo <- GHC.getModuleInfo session m
856 | Just modinfo <- mbModInfo,
857 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
858 | otherwise = GHC.alwaysQualify
861 Just modInfo -> return $! listTags unqual modInfo
864 mtags <- mapM tagModule ms
865 either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
867 Left e -> hPutStrLn stderr $ ioeGetErrorString e
870 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
871 listTags unqual modInfo =
872 [ tagInfo unqual name loc
873 | name <- GHC.modInfoExports modInfo
874 , let loc = nameSrcLoc name
878 type TagInfo = (String -- tag name
881 ,Int -- column number
884 -- get tag info, for later translation into Vim or Emacs style
885 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
886 tagInfo unqual name loc
887 = ( showSDocForUser unqual $ pprOccName (nameOccName name)
888 , showSDocForUser unqual $ ftext (srcLocFile loc)
893 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
894 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
895 let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
896 IO.try (writeFile file tags)
897 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
898 let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
899 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
900 tagGroups <- mapM tagFileGroup groups
901 IO.try (writeFile file $ concat tagGroups)
903 tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
904 tagFileGroup group@((_,fileName,_,_):_) = do
905 file <- readFile fileName -- need to get additional info from sources..
906 let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
907 sortedGroup = sortLe byLine group
908 tags = unlines $ perFile sortedGroup 1 0 $ lines file
909 return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
910 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
911 perFile (tagInfo:tags) (count+1) (pos+length line) lines
912 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
913 showETag tagInfo line pos : perFile tags count pos lines
914 perFile tags count pos lines = []
916 -- simple ctags format, for Vim et al
917 showTag :: TagInfo -> String
918 showTag (tag,file,lineNo,colNo)
919 = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
921 -- etags format, for Emacs/XEmacs
922 showETag :: TagInfo -> String -> Int -> String
923 showETag (tag,file,lineNo,colNo) line charPos
924 = take colNo line ++ tag
926 ++ "\x01" ++ show lineNo
927 ++ "," ++ show charPos
929 -----------------------------------------------------------------------------
930 -- Browsing a module's contents
932 browseCmd :: String -> GHCi ()
935 ['*':m] | looksLikeModuleName m -> browseModule m False
936 [m] | looksLikeModuleName m -> browseModule m True
937 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
939 browseModule m exports_only = do
942 let modl = GHC.mkModule m
943 is_interpreted <- io (GHC.moduleIsInterpreted s modl)
944 when (not is_interpreted && not exports_only) $
945 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
947 -- Temporarily set the context to the module we're interested in,
948 -- just so we can get an appropriate PrintUnqualified
949 (as,bs) <- io (GHC.getContext s)
950 io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
951 else GHC.setContext s [modl] [])
952 unqual <- io (GHC.getPrintUnqual s)
953 io (GHC.setContext s as bs)
955 mb_mod_info <- io $ GHC.getModuleInfo s modl
957 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
960 | exports_only = GHC.modInfoExports mod_info
961 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
963 filtered = filterOutChildren names
965 things <- io $ mapM (GHC.lookupName s) filtered
967 dflags <- getDynFlags
968 let exts = dopt Opt_GlasgowExts dflags
969 io (putStrLn (showSDocForUser unqual (
970 vcat (map (pprTyThingInContext exts) (catMaybes things))
972 -- ToDo: modInfoInstances currently throws an exception for
973 -- package modules. When it works, we can do this:
974 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
976 -----------------------------------------------------------------------------
977 -- Setting the module context
980 | all sensible mods = fn mods
981 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
983 (fn, mods) = case str of
984 '+':stuff -> (addToContext, words stuff)
985 '-':stuff -> (removeFromContext, words stuff)
986 stuff -> (newContext, words stuff)
988 sensible ('*':m) = looksLikeModuleName m
989 sensible m = looksLikeModuleName m
992 session <- getSession
993 (as,bs) <- separate session mods [] []
994 let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs
995 io (GHC.setContext session as bs')
997 separate :: Session -> [String] -> [Module] -> [Module]
998 -> GHCi ([Module],[Module])
999 separate session [] as bs = return (as,bs)
1000 separate session (('*':m):ms) as bs = do
1001 let modl = GHC.mkModule m
1002 b <- io (GHC.moduleIsInterpreted session modl)
1003 if b then separate session ms (modl:as) bs
1004 else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
1005 separate session (m:ms) as bs = separate session ms as (GHC.mkModule m:bs)
1007 prelude_mod = GHC.mkModule "Prelude"
1010 addToContext mods = do
1012 (as,bs) <- io (GHC.getContext cms)
1014 (as',bs') <- separate cms mods [] []
1016 let as_to_add = as' \\ (as ++ bs)
1017 bs_to_add = bs' \\ (as ++ bs)
1019 io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add))
1022 removeFromContext mods = do
1024 (as,bs) <- io (GHC.getContext cms)
1026 (as_to_remove,bs_to_remove) <- separate cms mods [] []
1028 let as' = as \\ (as_to_remove ++ bs_to_remove)
1029 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1031 io (GHC.setContext cms as' bs')
1033 ----------------------------------------------------------------------------
1036 -- set options in the interpreter. Syntax is exactly the same as the
1037 -- ghc command line, except that certain options aren't available (-C,
1040 -- This is pretty fragile: most options won't work as expected. ToDo:
1041 -- figure out which ones & disallow them.
1043 setCmd :: String -> GHCi ()
1045 = do st <- getGHCiState
1046 let opts = options st
1047 io $ putStrLn (showSDoc (
1048 text "options currently set: " <>
1051 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1055 ("args":args) -> setArgs args
1056 ("prog":prog) -> setProg prog
1057 wds -> setOptions wds
1061 setGHCiState st{ args = args }
1065 setGHCiState st{ progname = prog }
1067 io (hPutStrLn stderr "syntax: :set prog <progname>")
1070 do -- first, deal with the GHCi opts (+s, +t, etc.)
1071 let (plus_opts, minus_opts) = partition isPlus wds
1072 mapM_ setOpt plus_opts
1074 -- then, dynamic flags
1075 dflags <- getDynFlags
1076 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1079 -- update things if the users wants more packages
1081 let new_packages = pkgs_after \\ pkgs_before
1082 when (not (null new_packages)) $
1083 newPackages new_packages
1086 if (not (null leftovers))
1087 then throwDyn (CmdLineError ("unrecognised flags: " ++
1092 unsetOptions :: String -> GHCi ()
1094 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1095 let opts = words str
1096 (minus_opts, rest1) = partition isMinus opts
1097 (plus_opts, rest2) = partition isPlus rest1
1099 if (not (null rest2))
1100 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1103 mapM_ unsetOpt plus_opts
1105 -- can't do GHC flags for now
1106 if (not (null minus_opts))
1107 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1110 isMinus ('-':s) = True
1113 isPlus ('+':s) = True
1117 = case strToGHCiOpt str of
1118 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1119 Just o -> setOption o
1122 = case strToGHCiOpt str of
1123 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1124 Just o -> unsetOption o
1126 strToGHCiOpt :: String -> (Maybe GHCiOption)
1127 strToGHCiOpt "s" = Just ShowTiming
1128 strToGHCiOpt "t" = Just ShowType
1129 strToGHCiOpt "r" = Just RevertCAFs
1130 strToGHCiOpt _ = Nothing
1132 optToStr :: GHCiOption -> String
1133 optToStr ShowTiming = "s"
1134 optToStr ShowType = "t"
1135 optToStr RevertCAFs = "r"
1138 newPackages new_pkgs = do -- The new packages are already in v_Packages
1139 session <- getSession
1140 io (GHC.setTargets session [])
1141 io (GHC.load session Nothing)
1142 dflags <- getDynFlags
1143 io (linkPackages dflags new_pkgs)
1144 setContextAfterLoad []
1147 -- ---------------------------------------------------------------------------
1152 ["modules" ] -> showModules
1153 ["bindings"] -> showBindings
1154 ["linker"] -> io showLinkerState
1155 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1158 session <- getSession
1159 let show_one ms = do m <- io (GHC.showModule session ms)
1161 graph <- io (GHC.getModuleGraph session)
1162 mapM_ show_one graph
1166 unqual <- io (GHC.getPrintUnqual s)
1167 bindings <- io (GHC.getBindings s)
1168 mapM_ showTyThing bindings
1171 showTyThing (AnId id) = do
1172 ty' <- cleanType (GHC.idType id)
1173 str <- showForUser (ppr id <> text " :: " <> ppr ty')
1175 showTyThing _ = return ()
1177 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1178 cleanType :: Type -> GHCi Type
1180 dflags <- getDynFlags
1181 if dopt Opt_GlasgowExts dflags
1183 else return $! GHC.dropForAlls ty
1185 -- -----------------------------------------------------------------------------
1189 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1190 completeWord w start end = do
1191 line <- Readline.getLineBuffer
1193 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1195 | Just c <- is_cmd line -> do
1196 maybe_cmd <- lookupCommand c
1198 Nothing -> return Nothing
1199 Just (_,_,complete) -> wrapCompleter complete w
1201 --printf "complete %s, start = %d, end = %d\n" w start end
1202 wrapCompleter completeIdentifier w
1205 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1206 | otherwise = Nothing
1208 completeNone w = return []
1211 cmds <- readIORef commands
1212 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1214 completeIdentifier w = do
1216 rdrs <- GHC.getRdrNamesInScope s
1217 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1219 completeModule w = do
1221 dflags <- GHC.getSessionDynFlags s
1222 let pkg_mods = allExposedModules dflags
1223 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1225 completeHomeModule w = do
1227 g <- GHC.getModuleGraph s
1228 let home_mods = map GHC.ms_mod g
1229 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1231 completeFilename = Readline.filenameCompletionFunction
1233 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1235 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1236 unionComplete f1 f2 w = do
1241 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1242 wrapCompleter fun w = do
1245 [] -> return Nothing
1246 [x] -> return (Just (x,[]))
1247 xs -> case getCommonPrefix xs of
1248 "" -> return (Just ("",xs))
1249 pref -> return (Just (pref,xs))
1251 getCommonPrefix :: [String] -> String
1252 getCommonPrefix [] = ""
1253 getCommonPrefix (s:ss) = foldl common s ss
1254 where common s "" = s
1256 common (c:cs) (d:ds)
1257 | c == d = c : common cs ds
1260 allExposedModules :: DynFlags -> [Module]
1261 allExposedModules dflags
1262 = map GHC.mkModule (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1264 pkg_db = pkgIdMap (pkgState dflags)
1267 -----------------------------------------------------------------------------
1270 data GHCiState = GHCiState
1274 session :: GHC.Session,
1275 options :: [GHCiOption]
1279 = ShowTiming -- show time/allocs after evaluation
1280 | ShowType -- show the type of expressions
1281 | RevertCAFs -- revert CAFs after every evaluation
1284 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1286 startGHCi :: GHCi a -> GHCiState -> IO a
1287 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1289 instance Monad GHCi where
1290 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1291 return a = GHCi $ \s -> return a
1293 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1294 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1295 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1297 getGHCiState = GHCi $ \r -> readIORef r
1298 setGHCiState s = GHCi $ \r -> writeIORef r s
1300 -- for convenience...
1301 getSession = getGHCiState >>= return . session
1303 GLOBAL_VAR(saved_sess, no_saved_sess, Session)
1304 no_saved_sess = error "no saved_ses"
1305 saveSession = getSession >>= io . writeIORef saved_sess
1306 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
1307 restoreSession = readIORef saved_sess
1311 io (GHC.getSessionDynFlags s)
1312 setDynFlags dflags = do
1314 io (GHC.setSessionDynFlags s dflags)
1316 isOptionSet :: GHCiOption -> GHCi Bool
1318 = do st <- getGHCiState
1319 return (opt `elem` options st)
1321 setOption :: GHCiOption -> GHCi ()
1323 = do st <- getGHCiState
1324 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1326 unsetOption :: GHCiOption -> GHCi ()
1328 = do st <- getGHCiState
1329 setGHCiState (st{ options = filter (/= opt) (options st) })
1331 io :: IO a -> GHCi a
1332 io m = GHCi { unGHCi = \s -> m >>= return }
1334 -----------------------------------------------------------------------------
1335 -- recursive exception handlers
1337 -- Don't forget to unblock async exceptions in the handler, or if we're
1338 -- in an exception loop (eg. let a = error a in a) the ^C exception
1339 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1341 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1342 ghciHandle h (GHCi m) = GHCi $ \s ->
1343 Exception.catch (m s)
1344 (\e -> unGHCi (ghciUnblock (h e)) s)
1346 ghciUnblock :: GHCi a -> GHCi a
1347 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1349 -----------------------------------------------------------------------------
1350 -- timing & statistics
1352 timeIt :: GHCi a -> GHCi a
1354 = do b <- isOptionSet ShowTiming
1357 else do allocs1 <- io $ getAllocations
1358 time1 <- io $ getCPUTime
1360 allocs2 <- io $ getAllocations
1361 time2 <- io $ getCPUTime
1362 io $ printTimes (fromIntegral (allocs2 - allocs1))
1366 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1367 -- defined in ghc/rts/Stats.c
1369 printTimes :: Integer -> Integer -> IO ()
1370 printTimes allocs psecs
1371 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1372 secs_str = showFFloat (Just 2) secs
1373 putStrLn (showSDoc (
1374 parens (text (secs_str "") <+> text "secs" <> comma <+>
1375 text (show allocs) <+> text "bytes")))
1377 -----------------------------------------------------------------------------
1384 -- Have to turn off buffering again, because we just
1385 -- reverted stdout, stderr & stdin to their defaults.
1387 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1388 -- Make it "safe", just in case
1390 -- -----------------------------------------------------------------------------
1393 expandPath :: String -> GHCi String
1395 case dropWhile isSpace path of
1397 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1398 return (tilde ++ '/':d)