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 #if defined(mingw32_HOST_OS)
200 -- The win32 Console API mutates the first character of
201 -- type-ahead when reading from it in a non-buffered manner. Work
202 -- around this by flushing the input buffer of type-ahead characters.
204 GHC.ConsoleHandler.flushConsole stdin
206 startGHCi (runGHCi srcs maybe_expr)
207 GHCiState{ progname = "<interactive>",
213 Readline.resetTerminal Nothing
218 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
219 runGHCi paths maybe_expr = do
220 let read_dot_files = not opt_IgnoreDotGhci
222 when (read_dot_files) $ do
225 exists <- io (doesFileExist file)
227 dir_ok <- io (checkPerms ".")
228 file_ok <- io (checkPerms file)
229 when (dir_ok && file_ok) $ do
230 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
233 Right hdl -> fileLoop hdl False
235 when (read_dot_files) $ do
236 -- Read in $HOME/.ghci
237 either_dir <- io (IO.try (getEnv "HOME"))
241 cwd <- io (getCurrentDirectory)
242 when (dir /= cwd) $ do
243 let file = dir ++ "/.ghci"
244 ok <- io (checkPerms file)
246 either_hdl <- io (IO.try (openFile file ReadMode))
249 Right hdl -> fileLoop hdl False
251 -- Perform a :load for files given on the GHCi command line
252 -- When in -e mode, if the load fails then we want to stop
253 -- immediately rather than going on to evaluate the expression.
254 when (not (null paths)) $ do
255 ok <- ghciHandle (\e -> do showException e; return Failed) $
257 when (isJust maybe_expr && failed ok) $
258 io (exitWith (ExitFailure 1))
260 -- if verbosity is greater than 0, or we are connected to a
261 -- terminal, display the prompt in the interactive loop.
262 is_tty <- io (hIsTerminalDevice stdin)
263 dflags <- getDynFlags
264 let show_prompt = verbosity dflags > 0 || is_tty
268 -- enter the interactive loop
269 interactiveLoop is_tty show_prompt
271 -- just evaluate the expression we were given
276 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
279 interactiveLoop is_tty show_prompt = do
280 -- Ignore ^C exceptions caught here
281 ghciHandleDyn (\e -> case e of
282 Interrupted -> ghciUnblock (
283 #if defined(mingw32_HOST_OS)
286 interactiveLoop is_tty show_prompt)
287 _other -> return ()) $ do
289 -- read commands from stdin
293 else fileLoop stdin show_prompt
295 fileLoop stdin show_prompt
299 -- NOTE: We only read .ghci files if they are owned by the current user,
300 -- and aren't world writable. Otherwise, we could be accidentally
301 -- running code planted by a malicious third party.
303 -- Furthermore, We only read ./.ghci if . is owned by the current user
304 -- and isn't writable by anyone else. I think this is sufficient: we
305 -- don't need to check .. and ../.. etc. because "." always refers to
306 -- the same directory while a process is running.
308 checkPerms :: String -> IO Bool
310 #ifdef mingw32_HOST_OS
313 Util.handle (\_ -> return False) $ do
314 st <- getFileStatus name
316 if fileOwner st /= me then do
317 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
320 let mode = fileMode st
321 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
322 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
324 putStrLn $ "*** WARNING: " ++ name ++
325 " is writable by someone else, IGNORING!"
330 fileLoop :: Handle -> Bool -> GHCi ()
331 fileLoop hdl prompt = do
332 session <- getSession
333 (mod,imports) <- io (GHC.getContext session)
334 when prompt (io (putStr (mkPrompt mod imports)))
335 l <- io (IO.try (hGetLine hdl))
337 Left e | isEOFError e -> return ()
338 | InvalidArgument <- etype -> return ()
339 | otherwise -> io (ioError e)
340 where etype = ioeGetErrorType e
341 -- treat InvalidArgument in the same way as EOF:
342 -- this can happen if the user closed stdin, or
343 -- perhaps did getContents which closes stdin at
346 case removeSpaces l of
347 "" -> fileLoop hdl prompt
348 l -> do quit <- runCommand l
349 if quit then return () else fileLoop hdl prompt
351 stringLoop :: [String] -> GHCi ()
352 stringLoop [] = return ()
353 stringLoop (s:ss) = do
354 case removeSpaces s of
356 l -> do quit <- runCommand l
357 if quit then return () else stringLoop ss
359 mkPrompt toplevs exports
360 = showSDoc (hsep (map (\m -> char '*' <> pprModule m) toplevs)
361 <+> hsep (map pprModule exports)
365 readlineLoop :: GHCi ()
367 session <- getSession
368 (mod,imports) <- io (GHC.getContext session)
370 l <- io (readline (mkPrompt mod imports)
371 `finally` setNonBlockingFD 0)
372 -- readline sometimes puts stdin into blocking mode,
373 -- so we need to put it back for the IO library
377 case removeSpaces l of
382 if quit then return () else readlineLoop
385 runCommand :: String -> GHCi Bool
386 runCommand c = ghciHandle handler (doCommand c)
388 -- This version is for the GHC command-line option -e. The only difference
389 -- from runCommand is that it catches the ExitException exception and
390 -- exits, rather than printing out the exception.
391 runCommandEval c = ghciHandle handleEval (doCommand c)
393 handleEval (ExitException code) = io (exitWith code)
394 handleEval e = do showException e
395 io (exitWith (ExitFailure 1))
397 -- This is the exception handler for exceptions generated by the
398 -- user's code; it normally just prints out the exception. The
399 -- handler must be recursive, in case showing the exception causes
400 -- more exceptions to be raised.
402 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
403 -- raising another exception. We therefore don't put the recursive
404 -- handler arond the flushing operation, so if stderr is closed
405 -- GHCi will just die gracefully rather than going into an infinite loop.
406 handler :: Exception -> GHCi Bool
407 handler exception = do
409 io installSignalHandlers
410 ghciHandle handler (showException exception >> return False)
412 showException (DynException dyn) =
413 case fromDynamic dyn of
414 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
415 Just Interrupted -> io (putStrLn "Interrupted.")
416 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
417 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
418 Just other_ghc_ex -> io (print other_ghc_ex)
420 showException other_exception
421 = io (putStrLn ("*** Exception: " ++ show other_exception))
423 doCommand (':' : command) = specialCommand command
425 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
428 runStmt :: String -> GHCi [Name]
430 | null (filter (not.isSpace) stmt) = return []
432 = do st <- getGHCiState
433 session <- getSession
434 result <- io $ withProgName (progname st) $ withArgs (args st) $
435 GHC.runStmt session stmt
437 GHC.RunFailed -> return []
438 GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
439 GHC.RunOk names -> return names
441 -- possibly print the type and revert CAFs after evaluating an expression
443 = do b <- isOptionSet ShowType
444 session <- getSession
445 when b (mapM_ (showTypeOfName session) names)
448 io installSignalHandlers
449 b <- isOptionSet RevertCAFs
450 io (when b revertCAFs)
453 showTypeOfName :: Session -> Name -> GHCi ()
454 showTypeOfName session n
455 = do maybe_tything <- io (GHC.lookupName session n)
456 case maybe_tything of
458 Just thing -> showTyThing thing
460 showForUser :: SDoc -> GHCi String
462 session <- getSession
463 unqual <- io (GHC.getPrintUnqual session)
464 return $! showSDocForUser unqual doc
466 specialCommand :: String -> GHCi Bool
467 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
468 specialCommand str = do
469 let (cmd,rest) = break isSpace str
470 cmds <- io (readIORef commands)
471 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
472 [] -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
473 ++ shortHelpText) >> return False)
474 [(_,f)] -> f (dropWhile isSpace rest)
475 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
476 " matches multiple commands (" ++
477 foldr1 (\a b -> a ++ ',':b) (map fst cs)
478 ++ ")") >> return False)
480 -----------------------------------------------------------------------------
481 -- To flush buffers for the *interpreted* computation we need
482 -- to refer to *its* stdout/stderr handles
484 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
485 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
487 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
488 " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
489 flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
491 initInterpBuffering :: Session -> IO ()
492 initInterpBuffering session
493 = do maybe_hval <- GHC.compileExpr session no_buf_cmd
496 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
497 other -> panic "interactiveUI:setBuffering"
499 maybe_hval <- GHC.compileExpr session flush_cmd
501 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
502 _ -> panic "interactiveUI:flush"
504 turnOffBuffering -- Turn it off right now
509 flushInterpBuffers :: GHCi ()
511 = io $ do Monad.join (readIORef flush_interp)
514 turnOffBuffering :: IO ()
516 = do Monad.join (readIORef turn_off_buffering)
519 -----------------------------------------------------------------------------
522 help :: String -> GHCi ()
523 help _ = io (putStr helpText)
525 info :: String -> GHCi ()
526 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
527 info s = do { let names = words s
528 ; session <- getSession
529 ; dflags <- getDynFlags
530 ; let exts = dopt Opt_GlasgowExts dflags
531 ; mapM_ (infoThing exts session) names }
533 infoThing exts session str = io $ do
534 names <- GHC.parseName session str
535 let filtered = filterOutChildren names
536 mb_stuffs <- mapM (GHC.getInfo session) filtered
537 unqual <- GHC.getPrintUnqual session
538 putStrLn (showSDocForUser unqual $
539 vcat (intersperse (text "") $
540 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
542 -- Filter out names whose parent is also there Good
543 -- example is '[]', which is both a type and data
544 -- constructor in the same type
545 filterOutChildren :: [Name] -> [Name]
546 filterOutChildren names = filter (not . parent_is_there) names
547 where parent_is_there n
548 | Just p <- GHC.nameParent_maybe n = p `elem` names
551 pprInfo exts (thing, fixity, insts)
552 = pprTyThingInContextLoc exts thing
553 $$ show_fixity fixity
554 $$ vcat (map GHC.pprInstance insts)
557 | fix == GHC.defaultFixity = empty
558 | otherwise = ppr fix <+> ppr (GHC.getName thing)
560 -----------------------------------------------------------------------------
563 addModule :: [FilePath] -> GHCi ()
565 io (revertCAFs) -- always revert CAFs on load/add.
566 files <- mapM expandPath files
567 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
568 session <- getSession
569 io (mapM_ (GHC.addTarget session) targets)
570 ok <- io (GHC.load session LoadAllTargets)
573 changeDirectory :: String -> GHCi ()
574 changeDirectory dir = do
575 session <- getSession
576 graph <- io (GHC.getModuleGraph session)
577 when (not (null graph)) $
578 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
579 io (GHC.setTargets session [])
580 io (GHC.load session LoadAllTargets)
581 setContextAfterLoad []
582 io (GHC.workingDirectoryChanged session)
583 dir <- expandPath dir
584 io (setCurrentDirectory dir)
586 defineMacro :: String -> GHCi ()
588 let (macro_name, definition) = break isSpace s
589 cmds <- io (readIORef commands)
591 then throwDyn (CmdLineError "invalid macro name")
593 if (macro_name `elem` map fst cmds)
594 then throwDyn (CmdLineError
595 ("command '" ++ macro_name ++ "' is already defined"))
598 -- give the expression a type signature, so we can be sure we're getting
599 -- something of the right type.
600 let new_expr = '(' : definition ++ ") :: String -> IO String"
602 -- compile the expression
604 maybe_hv <- io (GHC.compileExpr cms new_expr)
607 Just hv -> io (writeIORef commands --
608 ((macro_name, keepGoing (runMacro hv)) : cmds))
610 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi ()
612 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
613 stringLoop (lines str)
615 undefineMacro :: String -> GHCi ()
616 undefineMacro macro_name = do
617 cmds <- io (readIORef commands)
618 if (macro_name `elem` map fst builtin_commands)
619 then throwDyn (CmdLineError
620 ("command '" ++ macro_name ++ "' cannot be undefined"))
622 if (macro_name `notElem` map fst cmds)
623 then throwDyn (CmdLineError
624 ("command '" ++ macro_name ++ "' not defined"))
626 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
629 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
630 loadModule fs = timeIt (loadModule' fs)
632 loadModule_ :: [FilePath] -> GHCi ()
633 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
635 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
636 loadModule' files = do
637 session <- getSession
640 io (GHC.setTargets session [])
641 io (GHC.load session LoadAllTargets)
644 let (filenames, phases) = unzip files
645 exp_filenames <- mapM expandPath filenames
646 let files' = zip exp_filenames phases
647 targets <- io (mapM (uncurry GHC.guessTarget) files')
649 -- NOTE: we used to do the dependency anal first, so that if it
650 -- fails we didn't throw away the current set of modules. This would
651 -- require some re-working of the GHC interface, so we'll leave it
652 -- as a ToDo for now.
654 io (GHC.setTargets session targets)
655 ok <- io (GHC.load session LoadAllTargets)
659 checkModule :: String -> GHCi ()
661 let modl = mkModule m
662 session <- getSession
663 result <- io (GHC.checkModule session modl printErrorsAndWarnings)
665 Nothing -> io $ putStrLn "Nothing"
666 Just r -> io $ putStrLn (showSDoc (
667 case checkedModuleInfo r of
668 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
670 (local,global) = partition ((== modl) . GHC.nameModule) scope
672 (text "global names: " <+> ppr global) $$
673 (text "local names: " <+> ppr local)
675 afterLoad (successIf (isJust result)) session
677 reloadModule :: String -> GHCi ()
679 io (revertCAFs) -- always revert CAFs on reload.
680 session <- getSession
681 ok <- io (GHC.load session LoadAllTargets)
684 io (revertCAFs) -- always revert CAFs on reload.
685 session <- getSession
686 ok <- io (GHC.load session (LoadUpTo (mkModule m)))
689 afterLoad ok session = do
690 io (revertCAFs) -- always revert CAFs on load.
691 graph <- io (GHC.getModuleGraph session)
692 let mods = map GHC.ms_mod graph
693 mods' <- filterM (io . GHC.isLoaded session) mods
694 setContextAfterLoad mods'
695 modulesLoadedMsg ok mods'
697 setContextAfterLoad [] = do
698 session <- getSession
699 io (GHC.setContext session [] [prelude_mod])
700 setContextAfterLoad (m:_) = do
701 session <- getSession
702 b <- io (GHC.moduleIsInterpreted session m)
703 if b then io (GHC.setContext session [m] [])
704 else io (GHC.setContext session [] [prelude_mod,m])
706 modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi ()
707 modulesLoadedMsg ok mods = do
708 dflags <- getDynFlags
709 when (verbosity dflags > 0) $ do
711 | null mods = text "none."
713 punctuate comma (map pprModule mods)) <> text "."
716 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
718 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
721 typeOfExpr :: String -> GHCi ()
723 = do cms <- getSession
724 maybe_ty <- io (GHC.exprType cms str)
727 Just ty -> do ty' <- cleanType ty
728 tystr <- showForUser (ppr ty')
729 io (putStrLn (str ++ " :: " ++ tystr))
731 kindOfType :: String -> GHCi ()
733 = do cms <- getSession
734 maybe_ty <- io (GHC.typeKind cms str)
737 Just ty -> do tystr <- showForUser (ppr ty)
738 io (putStrLn (str ++ " :: " ++ tystr))
740 quit :: String -> GHCi Bool
743 shellEscape :: String -> GHCi Bool
744 shellEscape str = io (system str >> return False)
746 -----------------------------------------------------------------------------
747 -- create tags file for currently loaded modules.
749 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
751 createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
752 createCTagsFileCmd file = ghciCreateTagsFile CTags file
754 createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
755 createETagsFileCmd file = ghciCreateTagsFile ETags file
757 data TagsKind = ETags | CTags
759 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
760 ghciCreateTagsFile kind file = do
761 session <- getSession
762 io $ createTagsFile session kind file
765 -- - remove restriction that all modules must be interpreted
766 -- (problem: we don't know source locations for entities unless
767 -- we compiled the module.
769 -- - extract createTagsFile so it can be used from the command-line
770 -- (probably need to fix first problem before this is useful).
772 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
773 createTagsFile session tagskind tagFile = do
774 graph <- GHC.getModuleGraph session
775 let ms = map GHC.ms_mod graph
777 is_interpreted <- GHC.moduleIsInterpreted session m
778 -- should we just skip these?
779 when (not is_interpreted) $
780 throwDyn (CmdLineError ("module '" ++ moduleUserString m ++ "' is not interpreted"))
782 mbModInfo <- GHC.getModuleInfo session m
784 | Just modinfo <- mbModInfo,
785 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
786 | otherwise = GHC.alwaysQualify
789 Just modInfo -> return $! listTags unqual modInfo
792 mtags <- mapM tagModule ms
793 either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
795 Left e -> hPutStrLn stderr $ ioeGetErrorString e
798 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
799 listTags unqual modInfo =
800 [ tagInfo unqual name loc
801 | name <- GHC.modInfoExports modInfo
802 , let loc = nameSrcLoc name
806 type TagInfo = (String -- tag name
809 ,Int -- column number
812 -- get tag info, for later translation into Vim or Emacs style
813 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
814 tagInfo unqual name loc
815 = ( showSDocForUser unqual $ pprOccName (nameOccName name)
816 , showSDocForUser unqual $ ftext (srcLocFile loc)
821 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
822 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
823 let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
824 IO.try (writeFile file tags)
825 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
826 let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
827 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
828 tagGroups <- mapM tagFileGroup groups
829 IO.try (writeFile file $ concat tagGroups)
831 tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
832 tagFileGroup group@((_,fileName,_,_):_) = do
833 file <- readFile fileName -- need to get additional info from sources..
834 let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
835 sortedGroup = sortLe byLine group
836 tags = unlines $ perFile sortedGroup 1 0 $ lines file
837 return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
838 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
839 perFile (tagInfo:tags) (count+1) (pos+length line) lines
840 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
841 showETag tagInfo line pos : perFile tags count pos lines
842 perFile tags count pos lines = []
844 -- simple ctags format, for Vim et al
845 showTag :: TagInfo -> String
846 showTag (tag,file,lineNo,colNo)
847 = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
849 -- etags format, for Emacs/XEmacs
850 showETag :: TagInfo -> String -> Int -> String
851 showETag (tag,file,lineNo,colNo) line charPos
852 = take colNo line ++ tag
854 ++ "\x01" ++ show lineNo
855 ++ "," ++ show charPos
857 -----------------------------------------------------------------------------
858 -- Browsing a module's contents
860 browseCmd :: String -> GHCi ()
863 ['*':m] | looksLikeModuleName m -> browseModule m False
864 [m] | looksLikeModuleName m -> browseModule m True
865 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
867 browseModule m exports_only = do
870 let modl = mkModule m
871 is_interpreted <- io (GHC.moduleIsInterpreted s modl)
872 when (not is_interpreted && not exports_only) $
873 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
875 -- Temporarily set the context to the module we're interested in,
876 -- just so we can get an appropriate PrintUnqualified
877 (as,bs) <- io (GHC.getContext s)
878 io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
879 else GHC.setContext s [modl] [])
880 unqual <- io (GHC.getPrintUnqual s)
881 io (GHC.setContext s as bs)
883 mb_mod_info <- io $ GHC.getModuleInfo s modl
885 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
888 | exports_only = GHC.modInfoExports mod_info
889 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
891 filtered = filterOutChildren names
893 things <- io $ mapM (GHC.lookupName s) filtered
895 dflags <- getDynFlags
896 let exts = dopt Opt_GlasgowExts dflags
897 io (putStrLn (showSDocForUser unqual (
898 vcat (map (pprTyThingInContext exts) (catMaybes things))
900 -- ToDo: modInfoInstances currently throws an exception for
901 -- package modules. When it works, we can do this:
902 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
904 -----------------------------------------------------------------------------
905 -- Setting the module context
908 | all sensible mods = fn mods
909 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
911 (fn, mods) = case str of
912 '+':stuff -> (addToContext, words stuff)
913 '-':stuff -> (removeFromContext, words stuff)
914 stuff -> (newContext, words stuff)
916 sensible ('*':m) = looksLikeModuleName m
917 sensible m = looksLikeModuleName m
920 session <- getSession
921 (as,bs) <- separate session mods [] []
922 let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs
923 io (GHC.setContext session as bs')
925 separate :: Session -> [String] -> [Module] -> [Module]
926 -> GHCi ([Module],[Module])
927 separate session [] as bs = return (as,bs)
928 separate session (('*':m):ms) as bs = do
929 let modl = mkModule m
930 b <- io (GHC.moduleIsInterpreted session modl)
931 if b then separate session ms (modl:as) bs
932 else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
933 separate session (m:ms) as bs = separate session ms as (mkModule m:bs)
935 prelude_mod = mkModule "Prelude"
938 addToContext mods = do
940 (as,bs) <- io (GHC.getContext cms)
942 (as',bs') <- separate cms mods [] []
944 let as_to_add = as' \\ (as ++ bs)
945 bs_to_add = bs' \\ (as ++ bs)
947 io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add))
950 removeFromContext mods = do
952 (as,bs) <- io (GHC.getContext cms)
954 (as_to_remove,bs_to_remove) <- separate cms mods [] []
956 let as' = as \\ (as_to_remove ++ bs_to_remove)
957 bs' = bs \\ (as_to_remove ++ bs_to_remove)
959 io (GHC.setContext cms as' bs')
961 ----------------------------------------------------------------------------
964 -- set options in the interpreter. Syntax is exactly the same as the
965 -- ghc command line, except that certain options aren't available (-C,
968 -- This is pretty fragile: most options won't work as expected. ToDo:
969 -- figure out which ones & disallow them.
971 setCmd :: String -> GHCi ()
973 = do st <- getGHCiState
974 let opts = options st
975 io $ putStrLn (showSDoc (
976 text "options currently set: " <>
979 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
983 ("args":args) -> setArgs args
984 ("prog":prog) -> setProg prog
985 wds -> setOptions wds
989 setGHCiState st{ args = args }
993 setGHCiState st{ progname = prog }
995 io (hPutStrLn stderr "syntax: :set prog <progname>")
998 do -- first, deal with the GHCi opts (+s, +t, etc.)
999 let (plus_opts, minus_opts) = partition isPlus wds
1000 mapM_ setOpt plus_opts
1002 -- then, dynamic flags
1003 dflags <- getDynFlags
1004 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1007 -- update things if the users wants more packages
1009 let new_packages = pkgs_after \\ pkgs_before
1010 when (not (null new_packages)) $
1011 newPackages new_packages
1014 if (not (null leftovers))
1015 then throwDyn (CmdLineError ("unrecognised flags: " ++
1020 unsetOptions :: String -> GHCi ()
1022 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1023 let opts = words str
1024 (minus_opts, rest1) = partition isMinus opts
1025 (plus_opts, rest2) = partition isPlus rest1
1027 if (not (null rest2))
1028 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1031 mapM_ unsetOpt plus_opts
1033 -- can't do GHC flags for now
1034 if (not (null minus_opts))
1035 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1038 isMinus ('-':s) = True
1041 isPlus ('+':s) = True
1045 = case strToGHCiOpt str of
1046 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1047 Just o -> setOption o
1050 = case strToGHCiOpt str of
1051 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1052 Just o -> unsetOption o
1054 strToGHCiOpt :: String -> (Maybe GHCiOption)
1055 strToGHCiOpt "s" = Just ShowTiming
1056 strToGHCiOpt "t" = Just ShowType
1057 strToGHCiOpt "r" = Just RevertCAFs
1058 strToGHCiOpt _ = Nothing
1060 optToStr :: GHCiOption -> String
1061 optToStr ShowTiming = "s"
1062 optToStr ShowType = "t"
1063 optToStr RevertCAFs = "r"
1066 newPackages new_pkgs = do -- The new packages are already in v_Packages
1067 session <- getSession
1068 io (GHC.setTargets session [])
1069 io (GHC.load session Nothing)
1070 dflags <- getDynFlags
1071 io (linkPackages dflags new_pkgs)
1072 setContextAfterLoad []
1075 -- ---------------------------------------------------------------------------
1080 ["modules" ] -> showModules
1081 ["bindings"] -> showBindings
1082 ["linker"] -> io showLinkerState
1083 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1086 session <- getSession
1087 let show_one ms = do m <- io (GHC.showModule session ms)
1089 graph <- io (GHC.getModuleGraph session)
1090 mapM_ show_one graph
1094 unqual <- io (GHC.getPrintUnqual s)
1095 bindings <- io (GHC.getBindings s)
1096 mapM_ showTyThing bindings
1099 showTyThing (AnId id) = do
1100 ty' <- cleanType (GHC.idType id)
1101 str <- showForUser (ppr id <> text " :: " <> ppr ty')
1103 showTyThing _ = return ()
1105 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1106 cleanType :: Type -> GHCi Type
1108 dflags <- getDynFlags
1109 if dopt Opt_GlasgowExts dflags
1111 else return $! GHC.dropForAlls ty
1113 -----------------------------------------------------------------------------
1116 data GHCiState = GHCiState
1120 session :: GHC.Session,
1121 options :: [GHCiOption]
1125 = ShowTiming -- show time/allocs after evaluation
1126 | ShowType -- show the type of expressions
1127 | RevertCAFs -- revert CAFs after every evaluation
1130 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1132 startGHCi :: GHCi a -> GHCiState -> IO a
1133 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1135 instance Monad GHCi where
1136 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1137 return a = GHCi $ \s -> return a
1139 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1140 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1141 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1143 getGHCiState = GHCi $ \r -> readIORef r
1144 setGHCiState s = GHCi $ \r -> writeIORef r s
1146 -- for convenience...
1147 getSession = getGHCiState >>= return . session
1151 io (GHC.getSessionDynFlags s)
1152 setDynFlags dflags = do
1154 io (GHC.setSessionDynFlags s dflags)
1156 isOptionSet :: GHCiOption -> GHCi Bool
1158 = do st <- getGHCiState
1159 return (opt `elem` options st)
1161 setOption :: GHCiOption -> GHCi ()
1163 = do st <- getGHCiState
1164 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1166 unsetOption :: GHCiOption -> GHCi ()
1168 = do st <- getGHCiState
1169 setGHCiState (st{ options = filter (/= opt) (options st) })
1171 io :: IO a -> GHCi a
1172 io m = GHCi { unGHCi = \s -> m >>= return }
1174 -----------------------------------------------------------------------------
1175 -- recursive exception handlers
1177 -- Don't forget to unblock async exceptions in the handler, or if we're
1178 -- in an exception loop (eg. let a = error a in a) the ^C exception
1179 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1181 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1182 ghciHandle h (GHCi m) = GHCi $ \s ->
1183 Exception.catch (m s)
1184 (\e -> unGHCi (ghciUnblock (h e)) s)
1186 ghciUnblock :: GHCi a -> GHCi a
1187 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1189 -----------------------------------------------------------------------------
1190 -- timing & statistics
1192 timeIt :: GHCi a -> GHCi a
1194 = do b <- isOptionSet ShowTiming
1197 else do allocs1 <- io $ getAllocations
1198 time1 <- io $ getCPUTime
1200 allocs2 <- io $ getAllocations
1201 time2 <- io $ getCPUTime
1202 io $ printTimes (fromIntegral (allocs2 - allocs1))
1206 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1207 -- defined in ghc/rts/Stats.c
1209 printTimes :: Integer -> Integer -> IO ()
1210 printTimes allocs psecs
1211 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1212 secs_str = showFFloat (Just 2) secs
1213 putStrLn (showSDoc (
1214 parens (text (secs_str "") <+> text "secs" <> comma <+>
1215 text (show allocs) <+> text "bytes")))
1217 -----------------------------------------------------------------------------
1224 -- Have to turn off buffering again, because we just
1225 -- reverted stdout, stderr & stdin to their defaults.
1227 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1228 -- Make it "safe", just in case
1230 -- -----------------------------------------------------------------------------
1233 expandPath :: String -> GHCi String
1235 case dropWhile isSpace path of
1237 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1238 return (tilde ++ '/':d)