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(..),
19 mkModule, pprModule, Type, Module, SuccessFlag(..),
20 TyThing(..), Name, LoadHowMuch(..), Phase,
21 GhcException(..), showGhcException,
22 CheckedModule(..), SrcLoc )
26 -- for createtags (should these come via GHC?)
27 import Module( moduleUserString )
28 import Name( nameSrcLoc, nameModule, nameOccName )
29 import OccName( pprOccName )
30 import SrcLoc( isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol )
32 -- Other random utilities
33 import BasicTypes ( failed, successIf )
34 import Panic ( panic, installSignalHandlers )
36 import StaticFlags ( opt_IgnoreDotGhci )
37 import Linker ( showLinkerState )
38 import Util ( removeSpaces, handle, global, toArgs,
39 looksLikeModuleName, prefixMatch, sortLe )
40 import ErrUtils ( printErrorsAndWarnings )
42 #ifndef mingw32_HOST_OS
44 #if __GLASGOW_HASKELL__ > 504
48 import GHC.ConsoleHandler ( flushConsole )
52 import Control.Concurrent ( yield ) -- Used in readline loop
53 import System.Console.Readline as Readline
58 import Control.Exception as Exception
60 -- import Control.Concurrent
64 import Data.Int ( Int64 )
65 import Data.Maybe ( isJust, fromMaybe, catMaybes )
68 import System.Environment
69 import System.Exit ( exitWith, ExitCode(..) )
70 import System.Directory
72 import System.IO.Error as IO
74 import Control.Monad as Monad
75 import Foreign.StablePtr ( newStablePtr )
77 import GHC.Exts ( unsafeCoerce# )
78 import GHC.IOBase ( IOErrorType(InvalidArgument) )
80 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
82 import System.Posix.Internals ( setNonBlockingFD )
84 -----------------------------------------------------------------------------
88 " / _ \\ /\\ /\\/ __(_)\n"++
89 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
90 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
91 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
93 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
95 builtin_commands :: [(String, String -> GHCi Bool)]
97 ("add", keepGoingPaths addModule),
98 ("browse", keepGoing browseCmd),
99 ("cd", keepGoing changeDirectory),
100 ("def", keepGoing defineMacro),
101 ("help", keepGoing help),
102 ("?", keepGoing help),
103 ("info", keepGoing info),
104 ("load", keepGoingPaths loadModule_),
105 ("module", keepGoing setContext),
106 ("reload", keepGoing reloadModule),
107 ("check", keepGoing checkModule),
108 ("set", keepGoing setCmd),
109 ("show", keepGoing showCmd),
110 ("etags", keepGoing createETagsFileCmd),
111 ("ctags", keepGoing createCTagsFileCmd),
112 ("type", keepGoing typeOfExpr),
113 ("kind", keepGoing kindOfType),
114 ("unset", keepGoing unsetOptions),
115 ("undef", keepGoing undefineMacro),
119 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
120 keepGoing a str = a str >> return False
122 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
123 keepGoingPaths a str = a (toArgs str) >> return False
125 shortHelpText = "use :? for help.\n"
127 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
129 " Commands available from the prompt:\n" ++
131 " <stmt> evaluate/run <stmt>\n" ++
132 " :add <filename> ... add module(s) to the current target set\n" ++
133 " :browse [*]<module> display the names defined by <module>\n" ++
134 " :cd <dir> change directory to <dir>\n" ++
135 " :def <cmd> <expr> define a command :<cmd>\n" ++
136 " :help, :? display this list of commands\n" ++
137 " :info [<name> ...] display information about the given names\n" ++
138 " :load <filename> ... load module(s) and their dependents\n" ++
139 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
140 " :reload reload the current module set\n" ++
142 " :set <option> ... set options\n" ++
143 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
144 " :set prog <progname> set the value returned by System.getProgName\n" ++
146 " :show modules show the currently loaded modules\n" ++
147 " :show bindings show the current bindings made at the prompt\n" ++
149 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
150 " :etags [<file>] create tags file for Emacs (defauilt: \"TAGS\")\n" ++
151 " :type <expr> show the type of <expr>\n" ++
152 " :kind <type> show the kind of <type>\n" ++
153 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
154 " :unset <option> ... unset options\n" ++
155 " :quit exit GHCi\n" ++
156 " :!<command> run the shell command <command>\n" ++
158 " Options for ':set' and ':unset':\n" ++
160 " +r revert top-level expressions after each evaluation\n" ++
161 " +s print timing/memory stats after each evaluation\n" ++
162 " +t print type after evaluation\n" ++
163 " -<flags> most GHC command line flags can also be set here\n" ++
164 " (eg. -v2, -fglasgow-exts, etc.)\n"
167 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
168 interactiveUI session srcs maybe_expr = do
170 -- HACK! If we happen to get into an infinite loop (eg the user
171 -- types 'let x=x in x' at the prompt), then the thread will block
172 -- on a blackhole, and become unreachable during GC. The GC will
173 -- detect that it is unreachable and send it the NonTermination
174 -- exception. However, since the thread is unreachable, everything
175 -- it refers to might be finalized, including the standard Handles.
176 -- This sounds like a bug, but we don't have a good solution right
183 hSetBuffering stdout NoBuffering
185 -- Initialise buffering for the *interpreted* I/O system
186 initInterpBuffering session
188 -- We don't want the cmd line to buffer any input that might be
189 -- intended for the program, so unbuffer stdin.
190 hSetBuffering stdin NoBuffering
192 -- initial context is just the Prelude
193 GHC.setContext session [] [prelude_mod]
199 startGHCi (runGHCi srcs maybe_expr)
200 GHCiState{ progname = "<interactive>",
206 Readline.resetTerminal Nothing
211 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
212 runGHCi paths maybe_expr = do
213 let read_dot_files = not opt_IgnoreDotGhci
215 when (read_dot_files) $ do
218 exists <- io (doesFileExist file)
220 dir_ok <- io (checkPerms ".")
221 file_ok <- io (checkPerms file)
222 when (dir_ok && file_ok) $ do
223 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
226 Right hdl -> fileLoop hdl False
228 when (read_dot_files) $ do
229 -- Read in $HOME/.ghci
230 either_dir <- io (IO.try (getEnv "HOME"))
234 cwd <- io (getCurrentDirectory)
235 when (dir /= cwd) $ do
236 let file = dir ++ "/.ghci"
237 ok <- io (checkPerms file)
239 either_hdl <- io (IO.try (openFile file ReadMode))
242 Right hdl -> fileLoop hdl False
244 -- Perform a :load for files given on the GHCi command line
245 -- When in -e mode, if the load fails then we want to stop
246 -- immediately rather than going on to evaluate the expression.
247 when (not (null paths)) $ do
248 ok <- ghciHandle (\e -> do showException e; return Failed) $
250 when (isJust maybe_expr && failed ok) $
251 io (exitWith (ExitFailure 1))
253 -- if verbosity is greater than 0, or we are connected to a
254 -- terminal, display the prompt in the interactive loop.
255 is_tty <- io (hIsTerminalDevice stdin)
256 dflags <- getDynFlags
257 let show_prompt = verbosity dflags > 0 || is_tty
261 #if defined(mingw32_HOST_OS)
263 -- The win32 Console API mutates the first character of
264 -- type-ahead when reading from it in a non-buffered manner. Work
265 -- around this by flushing the input buffer of type-ahead characters,
266 -- but only if stdin is available.
267 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
269 Left err | isDoesNotExistError err -> return ()
270 | otherwise -> io (ioError err)
271 Right () -> return ()
273 -- enter the interactive loop
274 interactiveLoop is_tty show_prompt
276 -- just evaluate the expression we were given
281 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
284 interactiveLoop is_tty show_prompt = do
285 -- Ignore ^C exceptions caught here
286 ghciHandleDyn (\e -> case e of
287 Interrupted -> ghciUnblock (
288 #if defined(mingw32_HOST_OS)
291 interactiveLoop is_tty show_prompt)
292 _other -> return ()) $ do
294 -- read commands from stdin
298 else fileLoop stdin show_prompt
300 fileLoop stdin show_prompt
304 -- NOTE: We only read .ghci files if they are owned by the current user,
305 -- and aren't world writable. Otherwise, we could be accidentally
306 -- running code planted by a malicious third party.
308 -- Furthermore, We only read ./.ghci if . is owned by the current user
309 -- and isn't writable by anyone else. I think this is sufficient: we
310 -- don't need to check .. and ../.. etc. because "." always refers to
311 -- the same directory while a process is running.
313 checkPerms :: String -> IO Bool
315 #ifdef mingw32_HOST_OS
318 Util.handle (\_ -> return False) $ do
319 st <- getFileStatus name
321 if fileOwner st /= me then do
322 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
325 let mode = fileMode st
326 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
327 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
329 putStrLn $ "*** WARNING: " ++ name ++
330 " is writable by someone else, IGNORING!"
335 fileLoop :: Handle -> Bool -> GHCi ()
336 fileLoop hdl prompt = do
337 session <- getSession
338 (mod,imports) <- io (GHC.getContext session)
339 when prompt (io (putStr (mkPrompt mod imports)))
340 l <- io (IO.try (hGetLine hdl))
342 Left e | isEOFError e -> return ()
343 | InvalidArgument <- etype -> return ()
344 | otherwise -> io (ioError e)
345 where etype = ioeGetErrorType e
346 -- treat InvalidArgument in the same way as EOF:
347 -- this can happen if the user closed stdin, or
348 -- perhaps did getContents which closes stdin at
351 case removeSpaces l of
352 "" -> fileLoop hdl prompt
353 l -> do quit <- runCommand l
354 if quit then return () else fileLoop hdl prompt
356 stringLoop :: [String] -> GHCi ()
357 stringLoop [] = return ()
358 stringLoop (s:ss) = do
359 case removeSpaces s of
361 l -> do quit <- runCommand l
362 if quit then return () else stringLoop ss
364 mkPrompt toplevs exports
365 = showSDoc (hsep (map (\m -> char '*' <> pprModule m) toplevs)
366 <+> hsep (map pprModule exports)
370 readlineLoop :: GHCi ()
372 session <- getSession
373 (mod,imports) <- io (GHC.getContext session)
375 l <- io (readline (mkPrompt mod imports)
376 `finally` setNonBlockingFD 0)
377 -- readline sometimes puts stdin into blocking mode,
378 -- so we need to put it back for the IO library
382 case removeSpaces l of
387 if quit then return () else readlineLoop
390 runCommand :: String -> GHCi Bool
391 runCommand c = ghciHandle handler (doCommand c)
393 doCommand (':' : command) = specialCommand command
395 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
398 -- This version is for the GHC command-line option -e. The only difference
399 -- from runCommand is that it catches the ExitException exception and
400 -- exits, rather than printing out the exception.
401 runCommandEval c = ghciHandle handleEval (doCommand c)
403 handleEval (ExitException code) = io (exitWith code)
404 handleEval e = do showException e
405 io (exitWith (ExitFailure 1))
407 doCommand (':' : command) = specialCommand command
409 = do nms <- runStmt stmt
411 Nothing -> io (exitWith (ExitFailure 1))
412 -- failure to run the command causes exit(1) for ghc -e.
413 _ -> finishEvalExpr nms
415 -- This is the exception handler for exceptions generated by the
416 -- user's code; it normally just prints out the exception. The
417 -- handler must be recursive, in case showing the exception causes
418 -- more exceptions to be raised.
420 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
421 -- raising another exception. We therefore don't put the recursive
422 -- handler arond the flushing operation, so if stderr is closed
423 -- GHCi will just die gracefully rather than going into an infinite loop.
424 handler :: Exception -> GHCi Bool
425 handler exception = do
427 io installSignalHandlers
428 ghciHandle handler (showException exception >> return False)
430 showException (DynException dyn) =
431 case fromDynamic dyn of
432 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
433 Just Interrupted -> io (putStrLn "Interrupted.")
434 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
435 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
436 Just other_ghc_ex -> io (print other_ghc_ex)
438 showException other_exception
439 = io (putStrLn ("*** Exception: " ++ show other_exception))
441 runStmt :: String -> GHCi (Maybe [Name])
443 | null (filter (not.isSpace) stmt) = return (Just [])
445 = do st <- getGHCiState
446 session <- getSession
447 result <- io $ withProgName (progname st) $ withArgs (args st) $
448 GHC.runStmt session stmt
450 GHC.RunFailed -> return Nothing
451 GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
452 GHC.RunOk names -> return (Just names)
454 -- possibly print the type and revert CAFs after evaluating an expression
455 finishEvalExpr mb_names
456 = do b <- isOptionSet ShowType
457 session <- getSession
460 Just names -> when b (mapM_ (showTypeOfName session) names)
463 io installSignalHandlers
464 b <- isOptionSet RevertCAFs
465 io (when b revertCAFs)
468 showTypeOfName :: Session -> Name -> GHCi ()
469 showTypeOfName session n
470 = do maybe_tything <- io (GHC.lookupName session n)
471 case maybe_tything of
473 Just thing -> showTyThing thing
475 showForUser :: SDoc -> GHCi String
477 session <- getSession
478 unqual <- io (GHC.getPrintUnqual session)
479 return $! showSDocForUser unqual doc
481 specialCommand :: String -> GHCi Bool
482 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
483 specialCommand str = do
484 let (cmd,rest) = break isSpace str
485 cmds <- io (readIORef commands)
486 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
487 [] -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
488 ++ shortHelpText) >> return False)
489 [(_,f)] -> f (dropWhile isSpace rest)
490 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
491 " matches multiple commands (" ++
492 foldr1 (\a b -> a ++ ',':b) (map fst cs)
493 ++ ")") >> return False)
495 -----------------------------------------------------------------------------
496 -- To flush buffers for the *interpreted* computation we need
497 -- to refer to *its* stdout/stderr handles
499 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
500 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
502 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
503 " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
504 flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
506 initInterpBuffering :: Session -> IO ()
507 initInterpBuffering session
508 = do maybe_hval <- GHC.compileExpr session no_buf_cmd
511 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
512 other -> panic "interactiveUI:setBuffering"
514 maybe_hval <- GHC.compileExpr session flush_cmd
516 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
517 _ -> panic "interactiveUI:flush"
519 turnOffBuffering -- Turn it off right now
524 flushInterpBuffers :: GHCi ()
526 = io $ do Monad.join (readIORef flush_interp)
529 turnOffBuffering :: IO ()
531 = do Monad.join (readIORef turn_off_buffering)
534 -----------------------------------------------------------------------------
537 help :: String -> GHCi ()
538 help _ = io (putStr helpText)
540 info :: String -> GHCi ()
541 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
542 info s = do { let names = words s
543 ; session <- getSession
544 ; dflags <- getDynFlags
545 ; let exts = dopt Opt_GlasgowExts dflags
546 ; mapM_ (infoThing exts session) names }
548 infoThing exts session str = io $ do
549 names <- GHC.parseName session str
550 let filtered = filterOutChildren names
551 mb_stuffs <- mapM (GHC.getInfo session) filtered
552 unqual <- GHC.getPrintUnqual session
553 putStrLn (showSDocForUser unqual $
554 vcat (intersperse (text "") $
555 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
557 -- Filter out names whose parent is also there Good
558 -- example is '[]', which is both a type and data
559 -- constructor in the same type
560 filterOutChildren :: [Name] -> [Name]
561 filterOutChildren names = filter (not . parent_is_there) names
562 where parent_is_there n
563 | Just p <- GHC.nameParent_maybe n = p `elem` names
566 pprInfo exts (thing, fixity, insts)
567 = pprTyThingInContextLoc exts thing
568 $$ show_fixity fixity
569 $$ vcat (map GHC.pprInstance insts)
572 | fix == GHC.defaultFixity = empty
573 | otherwise = ppr fix <+> ppr (GHC.getName thing)
575 -----------------------------------------------------------------------------
578 addModule :: [FilePath] -> GHCi ()
580 io (revertCAFs) -- always revert CAFs on load/add.
581 files <- mapM expandPath files
582 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
583 session <- getSession
584 io (mapM_ (GHC.addTarget session) targets)
585 ok <- io (GHC.load session LoadAllTargets)
588 changeDirectory :: String -> GHCi ()
589 changeDirectory dir = do
590 session <- getSession
591 graph <- io (GHC.getModuleGraph session)
592 when (not (null graph)) $
593 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
594 io (GHC.setTargets session [])
595 io (GHC.load session LoadAllTargets)
596 setContextAfterLoad []
597 io (GHC.workingDirectoryChanged session)
598 dir <- expandPath dir
599 io (setCurrentDirectory dir)
601 defineMacro :: String -> GHCi ()
603 let (macro_name, definition) = break isSpace s
604 cmds <- io (readIORef commands)
606 then throwDyn (CmdLineError "invalid macro name")
608 if (macro_name `elem` map fst cmds)
609 then throwDyn (CmdLineError
610 ("command '" ++ macro_name ++ "' is already defined"))
613 -- give the expression a type signature, so we can be sure we're getting
614 -- something of the right type.
615 let new_expr = '(' : definition ++ ") :: String -> IO String"
617 -- compile the expression
619 maybe_hv <- io (GHC.compileExpr cms new_expr)
622 Just hv -> io (writeIORef commands --
623 ((macro_name, keepGoing (runMacro hv)) : cmds))
625 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi ()
627 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
628 stringLoop (lines str)
630 undefineMacro :: String -> GHCi ()
631 undefineMacro macro_name = do
632 cmds <- io (readIORef commands)
633 if (macro_name `elem` map fst builtin_commands)
634 then throwDyn (CmdLineError
635 ("command '" ++ macro_name ++ "' cannot be undefined"))
637 if (macro_name `notElem` map fst cmds)
638 then throwDyn (CmdLineError
639 ("command '" ++ macro_name ++ "' not defined"))
641 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
644 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
645 loadModule fs = timeIt (loadModule' fs)
647 loadModule_ :: [FilePath] -> GHCi ()
648 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
650 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
651 loadModule' files = do
652 session <- getSession
655 io (GHC.setTargets session [])
656 io (GHC.load session LoadAllTargets)
659 let (filenames, phases) = unzip files
660 exp_filenames <- mapM expandPath filenames
661 let files' = zip exp_filenames phases
662 targets <- io (mapM (uncurry GHC.guessTarget) files')
664 -- NOTE: we used to do the dependency anal first, so that if it
665 -- fails we didn't throw away the current set of modules. This would
666 -- require some re-working of the GHC interface, so we'll leave it
667 -- as a ToDo for now.
669 io (GHC.setTargets session targets)
670 ok <- io (GHC.load session LoadAllTargets)
674 checkModule :: String -> GHCi ()
676 let modl = mkModule m
677 session <- getSession
678 result <- io (GHC.checkModule session modl printErrorsAndWarnings)
680 Nothing -> io $ putStrLn "Nothing"
681 Just r -> io $ putStrLn (showSDoc (
682 case checkedModuleInfo r of
683 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
685 (local,global) = partition ((== modl) . GHC.nameModule) scope
687 (text "global names: " <+> ppr global) $$
688 (text "local names: " <+> ppr local)
690 afterLoad (successIf (isJust result)) session
692 reloadModule :: String -> GHCi ()
694 io (revertCAFs) -- always revert CAFs on reload.
695 session <- getSession
696 ok <- io (GHC.load session LoadAllTargets)
699 io (revertCAFs) -- always revert CAFs on reload.
700 session <- getSession
701 ok <- io (GHC.load session (LoadUpTo (mkModule m)))
704 afterLoad ok session = do
705 io (revertCAFs) -- always revert CAFs on load.
706 graph <- io (GHC.getModuleGraph session)
707 let mods = map GHC.ms_mod graph
708 mods' <- filterM (io . GHC.isLoaded session) mods
709 setContextAfterLoad mods'
710 modulesLoadedMsg ok mods'
712 setContextAfterLoad [] = do
713 session <- getSession
714 io (GHC.setContext session [] [prelude_mod])
715 setContextAfterLoad (m:_) = do
716 session <- getSession
717 b <- io (GHC.moduleIsInterpreted session m)
718 if b then io (GHC.setContext session [m] [])
719 else io (GHC.setContext session [] [prelude_mod,m])
721 modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi ()
722 modulesLoadedMsg ok mods = do
723 dflags <- getDynFlags
724 when (verbosity dflags > 0) $ do
726 | null mods = text "none."
728 punctuate comma (map pprModule mods)) <> text "."
731 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
733 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
736 typeOfExpr :: String -> GHCi ()
738 = do cms <- getSession
739 maybe_ty <- io (GHC.exprType cms str)
742 Just ty -> do ty' <- cleanType ty
743 tystr <- showForUser (ppr ty')
744 io (putStrLn (str ++ " :: " ++ tystr))
746 kindOfType :: String -> GHCi ()
748 = do cms <- getSession
749 maybe_ty <- io (GHC.typeKind cms str)
752 Just ty -> do tystr <- showForUser (ppr ty)
753 io (putStrLn (str ++ " :: " ++ tystr))
755 quit :: String -> GHCi Bool
758 shellEscape :: String -> GHCi Bool
759 shellEscape str = io (system str >> return False)
761 -----------------------------------------------------------------------------
762 -- create tags file for currently loaded modules.
764 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
766 createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
767 createCTagsFileCmd file = ghciCreateTagsFile CTags file
769 createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
770 createETagsFileCmd file = ghciCreateTagsFile ETags file
772 data TagsKind = ETags | CTags
774 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
775 ghciCreateTagsFile kind file = do
776 session <- getSession
777 io $ createTagsFile session kind file
780 -- - remove restriction that all modules must be interpreted
781 -- (problem: we don't know source locations for entities unless
782 -- we compiled the module.
784 -- - extract createTagsFile so it can be used from the command-line
785 -- (probably need to fix first problem before this is useful).
787 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
788 createTagsFile session tagskind tagFile = do
789 graph <- GHC.getModuleGraph session
790 let ms = map GHC.ms_mod graph
792 is_interpreted <- GHC.moduleIsInterpreted session m
793 -- should we just skip these?
794 when (not is_interpreted) $
795 throwDyn (CmdLineError ("module '" ++ moduleUserString m ++ "' is not interpreted"))
797 mbModInfo <- GHC.getModuleInfo session m
799 | Just modinfo <- mbModInfo,
800 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
801 | otherwise = GHC.alwaysQualify
804 Just modInfo -> return $! listTags unqual modInfo
807 mtags <- mapM tagModule ms
808 either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
810 Left e -> hPutStrLn stderr $ ioeGetErrorString e
813 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
814 listTags unqual modInfo =
815 [ tagInfo unqual name loc
816 | name <- GHC.modInfoExports modInfo
817 , let loc = nameSrcLoc name
821 type TagInfo = (String -- tag name
824 ,Int -- column number
827 -- get tag info, for later translation into Vim or Emacs style
828 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
829 tagInfo unqual name loc
830 = ( showSDocForUser unqual $ pprOccName (nameOccName name)
831 , showSDocForUser unqual $ ftext (srcLocFile loc)
836 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
837 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
838 let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
839 IO.try (writeFile file tags)
840 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
841 let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
842 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
843 tagGroups <- mapM tagFileGroup groups
844 IO.try (writeFile file $ concat tagGroups)
846 tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
847 tagFileGroup group@((_,fileName,_,_):_) = do
848 file <- readFile fileName -- need to get additional info from sources..
849 let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
850 sortedGroup = sortLe byLine group
851 tags = unlines $ perFile sortedGroup 1 0 $ lines file
852 return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
853 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
854 perFile (tagInfo:tags) (count+1) (pos+length line) lines
855 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
856 showETag tagInfo line pos : perFile tags count pos lines
857 perFile tags count pos lines = []
859 -- simple ctags format, for Vim et al
860 showTag :: TagInfo -> String
861 showTag (tag,file,lineNo,colNo)
862 = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
864 -- etags format, for Emacs/XEmacs
865 showETag :: TagInfo -> String -> Int -> String
866 showETag (tag,file,lineNo,colNo) line charPos
867 = take colNo line ++ tag
869 ++ "\x01" ++ show lineNo
870 ++ "," ++ show charPos
872 -----------------------------------------------------------------------------
873 -- Browsing a module's contents
875 browseCmd :: String -> GHCi ()
878 ['*':m] | looksLikeModuleName m -> browseModule m False
879 [m] | looksLikeModuleName m -> browseModule m True
880 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
882 browseModule m exports_only = do
885 let modl = mkModule m
886 is_interpreted <- io (GHC.moduleIsInterpreted s modl)
887 when (not is_interpreted && not exports_only) $
888 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
890 -- Temporarily set the context to the module we're interested in,
891 -- just so we can get an appropriate PrintUnqualified
892 (as,bs) <- io (GHC.getContext s)
893 io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
894 else GHC.setContext s [modl] [])
895 unqual <- io (GHC.getPrintUnqual s)
896 io (GHC.setContext s as bs)
898 mb_mod_info <- io $ GHC.getModuleInfo s modl
900 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
903 | exports_only = GHC.modInfoExports mod_info
904 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
906 filtered = filterOutChildren names
908 things <- io $ mapM (GHC.lookupName s) filtered
910 dflags <- getDynFlags
911 let exts = dopt Opt_GlasgowExts dflags
912 io (putStrLn (showSDocForUser unqual (
913 vcat (map (pprTyThingInContext exts) (catMaybes things))
915 -- ToDo: modInfoInstances currently throws an exception for
916 -- package modules. When it works, we can do this:
917 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
919 -----------------------------------------------------------------------------
920 -- Setting the module context
923 | all sensible mods = fn mods
924 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
926 (fn, mods) = case str of
927 '+':stuff -> (addToContext, words stuff)
928 '-':stuff -> (removeFromContext, words stuff)
929 stuff -> (newContext, words stuff)
931 sensible ('*':m) = looksLikeModuleName m
932 sensible m = looksLikeModuleName m
935 session <- getSession
936 (as,bs) <- separate session mods [] []
937 let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs
938 io (GHC.setContext session as bs')
940 separate :: Session -> [String] -> [Module] -> [Module]
941 -> GHCi ([Module],[Module])
942 separate session [] as bs = return (as,bs)
943 separate session (('*':m):ms) as bs = do
944 let modl = mkModule m
945 b <- io (GHC.moduleIsInterpreted session modl)
946 if b then separate session ms (modl:as) bs
947 else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
948 separate session (m:ms) as bs = separate session ms as (mkModule m:bs)
950 prelude_mod = mkModule "Prelude"
953 addToContext mods = do
955 (as,bs) <- io (GHC.getContext cms)
957 (as',bs') <- separate cms mods [] []
959 let as_to_add = as' \\ (as ++ bs)
960 bs_to_add = bs' \\ (as ++ bs)
962 io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add))
965 removeFromContext mods = do
967 (as,bs) <- io (GHC.getContext cms)
969 (as_to_remove,bs_to_remove) <- separate cms mods [] []
971 let as' = as \\ (as_to_remove ++ bs_to_remove)
972 bs' = bs \\ (as_to_remove ++ bs_to_remove)
974 io (GHC.setContext cms as' bs')
976 ----------------------------------------------------------------------------
979 -- set options in the interpreter. Syntax is exactly the same as the
980 -- ghc command line, except that certain options aren't available (-C,
983 -- This is pretty fragile: most options won't work as expected. ToDo:
984 -- figure out which ones & disallow them.
986 setCmd :: String -> GHCi ()
988 = do st <- getGHCiState
989 let opts = options st
990 io $ putStrLn (showSDoc (
991 text "options currently set: " <>
994 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
998 ("args":args) -> setArgs args
999 ("prog":prog) -> setProg prog
1000 wds -> setOptions wds
1004 setGHCiState st{ args = args }
1008 setGHCiState st{ progname = prog }
1010 io (hPutStrLn stderr "syntax: :set prog <progname>")
1013 do -- first, deal with the GHCi opts (+s, +t, etc.)
1014 let (plus_opts, minus_opts) = partition isPlus wds
1015 mapM_ setOpt plus_opts
1017 -- then, dynamic flags
1018 dflags <- getDynFlags
1019 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1022 -- update things if the users wants more packages
1024 let new_packages = pkgs_after \\ pkgs_before
1025 when (not (null new_packages)) $
1026 newPackages new_packages
1029 if (not (null leftovers))
1030 then throwDyn (CmdLineError ("unrecognised flags: " ++
1035 unsetOptions :: String -> GHCi ()
1037 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1038 let opts = words str
1039 (minus_opts, rest1) = partition isMinus opts
1040 (plus_opts, rest2) = partition isPlus rest1
1042 if (not (null rest2))
1043 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1046 mapM_ unsetOpt plus_opts
1048 -- can't do GHC flags for now
1049 if (not (null minus_opts))
1050 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1053 isMinus ('-':s) = True
1056 isPlus ('+':s) = True
1060 = case strToGHCiOpt str of
1061 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1062 Just o -> setOption o
1065 = case strToGHCiOpt str of
1066 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1067 Just o -> unsetOption o
1069 strToGHCiOpt :: String -> (Maybe GHCiOption)
1070 strToGHCiOpt "s" = Just ShowTiming
1071 strToGHCiOpt "t" = Just ShowType
1072 strToGHCiOpt "r" = Just RevertCAFs
1073 strToGHCiOpt _ = Nothing
1075 optToStr :: GHCiOption -> String
1076 optToStr ShowTiming = "s"
1077 optToStr ShowType = "t"
1078 optToStr RevertCAFs = "r"
1081 newPackages new_pkgs = do -- The new packages are already in v_Packages
1082 session <- getSession
1083 io (GHC.setTargets session [])
1084 io (GHC.load session Nothing)
1085 dflags <- getDynFlags
1086 io (linkPackages dflags new_pkgs)
1087 setContextAfterLoad []
1090 -- ---------------------------------------------------------------------------
1095 ["modules" ] -> showModules
1096 ["bindings"] -> showBindings
1097 ["linker"] -> io showLinkerState
1098 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1101 session <- getSession
1102 let show_one ms = do m <- io (GHC.showModule session ms)
1104 graph <- io (GHC.getModuleGraph session)
1105 mapM_ show_one graph
1109 unqual <- io (GHC.getPrintUnqual s)
1110 bindings <- io (GHC.getBindings s)
1111 mapM_ showTyThing bindings
1114 showTyThing (AnId id) = do
1115 ty' <- cleanType (GHC.idType id)
1116 str <- showForUser (ppr id <> text " :: " <> ppr ty')
1118 showTyThing _ = return ()
1120 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1121 cleanType :: Type -> GHCi Type
1123 dflags <- getDynFlags
1124 if dopt Opt_GlasgowExts dflags
1126 else return $! GHC.dropForAlls ty
1128 -----------------------------------------------------------------------------
1131 data GHCiState = GHCiState
1135 session :: GHC.Session,
1136 options :: [GHCiOption]
1140 = ShowTiming -- show time/allocs after evaluation
1141 | ShowType -- show the type of expressions
1142 | RevertCAFs -- revert CAFs after every evaluation
1145 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1147 startGHCi :: GHCi a -> GHCiState -> IO a
1148 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1150 instance Monad GHCi where
1151 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1152 return a = GHCi $ \s -> return a
1154 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1155 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1156 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1158 getGHCiState = GHCi $ \r -> readIORef r
1159 setGHCiState s = GHCi $ \r -> writeIORef r s
1161 -- for convenience...
1162 getSession = getGHCiState >>= return . session
1166 io (GHC.getSessionDynFlags s)
1167 setDynFlags dflags = do
1169 io (GHC.setSessionDynFlags s dflags)
1171 isOptionSet :: GHCiOption -> GHCi Bool
1173 = do st <- getGHCiState
1174 return (opt `elem` options st)
1176 setOption :: GHCiOption -> GHCi ()
1178 = do st <- getGHCiState
1179 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1181 unsetOption :: GHCiOption -> GHCi ()
1183 = do st <- getGHCiState
1184 setGHCiState (st{ options = filter (/= opt) (options st) })
1186 io :: IO a -> GHCi a
1187 io m = GHCi { unGHCi = \s -> m >>= return }
1189 -----------------------------------------------------------------------------
1190 -- recursive exception handlers
1192 -- Don't forget to unblock async exceptions in the handler, or if we're
1193 -- in an exception loop (eg. let a = error a in a) the ^C exception
1194 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1196 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1197 ghciHandle h (GHCi m) = GHCi $ \s ->
1198 Exception.catch (m s)
1199 (\e -> unGHCi (ghciUnblock (h e)) s)
1201 ghciUnblock :: GHCi a -> GHCi a
1202 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1204 -----------------------------------------------------------------------------
1205 -- timing & statistics
1207 timeIt :: GHCi a -> GHCi a
1209 = do b <- isOptionSet ShowTiming
1212 else do allocs1 <- io $ getAllocations
1213 time1 <- io $ getCPUTime
1215 allocs2 <- io $ getAllocations
1216 time2 <- io $ getCPUTime
1217 io $ printTimes (fromIntegral (allocs2 - allocs1))
1221 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1222 -- defined in ghc/rts/Stats.c
1224 printTimes :: Integer -> Integer -> IO ()
1225 printTimes allocs psecs
1226 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1227 secs_str = showFFloat (Just 2) secs
1228 putStrLn (showSDoc (
1229 parens (text (secs_str "") <+> text "secs" <> comma <+>
1230 text (show allocs) <+> text "bytes")))
1232 -----------------------------------------------------------------------------
1239 -- Have to turn off buffering again, because we just
1240 -- reverted stdout, stderr & stdin to their defaults.
1242 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1243 -- Make it "safe", just in case
1245 -- -----------------------------------------------------------------------------
1248 expandPath :: String -> GHCi String
1250 case dropWhile isSpace path of
1252 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1253 return (tilde ++ '/':d)