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 )
41 #ifndef mingw32_HOST_OS
43 #if __GLASGOW_HASKELL__ > 504
47 import GHC.ConsoleHandler ( flushConsole )
51 import Control.Concurrent ( yield ) -- Used in readline loop
52 import System.Console.Readline as Readline
57 import Control.Exception as Exception
59 -- import Control.Concurrent
63 import Data.Int ( Int64 )
64 import Data.Maybe ( isJust, fromMaybe, catMaybes )
67 import System.Environment
68 import System.Exit ( exitWith, ExitCode(..) )
69 import System.Directory
71 import System.IO.Error as IO
73 import Control.Monad as Monad
74 import Foreign.StablePtr ( newStablePtr )
76 import GHC.Exts ( unsafeCoerce# )
77 import GHC.IOBase ( IOErrorType(InvalidArgument) )
79 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
81 import System.Posix.Internals ( setNonBlockingFD )
83 -----------------------------------------------------------------------------
87 " / _ \\ /\\ /\\/ __(_)\n"++
88 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
89 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
90 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
92 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
94 builtin_commands :: [(String, String -> GHCi Bool)]
96 ("add", keepGoingPaths addModule),
97 ("browse", keepGoing browseCmd),
98 ("cd", keepGoing changeDirectory),
99 ("def", keepGoing defineMacro),
100 ("help", keepGoing help),
101 ("?", keepGoing help),
102 ("info", keepGoing info),
103 ("load", keepGoingPaths loadModule_),
104 ("module", keepGoing setContext),
105 ("reload", keepGoing reloadModule),
106 ("check", keepGoing checkModule),
107 ("set", keepGoing setCmd),
108 ("show", keepGoing showCmd),
109 ("etags", keepGoing createETagsFileCmd),
110 ("ctags", keepGoing createCTagsFileCmd),
111 ("type", keepGoing typeOfExpr),
112 ("kind", keepGoing kindOfType),
113 ("unset", keepGoing unsetOptions),
114 ("undef", keepGoing undefineMacro),
118 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
119 keepGoing a str = a str >> return False
121 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
122 keepGoingPaths a str = a (toArgs str) >> return False
124 shortHelpText = "use :? for help.\n"
126 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
128 " Commands available from the prompt:\n" ++
130 " <stmt> evaluate/run <stmt>\n" ++
131 " :add <filename> ... add module(s) to the current target set\n" ++
132 " :browse [*]<module> display the names defined by <module>\n" ++
133 " :cd <dir> change directory to <dir>\n" ++
134 " :def <cmd> <expr> define a command :<cmd>\n" ++
135 " :help, :? display this list of commands\n" ++
136 " :info [<name> ...] display information about the given names\n" ++
137 " :load <filename> ... load module(s) and their dependents\n" ++
138 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
139 " :reload reload the current module set\n" ++
141 " :set <option> ... set options\n" ++
142 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
143 " :set prog <progname> set the value returned by System.getProgName\n" ++
145 " :show modules show the currently loaded modules\n" ++
146 " :show bindings show the current bindings made at the prompt\n" ++
148 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
149 " :etags [<file>] create tags file for Emacs (defauilt: \"TAGS\")\n" ++
150 " :type <expr> show the type of <expr>\n" ++
151 " :kind <type> show the kind of <type>\n" ++
152 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
153 " :unset <option> ... unset options\n" ++
154 " :quit exit GHCi\n" ++
155 " :!<command> run the shell command <command>\n" ++
157 " Options for ':set' and ':unset':\n" ++
159 " +r revert top-level expressions after each evaluation\n" ++
160 " +s print timing/memory stats after each evaluation\n" ++
161 " +t print type after evaluation\n" ++
162 " -<flags> most GHC command line flags can also be set here\n" ++
163 " (eg. -v2, -fglasgow-exts, etc.)\n"
166 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
167 interactiveUI session srcs maybe_expr = do
169 -- HACK! If we happen to get into an infinite loop (eg the user
170 -- types 'let x=x in x' at the prompt), then the thread will block
171 -- on a blackhole, and become unreachable during GC. The GC will
172 -- detect that it is unreachable and send it the NonTermination
173 -- exception. However, since the thread is unreachable, everything
174 -- it refers to might be finalized, including the standard Handles.
175 -- This sounds like a bug, but we don't have a good solution right
182 hSetBuffering stdout NoBuffering
184 -- Initialise buffering for the *interpreted* I/O system
185 initInterpBuffering session
187 -- We don't want the cmd line to buffer any input that might be
188 -- intended for the program, so unbuffer stdin.
189 hSetBuffering stdin NoBuffering
191 -- initial context is just the Prelude
192 GHC.setContext session [] [prelude_mod]
198 startGHCi (runGHCi srcs maybe_expr)
199 GHCiState{ progname = "<interactive>",
205 Readline.resetTerminal Nothing
210 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
211 runGHCi paths maybe_expr = do
212 let read_dot_files = not opt_IgnoreDotGhci
214 when (read_dot_files) $ do
217 exists <- io (doesFileExist file)
219 dir_ok <- io (checkPerms ".")
220 file_ok <- io (checkPerms file)
221 when (dir_ok && file_ok) $ do
222 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
225 Right hdl -> fileLoop hdl False
227 when (read_dot_files) $ do
228 -- Read in $HOME/.ghci
229 either_dir <- io (IO.try (getEnv "HOME"))
233 cwd <- io (getCurrentDirectory)
234 when (dir /= cwd) $ do
235 let file = dir ++ "/.ghci"
236 ok <- io (checkPerms file)
238 either_hdl <- io (IO.try (openFile file ReadMode))
241 Right hdl -> fileLoop hdl False
243 -- Perform a :load for files given on the GHCi command line
244 -- When in -e mode, if the load fails then we want to stop
245 -- immediately rather than going on to evaluate the expression.
246 when (not (null paths)) $ do
247 ok <- ghciHandle (\e -> do showException e; return Failed) $
249 when (isJust maybe_expr && failed ok) $
250 io (exitWith (ExitFailure 1))
252 -- if verbosity is greater than 0, or we are connected to a
253 -- terminal, display the prompt in the interactive loop.
254 is_tty <- io (hIsTerminalDevice stdin)
255 dflags <- getDynFlags
256 let show_prompt = verbosity dflags > 0 || is_tty
260 #if defined(mingw32_HOST_OS)
262 -- The win32 Console API mutates the first character of
263 -- type-ahead when reading from it in a non-buffered manner. Work
264 -- around this by flushing the input buffer of type-ahead characters,
265 -- but only if stdin is available.
266 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
268 Left err | isDoesNotExistError err -> return ()
269 | otherwise -> io (ioError err)
270 Right () -> return ()
272 -- enter the interactive loop
273 interactiveLoop is_tty show_prompt
275 -- just evaluate the expression we were given
280 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
283 interactiveLoop is_tty show_prompt = do
284 -- Ignore ^C exceptions caught here
285 ghciHandleDyn (\e -> case e of
286 Interrupted -> ghciUnblock (
287 #if defined(mingw32_HOST_OS)
290 interactiveLoop is_tty show_prompt)
291 _other -> return ()) $ do
293 -- read commands from stdin
297 else fileLoop stdin show_prompt
299 fileLoop stdin show_prompt
303 -- NOTE: We only read .ghci files if they are owned by the current user,
304 -- and aren't world writable. Otherwise, we could be accidentally
305 -- running code planted by a malicious third party.
307 -- Furthermore, We only read ./.ghci if . is owned by the current user
308 -- and isn't writable by anyone else. I think this is sufficient: we
309 -- don't need to check .. and ../.. etc. because "." always refers to
310 -- the same directory while a process is running.
312 checkPerms :: String -> IO Bool
314 #ifdef mingw32_HOST_OS
317 Util.handle (\_ -> return False) $ do
318 st <- getFileStatus name
320 if fileOwner st /= me then do
321 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
324 let mode = fileMode st
325 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
326 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
328 putStrLn $ "*** WARNING: " ++ name ++
329 " is writable by someone else, IGNORING!"
334 fileLoop :: Handle -> Bool -> GHCi ()
335 fileLoop hdl prompt = do
336 session <- getSession
337 (mod,imports) <- io (GHC.getContext session)
338 when prompt (io (putStr (mkPrompt mod imports)))
339 l <- io (IO.try (hGetLine hdl))
341 Left e | isEOFError e -> return ()
342 | InvalidArgument <- etype -> return ()
343 | otherwise -> io (ioError e)
344 where etype = ioeGetErrorType e
345 -- treat InvalidArgument in the same way as EOF:
346 -- this can happen if the user closed stdin, or
347 -- perhaps did getContents which closes stdin at
350 case removeSpaces l of
351 "" -> fileLoop hdl prompt
352 l -> do quit <- runCommand l
353 if quit then return () else fileLoop hdl prompt
355 stringLoop :: [String] -> GHCi ()
356 stringLoop [] = return ()
357 stringLoop (s:ss) = do
358 case removeSpaces s of
360 l -> do quit <- runCommand l
361 if quit then return () else stringLoop ss
363 mkPrompt toplevs exports
364 = showSDoc (hsep (map (\m -> char '*' <> pprModule m) toplevs)
365 <+> hsep (map pprModule exports)
369 readlineLoop :: GHCi ()
371 session <- getSession
372 (mod,imports) <- io (GHC.getContext session)
374 l <- io (readline (mkPrompt mod imports)
375 `finally` setNonBlockingFD 0)
376 -- readline sometimes puts stdin into blocking mode,
377 -- so we need to put it back for the IO library
381 case removeSpaces l of
386 if quit then return () else readlineLoop
389 runCommand :: String -> GHCi Bool
390 runCommand c = ghciHandle handler (doCommand c)
392 doCommand (':' : command) = specialCommand command
394 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
397 -- This version is for the GHC command-line option -e. The only difference
398 -- from runCommand is that it catches the ExitException exception and
399 -- exits, rather than printing out the exception.
400 runCommandEval c = ghciHandle handleEval (doCommand c)
402 handleEval (ExitException code) = io (exitWith code)
403 handleEval e = do showException e
404 io (exitWith (ExitFailure 1))
406 doCommand (':' : command) = specialCommand command
408 = do nms <- runStmt stmt
410 Nothing -> io (exitWith (ExitFailure 1))
411 -- failure to run the command causes exit(1) for ghc -e.
412 _ -> finishEvalExpr nms
414 -- This is the exception handler for exceptions generated by the
415 -- user's code; it normally just prints out the exception. The
416 -- handler must be recursive, in case showing the exception causes
417 -- more exceptions to be raised.
419 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
420 -- raising another exception. We therefore don't put the recursive
421 -- handler arond the flushing operation, so if stderr is closed
422 -- GHCi will just die gracefully rather than going into an infinite loop.
423 handler :: Exception -> GHCi Bool
424 handler exception = do
426 io installSignalHandlers
427 ghciHandle handler (showException exception >> return False)
429 showException (DynException dyn) =
430 case fromDynamic dyn of
431 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
432 Just Interrupted -> io (putStrLn "Interrupted.")
433 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
434 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
435 Just other_ghc_ex -> io (print other_ghc_ex)
437 showException other_exception
438 = io (putStrLn ("*** Exception: " ++ show other_exception))
440 runStmt :: String -> GHCi (Maybe [Name])
442 | null (filter (not.isSpace) stmt) = return (Just [])
444 = do st <- getGHCiState
445 session <- getSession
446 result <- io $ withProgName (progname st) $ withArgs (args st) $
447 GHC.runStmt session stmt
449 GHC.RunFailed -> return Nothing
450 GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
451 GHC.RunOk names -> return (Just names)
453 -- possibly print the type and revert CAFs after evaluating an expression
454 finishEvalExpr mb_names
455 = do b <- isOptionSet ShowType
456 session <- getSession
459 Just names -> when b (mapM_ (showTypeOfName session) names)
462 io installSignalHandlers
463 b <- isOptionSet RevertCAFs
464 io (when b revertCAFs)
467 showTypeOfName :: Session -> Name -> GHCi ()
468 showTypeOfName session n
469 = do maybe_tything <- io (GHC.lookupName session n)
470 case maybe_tything of
472 Just thing -> showTyThing thing
474 showForUser :: SDoc -> GHCi String
476 session <- getSession
477 unqual <- io (GHC.getPrintUnqual session)
478 return $! showSDocForUser unqual doc
480 specialCommand :: String -> GHCi Bool
481 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
482 specialCommand str = do
483 let (cmd,rest) = break isSpace str
484 cmds <- io (readIORef commands)
485 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
486 [] -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
487 ++ shortHelpText) >> return False)
488 [(_,f)] -> f (dropWhile isSpace rest)
489 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
490 " matches multiple commands (" ++
491 foldr1 (\a b -> a ++ ',':b) (map fst cs)
492 ++ ")") >> return False)
494 -----------------------------------------------------------------------------
495 -- To flush buffers for the *interpreted* computation we need
496 -- to refer to *its* stdout/stderr handles
498 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
499 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
501 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
502 " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
503 flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
505 initInterpBuffering :: Session -> IO ()
506 initInterpBuffering session
507 = do maybe_hval <- GHC.compileExpr session no_buf_cmd
510 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
511 other -> panic "interactiveUI:setBuffering"
513 maybe_hval <- GHC.compileExpr session flush_cmd
515 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
516 _ -> panic "interactiveUI:flush"
518 turnOffBuffering -- Turn it off right now
523 flushInterpBuffers :: GHCi ()
525 = io $ do Monad.join (readIORef flush_interp)
528 turnOffBuffering :: IO ()
530 = do Monad.join (readIORef turn_off_buffering)
533 -----------------------------------------------------------------------------
536 help :: String -> GHCi ()
537 help _ = io (putStr helpText)
539 info :: String -> GHCi ()
540 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
541 info s = do { let names = words s
542 ; session <- getSession
543 ; dflags <- getDynFlags
544 ; let exts = dopt Opt_GlasgowExts dflags
545 ; mapM_ (infoThing exts session) names }
547 infoThing exts session str = io $ do
548 names <- GHC.parseName session str
549 let filtered = filterOutChildren names
550 mb_stuffs <- mapM (GHC.getInfo session) filtered
551 unqual <- GHC.getPrintUnqual session
552 putStrLn (showSDocForUser unqual $
553 vcat (intersperse (text "") $
554 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
556 -- Filter out names whose parent is also there Good
557 -- example is '[]', which is both a type and data
558 -- constructor in the same type
559 filterOutChildren :: [Name] -> [Name]
560 filterOutChildren names = filter (not . parent_is_there) names
561 where parent_is_there n
562 | Just p <- GHC.nameParent_maybe n = p `elem` names
565 pprInfo exts (thing, fixity, insts)
566 = pprTyThingInContextLoc exts thing
567 $$ show_fixity fixity
568 $$ vcat (map GHC.pprInstance insts)
571 | fix == GHC.defaultFixity = empty
572 | otherwise = ppr fix <+> ppr (GHC.getName thing)
574 -----------------------------------------------------------------------------
577 addModule :: [FilePath] -> GHCi ()
579 io (revertCAFs) -- always revert CAFs on load/add.
580 files <- mapM expandPath files
581 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
582 session <- getSession
583 io (mapM_ (GHC.addTarget session) targets)
584 ok <- io (GHC.load session LoadAllTargets)
587 changeDirectory :: String -> GHCi ()
588 changeDirectory dir = do
589 session <- getSession
590 graph <- io (GHC.getModuleGraph session)
591 when (not (null graph)) $
592 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
593 io (GHC.setTargets session [])
594 io (GHC.load session LoadAllTargets)
595 setContextAfterLoad []
596 io (GHC.workingDirectoryChanged session)
597 dir <- expandPath dir
598 io (setCurrentDirectory dir)
600 defineMacro :: String -> GHCi ()
602 let (macro_name, definition) = break isSpace s
603 cmds <- io (readIORef commands)
605 then throwDyn (CmdLineError "invalid macro name")
607 if (macro_name `elem` map fst cmds)
608 then throwDyn (CmdLineError
609 ("command '" ++ macro_name ++ "' is already defined"))
612 -- give the expression a type signature, so we can be sure we're getting
613 -- something of the right type.
614 let new_expr = '(' : definition ++ ") :: String -> IO String"
616 -- compile the expression
618 maybe_hv <- io (GHC.compileExpr cms new_expr)
621 Just hv -> io (writeIORef commands --
622 ((macro_name, keepGoing (runMacro hv)) : cmds))
624 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi ()
626 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
627 stringLoop (lines str)
629 undefineMacro :: String -> GHCi ()
630 undefineMacro macro_name = do
631 cmds <- io (readIORef commands)
632 if (macro_name `elem` map fst builtin_commands)
633 then throwDyn (CmdLineError
634 ("command '" ++ macro_name ++ "' cannot be undefined"))
636 if (macro_name `notElem` map fst cmds)
637 then throwDyn (CmdLineError
638 ("command '" ++ macro_name ++ "' not defined"))
640 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
643 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
644 loadModule fs = timeIt (loadModule' fs)
646 loadModule_ :: [FilePath] -> GHCi ()
647 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
649 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
650 loadModule' files = do
651 session <- getSession
654 io (GHC.setTargets session [])
655 io (GHC.load session LoadAllTargets)
658 let (filenames, phases) = unzip files
659 exp_filenames <- mapM expandPath filenames
660 let files' = zip exp_filenames phases
661 targets <- io (mapM (uncurry GHC.guessTarget) files')
663 -- NOTE: we used to do the dependency anal first, so that if it
664 -- fails we didn't throw away the current set of modules. This would
665 -- require some re-working of the GHC interface, so we'll leave it
666 -- as a ToDo for now.
668 io (GHC.setTargets session targets)
669 ok <- io (GHC.load session LoadAllTargets)
673 checkModule :: String -> GHCi ()
675 let modl = mkModule m
676 session <- getSession
677 result <- io (GHC.checkModule session modl)
679 Nothing -> io $ putStrLn "Nothing"
680 Just r -> io $ putStrLn (showSDoc (
681 case checkedModuleInfo r of
682 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
684 (local,global) = partition ((== modl) . GHC.nameModule) scope
686 (text "global names: " <+> ppr global) $$
687 (text "local names: " <+> ppr local)
689 afterLoad (successIf (isJust result)) session
691 reloadModule :: String -> GHCi ()
693 io (revertCAFs) -- always revert CAFs on reload.
694 session <- getSession
695 ok <- io (GHC.load session LoadAllTargets)
698 io (revertCAFs) -- always revert CAFs on reload.
699 session <- getSession
700 ok <- io (GHC.load session (LoadUpTo (mkModule m)))
703 afterLoad ok session = do
704 io (revertCAFs) -- always revert CAFs on load.
705 graph <- io (GHC.getModuleGraph session)
706 let mods = map GHC.ms_mod graph
707 mods' <- filterM (io . GHC.isLoaded session) mods
708 setContextAfterLoad mods'
709 modulesLoadedMsg ok mods'
711 setContextAfterLoad [] = do
712 session <- getSession
713 io (GHC.setContext session [] [prelude_mod])
714 setContextAfterLoad (m:_) = do
715 session <- getSession
716 b <- io (GHC.moduleIsInterpreted session m)
717 if b then io (GHC.setContext session [m] [])
718 else io (GHC.setContext session [] [prelude_mod,m])
720 modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi ()
721 modulesLoadedMsg ok mods = do
722 dflags <- getDynFlags
723 when (verbosity dflags > 0) $ do
725 | null mods = text "none."
727 punctuate comma (map pprModule mods)) <> text "."
730 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
732 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
735 typeOfExpr :: String -> GHCi ()
737 = do cms <- getSession
738 maybe_ty <- io (GHC.exprType cms str)
741 Just ty -> do ty' <- cleanType ty
742 tystr <- showForUser (ppr ty')
743 io (putStrLn (str ++ " :: " ++ tystr))
745 kindOfType :: String -> GHCi ()
747 = do cms <- getSession
748 maybe_ty <- io (GHC.typeKind cms str)
751 Just ty -> do tystr <- showForUser (ppr ty)
752 io (putStrLn (str ++ " :: " ++ tystr))
754 quit :: String -> GHCi Bool
757 shellEscape :: String -> GHCi Bool
758 shellEscape str = io (system str >> return False)
760 -----------------------------------------------------------------------------
761 -- create tags file for currently loaded modules.
763 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
765 createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
766 createCTagsFileCmd file = ghciCreateTagsFile CTags file
768 createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
769 createETagsFileCmd file = ghciCreateTagsFile ETags file
771 data TagsKind = ETags | CTags
773 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
774 ghciCreateTagsFile kind file = do
775 session <- getSession
776 io $ createTagsFile session kind file
779 -- - remove restriction that all modules must be interpreted
780 -- (problem: we don't know source locations for entities unless
781 -- we compiled the module.
783 -- - extract createTagsFile so it can be used from the command-line
784 -- (probably need to fix first problem before this is useful).
786 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
787 createTagsFile session tagskind tagFile = do
788 graph <- GHC.getModuleGraph session
789 let ms = map GHC.ms_mod graph
791 is_interpreted <- GHC.moduleIsInterpreted session m
792 -- should we just skip these?
793 when (not is_interpreted) $
794 throwDyn (CmdLineError ("module '" ++ moduleUserString m ++ "' is not interpreted"))
796 mbModInfo <- GHC.getModuleInfo session m
798 | Just modinfo <- mbModInfo,
799 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
800 | otherwise = GHC.alwaysQualify
803 Just modInfo -> return $! listTags unqual modInfo
806 mtags <- mapM tagModule ms
807 either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
809 Left e -> hPutStrLn stderr $ ioeGetErrorString e
812 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
813 listTags unqual modInfo =
814 [ tagInfo unqual name loc
815 | name <- GHC.modInfoExports modInfo
816 , let loc = nameSrcLoc name
820 type TagInfo = (String -- tag name
823 ,Int -- column number
826 -- get tag info, for later translation into Vim or Emacs style
827 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
828 tagInfo unqual name loc
829 = ( showSDocForUser unqual $ pprOccName (nameOccName name)
830 , showSDocForUser unqual $ ftext (srcLocFile loc)
835 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
836 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
837 let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
838 IO.try (writeFile file tags)
839 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
840 let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
841 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
842 tagGroups <- mapM tagFileGroup groups
843 IO.try (writeFile file $ concat tagGroups)
845 tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
846 tagFileGroup group@((_,fileName,_,_):_) = do
847 file <- readFile fileName -- need to get additional info from sources..
848 let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
849 sortedGroup = sortLe byLine group
850 tags = unlines $ perFile sortedGroup 1 0 $ lines file
851 return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
852 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
853 perFile (tagInfo:tags) (count+1) (pos+length line) lines
854 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
855 showETag tagInfo line pos : perFile tags count pos lines
856 perFile tags count pos lines = []
858 -- simple ctags format, for Vim et al
859 showTag :: TagInfo -> String
860 showTag (tag,file,lineNo,colNo)
861 = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
863 -- etags format, for Emacs/XEmacs
864 showETag :: TagInfo -> String -> Int -> String
865 showETag (tag,file,lineNo,colNo) line charPos
866 = take colNo line ++ tag
868 ++ "\x01" ++ show lineNo
869 ++ "," ++ show charPos
871 -----------------------------------------------------------------------------
872 -- Browsing a module's contents
874 browseCmd :: String -> GHCi ()
877 ['*':m] | looksLikeModuleName m -> browseModule m False
878 [m] | looksLikeModuleName m -> browseModule m True
879 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
881 browseModule m exports_only = do
884 let modl = mkModule m
885 is_interpreted <- io (GHC.moduleIsInterpreted s modl)
886 when (not is_interpreted && not exports_only) $
887 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
889 -- Temporarily set the context to the module we're interested in,
890 -- just so we can get an appropriate PrintUnqualified
891 (as,bs) <- io (GHC.getContext s)
892 io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
893 else GHC.setContext s [modl] [])
894 unqual <- io (GHC.getPrintUnqual s)
895 io (GHC.setContext s as bs)
897 mb_mod_info <- io $ GHC.getModuleInfo s modl
899 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
902 | exports_only = GHC.modInfoExports mod_info
903 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
905 filtered = filterOutChildren names
907 things <- io $ mapM (GHC.lookupName s) filtered
909 dflags <- getDynFlags
910 let exts = dopt Opt_GlasgowExts dflags
911 io (putStrLn (showSDocForUser unqual (
912 vcat (map (pprTyThingInContext exts) (catMaybes things))
914 -- ToDo: modInfoInstances currently throws an exception for
915 -- package modules. When it works, we can do this:
916 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
918 -----------------------------------------------------------------------------
919 -- Setting the module context
922 | all sensible mods = fn mods
923 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
925 (fn, mods) = case str of
926 '+':stuff -> (addToContext, words stuff)
927 '-':stuff -> (removeFromContext, words stuff)
928 stuff -> (newContext, words stuff)
930 sensible ('*':m) = looksLikeModuleName m
931 sensible m = looksLikeModuleName m
934 session <- getSession
935 (as,bs) <- separate session mods [] []
936 let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs
937 io (GHC.setContext session as bs')
939 separate :: Session -> [String] -> [Module] -> [Module]
940 -> GHCi ([Module],[Module])
941 separate session [] as bs = return (as,bs)
942 separate session (('*':m):ms) as bs = do
943 let modl = mkModule m
944 b <- io (GHC.moduleIsInterpreted session modl)
945 if b then separate session ms (modl:as) bs
946 else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
947 separate session (m:ms) as bs = separate session ms as (mkModule m:bs)
949 prelude_mod = mkModule "Prelude"
952 addToContext mods = do
954 (as,bs) <- io (GHC.getContext cms)
956 (as',bs') <- separate cms mods [] []
958 let as_to_add = as' \\ (as ++ bs)
959 bs_to_add = bs' \\ (as ++ bs)
961 io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add))
964 removeFromContext mods = do
966 (as,bs) <- io (GHC.getContext cms)
968 (as_to_remove,bs_to_remove) <- separate cms mods [] []
970 let as' = as \\ (as_to_remove ++ bs_to_remove)
971 bs' = bs \\ (as_to_remove ++ bs_to_remove)
973 io (GHC.setContext cms as' bs')
975 ----------------------------------------------------------------------------
978 -- set options in the interpreter. Syntax is exactly the same as the
979 -- ghc command line, except that certain options aren't available (-C,
982 -- This is pretty fragile: most options won't work as expected. ToDo:
983 -- figure out which ones & disallow them.
985 setCmd :: String -> GHCi ()
987 = do st <- getGHCiState
988 let opts = options st
989 io $ putStrLn (showSDoc (
990 text "options currently set: " <>
993 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
997 ("args":args) -> setArgs args
998 ("prog":prog) -> setProg prog
999 wds -> setOptions wds
1003 setGHCiState st{ args = args }
1007 setGHCiState st{ progname = prog }
1009 io (hPutStrLn stderr "syntax: :set prog <progname>")
1012 do -- first, deal with the GHCi opts (+s, +t, etc.)
1013 let (plus_opts, minus_opts) = partition isPlus wds
1014 mapM_ setOpt plus_opts
1016 -- then, dynamic flags
1017 dflags <- getDynFlags
1018 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1021 -- update things if the users wants more packages
1023 let new_packages = pkgs_after \\ pkgs_before
1024 when (not (null new_packages)) $
1025 newPackages new_packages
1028 if (not (null leftovers))
1029 then throwDyn (CmdLineError ("unrecognised flags: " ++
1034 unsetOptions :: String -> GHCi ()
1036 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1037 let opts = words str
1038 (minus_opts, rest1) = partition isMinus opts
1039 (plus_opts, rest2) = partition isPlus rest1
1041 if (not (null rest2))
1042 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1045 mapM_ unsetOpt plus_opts
1047 -- can't do GHC flags for now
1048 if (not (null minus_opts))
1049 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1052 isMinus ('-':s) = True
1055 isPlus ('+':s) = True
1059 = case strToGHCiOpt str of
1060 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1061 Just o -> setOption o
1064 = case strToGHCiOpt str of
1065 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1066 Just o -> unsetOption o
1068 strToGHCiOpt :: String -> (Maybe GHCiOption)
1069 strToGHCiOpt "s" = Just ShowTiming
1070 strToGHCiOpt "t" = Just ShowType
1071 strToGHCiOpt "r" = Just RevertCAFs
1072 strToGHCiOpt _ = Nothing
1074 optToStr :: GHCiOption -> String
1075 optToStr ShowTiming = "s"
1076 optToStr ShowType = "t"
1077 optToStr RevertCAFs = "r"
1080 newPackages new_pkgs = do -- The new packages are already in v_Packages
1081 session <- getSession
1082 io (GHC.setTargets session [])
1083 io (GHC.load session Nothing)
1084 dflags <- getDynFlags
1085 io (linkPackages dflags new_pkgs)
1086 setContextAfterLoad []
1089 -- ---------------------------------------------------------------------------
1094 ["modules" ] -> showModules
1095 ["bindings"] -> showBindings
1096 ["linker"] -> io showLinkerState
1097 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1100 session <- getSession
1101 let show_one ms = do m <- io (GHC.showModule session ms)
1103 graph <- io (GHC.getModuleGraph session)
1104 mapM_ show_one graph
1108 unqual <- io (GHC.getPrintUnqual s)
1109 bindings <- io (GHC.getBindings s)
1110 mapM_ showTyThing bindings
1113 showTyThing (AnId id) = do
1114 ty' <- cleanType (GHC.idType id)
1115 str <- showForUser (ppr id <> text " :: " <> ppr ty')
1117 showTyThing _ = return ()
1119 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1120 cleanType :: Type -> GHCi Type
1122 dflags <- getDynFlags
1123 if dopt Opt_GlasgowExts dflags
1125 else return $! GHC.dropForAlls ty
1127 -----------------------------------------------------------------------------
1130 data GHCiState = GHCiState
1134 session :: GHC.Session,
1135 options :: [GHCiOption]
1139 = ShowTiming -- show time/allocs after evaluation
1140 | ShowType -- show the type of expressions
1141 | RevertCAFs -- revert CAFs after every evaluation
1144 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1146 startGHCi :: GHCi a -> GHCiState -> IO a
1147 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1149 instance Monad GHCi where
1150 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1151 return a = GHCi $ \s -> return a
1153 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1154 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1155 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1157 getGHCiState = GHCi $ \r -> readIORef r
1158 setGHCiState s = GHCi $ \r -> writeIORef r s
1160 -- for convenience...
1161 getSession = getGHCiState >>= return . session
1165 io (GHC.getSessionDynFlags s)
1166 setDynFlags dflags = do
1168 io (GHC.setSessionDynFlags s dflags)
1170 isOptionSet :: GHCiOption -> GHCi Bool
1172 = do st <- getGHCiState
1173 return (opt `elem` options st)
1175 setOption :: GHCiOption -> GHCi ()
1177 = do st <- getGHCiState
1178 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1180 unsetOption :: GHCiOption -> GHCi ()
1182 = do st <- getGHCiState
1183 setGHCiState (st{ options = filter (/= opt) (options st) })
1185 io :: IO a -> GHCi a
1186 io m = GHCi { unGHCi = \s -> m >>= return }
1188 -----------------------------------------------------------------------------
1189 -- recursive exception handlers
1191 -- Don't forget to unblock async exceptions in the handler, or if we're
1192 -- in an exception loop (eg. let a = error a in a) the ^C exception
1193 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1195 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1196 ghciHandle h (GHCi m) = GHCi $ \s ->
1197 Exception.catch (m s)
1198 (\e -> unGHCi (ghciUnblock (h e)) s)
1200 ghciUnblock :: GHCi a -> GHCi a
1201 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1203 -----------------------------------------------------------------------------
1204 -- timing & statistics
1206 timeIt :: GHCi a -> GHCi a
1208 = do b <- isOptionSet ShowTiming
1211 else do allocs1 <- io $ getAllocations
1212 time1 <- io $ getCPUTime
1214 allocs2 <- io $ getAllocations
1215 time2 <- io $ getCPUTime
1216 io $ printTimes (fromIntegral (allocs2 - allocs1))
1220 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1221 -- defined in ghc/rts/Stats.c
1223 printTimes :: Integer -> Integer -> IO ()
1224 printTimes allocs psecs
1225 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1226 secs_str = showFFloat (Just 2) secs
1227 putStrLn (showSDoc (
1228 parens (text (secs_str "") <+> text "secs" <> comma <+>
1229 text (show allocs) <+> text "bytes")))
1231 -----------------------------------------------------------------------------
1238 -- Have to turn off buffering again, because we just
1239 -- reverted stdout, stderr & stdin to their defaults.
1241 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1242 -- Make it "safe", just in case
1244 -- -----------------------------------------------------------------------------
1247 expandPath :: String -> GHCi String
1249 case dropWhile isSpace path of
1251 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1252 return (tilde ++ '/':d)