1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005
8 -----------------------------------------------------------------------------
14 #include "HsVersions.h"
18 import GHC ( Session, verbosity, dopt, DynFlag(..), Target(..),
20 mkModule, pprModule, Type, Module, SuccessFlag(..),
21 TyThing(..), Name, LoadHowMuch(..), Phase,
22 GhcException(..), showGhcException,
23 CheckedModule(..), SrcLoc )
27 -- for createtags (should these come via GHC?)
28 import Module ( moduleString )
29 import Name ( nameSrcLoc, nameModule, nameOccName )
30 import OccName ( pprOccName )
31 import SrcLoc ( isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol )
33 -- Other random utilities
34 import Digraph ( flattenSCCs )
35 import BasicTypes ( failed, successIf )
36 import Panic ( panic, installSignalHandlers )
38 import StaticFlags ( opt_IgnoreDotGhci )
39 import Linker ( showLinkerState )
40 import Util ( removeSpaces, handle, global, toArgs,
41 looksLikeModuleName, prefixMatch, sortLe )
43 #ifndef mingw32_HOST_OS
45 #if __GLASGOW_HASKELL__ > 504
49 import GHC.ConsoleHandler ( flushConsole )
53 import Control.Concurrent ( yield ) -- Used in readline loop
54 import System.Console.Readline as Readline
59 import Control.Exception as Exception
61 -- import Control.Concurrent
65 import Data.Int ( Int64 )
66 import Data.Maybe ( isJust, fromMaybe, catMaybes )
69 import System.Environment
70 import System.Exit ( exitWith, ExitCode(..) )
71 import System.Directory
73 import System.IO.Error as IO
75 import Control.Monad as Monad
76 import Foreign.StablePtr ( newStablePtr )
78 import GHC.Exts ( unsafeCoerce# )
79 import GHC.IOBase ( IOErrorType(InvalidArgument) )
81 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
83 import System.Posix.Internals ( setNonBlockingFD )
85 -----------------------------------------------------------------------------
89 " / _ \\ /\\ /\\/ __(_)\n"++
90 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
91 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
92 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
94 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
96 builtin_commands :: [(String, String -> GHCi Bool)]
98 ("add", keepGoingPaths addModule),
99 ("browse", keepGoing browseCmd),
100 ("cd", keepGoing changeDirectory),
101 ("def", keepGoing defineMacro),
102 ("help", keepGoing help),
103 ("?", keepGoing help),
104 ("info", keepGoing info),
105 ("load", keepGoingPaths loadModule_),
106 ("module", keepGoing setContext),
107 ("main", keepGoing runMain),
108 ("reload", keepGoing reloadModule),
109 ("check", keepGoing checkModule),
110 ("set", keepGoing setCmd),
111 ("show", keepGoing showCmd),
112 ("etags", keepGoing createETagsFileCmd),
113 ("ctags", keepGoing createCTagsFileCmd),
114 ("type", keepGoing typeOfExpr),
115 ("kind", keepGoing kindOfType),
116 ("unset", keepGoing unsetOptions),
117 ("undef", keepGoing undefineMacro),
121 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
122 keepGoing a str = a str >> return False
124 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
125 keepGoingPaths a str = a (toArgs str) >> return False
127 shortHelpText = "use :? for help.\n"
129 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
131 " Commands available from the prompt:\n" ++
133 " <stmt> evaluate/run <stmt>\n" ++
134 " :add <filename> ... add module(s) to the current target set\n" ++
135 " :browse [*]<module> display the names defined by <module>\n" ++
136 " :cd <dir> change directory to <dir>\n" ++
137 " :def <cmd> <expr> define a command :<cmd>\n" ++
138 " :help, :? display this list of commands\n" ++
139 " :info [<name> ...] display information about the given names\n" ++
140 " :load <filename> ... load module(s) and their dependents\n" ++
141 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
142 " :main [<arguments> ...] run the main function with the given arguments\n" ++
143 " :reload reload the current module set\n" ++
145 " :set <option> ... set options\n" ++
146 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
147 " :set prog <progname> set the value returned by System.getProgName\n" ++
149 " :show modules show the currently loaded modules\n" ++
150 " :show bindings show the current bindings made at the prompt\n" ++
152 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
153 " :etags [<file>] create tags file for Emacs (defauilt: \"TAGS\")\n" ++
154 " :type <expr> show the type of <expr>\n" ++
155 " :kind <type> show the kind of <type>\n" ++
156 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
157 " :unset <option> ... unset options\n" ++
158 " :quit exit GHCi\n" ++
159 " :!<command> run the shell command <command>\n" ++
161 " Options for ':set' and ':unset':\n" ++
163 " +r revert top-level expressions after each evaluation\n" ++
164 " +s print timing/memory stats after each evaluation\n" ++
165 " +t print type after evaluation\n" ++
166 " -<flags> most GHC command line flags can also be set here\n" ++
167 " (eg. -v2, -fglasgow-exts, etc.)\n"
170 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
171 interactiveUI session srcs maybe_expr = do
173 -- HACK! If we happen to get into an infinite loop (eg the user
174 -- types 'let x=x in x' at the prompt), then the thread will block
175 -- on a blackhole, and become unreachable during GC. The GC will
176 -- detect that it is unreachable and send it the NonTermination
177 -- exception. However, since the thread is unreachable, everything
178 -- it refers to might be finalized, including the standard Handles.
179 -- This sounds like a bug, but we don't have a good solution right
186 hSetBuffering stdout NoBuffering
188 -- Initialise buffering for the *interpreted* I/O system
189 initInterpBuffering session
191 -- We don't want the cmd line to buffer any input that might be
192 -- intended for the program, so unbuffer stdin.
193 hSetBuffering stdin NoBuffering
195 -- initial context is just the Prelude
196 GHC.setContext session [] [prelude_mod]
202 startGHCi (runGHCi srcs maybe_expr)
203 GHCiState{ progname = "<interactive>",
209 Readline.resetTerminal Nothing
214 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
215 runGHCi paths maybe_expr = do
216 let read_dot_files = not opt_IgnoreDotGhci
218 when (read_dot_files) $ do
221 exists <- io (doesFileExist file)
223 dir_ok <- io (checkPerms ".")
224 file_ok <- io (checkPerms file)
225 when (dir_ok && file_ok) $ do
226 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
229 Right hdl -> fileLoop hdl False
231 when (read_dot_files) $ do
232 -- Read in $HOME/.ghci
233 either_dir <- io (IO.try (getEnv "HOME"))
237 cwd <- io (getCurrentDirectory)
238 when (dir /= cwd) $ do
239 let file = dir ++ "/.ghci"
240 ok <- io (checkPerms file)
242 either_hdl <- io (IO.try (openFile file ReadMode))
245 Right hdl -> fileLoop hdl False
247 -- Perform a :load for files given on the GHCi command line
248 -- When in -e mode, if the load fails then we want to stop
249 -- immediately rather than going on to evaluate the expression.
250 when (not (null paths)) $ do
251 ok <- ghciHandle (\e -> do showException e; return Failed) $
253 when (isJust maybe_expr && failed ok) $
254 io (exitWith (ExitFailure 1))
256 -- if verbosity is greater than 0, or we are connected to a
257 -- terminal, display the prompt in the interactive loop.
258 is_tty <- io (hIsTerminalDevice stdin)
259 dflags <- getDynFlags
260 let show_prompt = verbosity dflags > 0 || is_tty
264 #if defined(mingw32_HOST_OS)
266 -- The win32 Console API mutates the first character of
267 -- type-ahead when reading from it in a non-buffered manner. Work
268 -- around this by flushing the input buffer of type-ahead characters,
269 -- but only if stdin is available.
270 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
272 Left err | isDoesNotExistError err -> return ()
273 | otherwise -> io (ioError err)
274 Right () -> return ()
276 -- enter the interactive loop
277 interactiveLoop is_tty show_prompt
279 -- just evaluate the expression we were given
284 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
287 interactiveLoop is_tty show_prompt =
288 -- Ignore ^C exceptions caught here
289 ghciHandleDyn (\e -> case e of
291 #if defined(mingw32_HOST_OS)
294 interactiveLoop is_tty show_prompt
295 _other -> return ()) $
297 ghciUnblock $ do -- unblock necessary if we recursed from the
298 -- exception handler above.
300 -- read commands from stdin
304 else fileLoop stdin show_prompt
306 fileLoop stdin show_prompt
310 -- NOTE: We only read .ghci files if they are owned by the current user,
311 -- and aren't world writable. Otherwise, we could be accidentally
312 -- running code planted by a malicious third party.
314 -- Furthermore, We only read ./.ghci if . is owned by the current user
315 -- and isn't writable by anyone else. I think this is sufficient: we
316 -- don't need to check .. and ../.. etc. because "." always refers to
317 -- the same directory while a process is running.
319 checkPerms :: String -> IO Bool
321 #ifdef mingw32_HOST_OS
324 Util.handle (\_ -> return False) $ do
325 st <- getFileStatus name
327 if fileOwner st /= me then do
328 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
331 let mode = fileMode st
332 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
333 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
335 putStrLn $ "*** WARNING: " ++ name ++
336 " is writable by someone else, IGNORING!"
341 fileLoop :: Handle -> Bool -> GHCi ()
342 fileLoop hdl prompt = do
343 session <- getSession
344 (mod,imports) <- io (GHC.getContext session)
345 when prompt (io (putStr (mkPrompt mod imports)))
346 l <- io (IO.try (hGetLine hdl))
348 Left e | isEOFError e -> return ()
349 | InvalidArgument <- etype -> return ()
350 | otherwise -> io (ioError e)
351 where etype = ioeGetErrorType e
352 -- treat InvalidArgument in the same way as EOF:
353 -- this can happen if the user closed stdin, or
354 -- perhaps did getContents which closes stdin at
357 case removeSpaces l of
358 "" -> fileLoop hdl prompt
359 l -> do quit <- runCommand l
360 if quit then return () else fileLoop hdl prompt
362 stringLoop :: [String] -> GHCi ()
363 stringLoop [] = return ()
364 stringLoop (s:ss) = do
365 case removeSpaces s of
367 l -> do quit <- runCommand l
368 if quit then return () else stringLoop ss
370 mkPrompt toplevs exports
371 = showSDoc (hsep (map (\m -> char '*' <> pprModule m) toplevs)
372 <+> hsep (map pprModule exports)
376 readlineLoop :: GHCi ()
378 session <- getSession
379 (mod,imports) <- io (GHC.getContext session)
381 l <- io (readline (mkPrompt mod imports)
382 `finally` setNonBlockingFD 0)
383 -- readline sometimes puts stdin into blocking mode,
384 -- so we need to put it back for the IO library
388 case removeSpaces l of
393 if quit then return () else readlineLoop
396 runCommand :: String -> GHCi Bool
397 runCommand c = ghciHandle handler (doCommand c)
399 doCommand (':' : command) = specialCommand command
401 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
404 -- This version is for the GHC command-line option -e. The only difference
405 -- from runCommand is that it catches the ExitException exception and
406 -- exits, rather than printing out the exception.
407 runCommandEval c = ghciHandle handleEval (doCommand c)
409 handleEval (ExitException code) = io (exitWith code)
410 handleEval e = do showException e
411 io (exitWith (ExitFailure 1))
413 doCommand (':' : command) = specialCommand command
415 = do nms <- runStmt stmt
417 Nothing -> io (exitWith (ExitFailure 1))
418 -- failure to run the command causes exit(1) for ghc -e.
419 _ -> finishEvalExpr nms
421 -- This is the exception handler for exceptions generated by the
422 -- user's code; it normally just prints out the exception. The
423 -- handler must be recursive, in case showing the exception causes
424 -- more exceptions to be raised.
426 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
427 -- raising another exception. We therefore don't put the recursive
428 -- handler arond the flushing operation, so if stderr is closed
429 -- GHCi will just die gracefully rather than going into an infinite loop.
430 handler :: Exception -> GHCi Bool
431 handler exception = do
433 io installSignalHandlers
434 ghciHandle handler (showException exception >> return False)
436 showException (DynException dyn) =
437 case fromDynamic dyn of
438 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
439 Just Interrupted -> io (putStrLn "Interrupted.")
440 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
441 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
442 Just other_ghc_ex -> io (print other_ghc_ex)
444 showException other_exception
445 = io (putStrLn ("*** Exception: " ++ show other_exception))
447 runStmt :: String -> GHCi (Maybe [Name])
449 | null (filter (not.isSpace) stmt) = return (Just [])
451 = do st <- getGHCiState
452 session <- getSession
453 result <- io $ withProgName (progname st) $ withArgs (args st) $
454 GHC.runStmt session stmt
456 GHC.RunFailed -> return Nothing
457 GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
458 GHC.RunOk names -> return (Just names)
460 -- possibly print the type and revert CAFs after evaluating an expression
461 finishEvalExpr mb_names
462 = do b <- isOptionSet ShowType
463 session <- getSession
466 Just names -> when b (mapM_ (showTypeOfName session) names)
469 io installSignalHandlers
470 b <- isOptionSet RevertCAFs
471 io (when b revertCAFs)
474 showTypeOfName :: Session -> Name -> GHCi ()
475 showTypeOfName session n
476 = do maybe_tything <- io (GHC.lookupName session n)
477 case maybe_tything of
479 Just thing -> showTyThing thing
481 showForUser :: SDoc -> GHCi String
483 session <- getSession
484 unqual <- io (GHC.getPrintUnqual session)
485 return $! showSDocForUser unqual doc
487 specialCommand :: String -> GHCi Bool
488 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
489 specialCommand str = do
490 let (cmd,rest) = break isSpace str
491 cmds <- io (readIORef commands)
492 -- look for exact match first, then the first prefix match
493 case [ (s,f) | (s,f) <- cmds, cmd == s ] of
494 (_,f):_ -> f (dropWhile isSpace rest)
495 [] -> case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
496 [] -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
497 ++ shortHelpText) >> return False)
498 (_,f):_ -> f (dropWhile isSpace rest)
500 -----------------------------------------------------------------------------
501 -- To flush buffers for the *interpreted* computation we need
502 -- to refer to *its* stdout/stderr handles
504 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
505 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
507 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
508 " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
509 flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
511 initInterpBuffering :: Session -> IO ()
512 initInterpBuffering session
513 = do maybe_hval <- GHC.compileExpr session no_buf_cmd
516 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
517 other -> panic "interactiveUI:setBuffering"
519 maybe_hval <- GHC.compileExpr session flush_cmd
521 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
522 _ -> panic "interactiveUI:flush"
524 turnOffBuffering -- Turn it off right now
529 flushInterpBuffers :: GHCi ()
531 = io $ do Monad.join (readIORef flush_interp)
534 turnOffBuffering :: IO ()
536 = do Monad.join (readIORef turn_off_buffering)
539 -----------------------------------------------------------------------------
542 help :: String -> GHCi ()
543 help _ = io (putStr helpText)
545 info :: String -> GHCi ()
546 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
547 info s = do { let names = words s
548 ; session <- getSession
549 ; dflags <- getDynFlags
550 ; let exts = dopt Opt_GlasgowExts dflags
551 ; mapM_ (infoThing exts session) names }
553 infoThing exts session str = io $ do
554 names <- GHC.parseName session str
555 let filtered = filterOutChildren names
556 mb_stuffs <- mapM (GHC.getInfo session) filtered
557 unqual <- GHC.getPrintUnqual session
558 putStrLn (showSDocForUser unqual $
559 vcat (intersperse (text "") $
560 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
562 -- Filter out names whose parent is also there Good
563 -- example is '[]', which is both a type and data
564 -- constructor in the same type
565 filterOutChildren :: [Name] -> [Name]
566 filterOutChildren names = filter (not . parent_is_there) names
567 where parent_is_there n
568 | Just p <- GHC.nameParent_maybe n = p `elem` names
571 pprInfo exts (thing, fixity, insts)
572 = pprTyThingInContextLoc exts thing
573 $$ show_fixity fixity
574 $$ vcat (map GHC.pprInstance insts)
577 | fix == GHC.defaultFixity = empty
578 | otherwise = ppr fix <+> ppr (GHC.getName thing)
580 -----------------------------------------------------------------------------
583 runMain :: String -> GHCi ()
585 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
586 runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
589 addModule :: [FilePath] -> GHCi ()
591 io (revertCAFs) -- always revert CAFs on load/add.
592 files <- mapM expandPath files
593 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
594 session <- getSession
595 io (mapM_ (GHC.addTarget session) targets)
596 ok <- io (GHC.load session LoadAllTargets)
599 changeDirectory :: String -> GHCi ()
600 changeDirectory dir = do
601 session <- getSession
602 graph <- io (GHC.getModuleGraph session)
603 when (not (null graph)) $
604 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
605 io (GHC.setTargets session [])
606 io (GHC.load session LoadAllTargets)
607 setContextAfterLoad session []
608 io (GHC.workingDirectoryChanged session)
609 dir <- expandPath dir
610 io (setCurrentDirectory dir)
612 defineMacro :: String -> GHCi ()
614 let (macro_name, definition) = break isSpace s
615 cmds <- io (readIORef commands)
617 then throwDyn (CmdLineError "invalid macro name")
619 if (macro_name `elem` map fst cmds)
620 then throwDyn (CmdLineError
621 ("command '" ++ macro_name ++ "' is already defined"))
624 -- give the expression a type signature, so we can be sure we're getting
625 -- something of the right type.
626 let new_expr = '(' : definition ++ ") :: String -> IO String"
628 -- compile the expression
630 maybe_hv <- io (GHC.compileExpr cms new_expr)
633 Just hv -> io (writeIORef commands --
634 (cmds ++ [(macro_name, keepGoing (runMacro hv))]))
636 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi ()
638 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
639 stringLoop (lines str)
641 undefineMacro :: String -> GHCi ()
642 undefineMacro macro_name = do
643 cmds <- io (readIORef commands)
644 if (macro_name `elem` map fst builtin_commands)
645 then throwDyn (CmdLineError
646 ("command '" ++ macro_name ++ "' cannot be undefined"))
648 if (macro_name `notElem` map fst cmds)
649 then throwDyn (CmdLineError
650 ("command '" ++ macro_name ++ "' not defined"))
652 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
655 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
656 loadModule fs = timeIt (loadModule' fs)
658 loadModule_ :: [FilePath] -> GHCi ()
659 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
661 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
662 loadModule' files = do
663 session <- getSession
666 io (GHC.setTargets session [])
667 io (GHC.load session LoadAllTargets)
670 let (filenames, phases) = unzip files
671 exp_filenames <- mapM expandPath filenames
672 let files' = zip exp_filenames phases
673 targets <- io (mapM (uncurry GHC.guessTarget) files')
675 -- NOTE: we used to do the dependency anal first, so that if it
676 -- fails we didn't throw away the current set of modules. This would
677 -- require some re-working of the GHC interface, so we'll leave it
678 -- as a ToDo for now.
680 io (GHC.setTargets session targets)
681 ok <- io (GHC.load session LoadAllTargets)
685 checkModule :: String -> GHCi ()
687 let modl = mkModule m
688 session <- getSession
689 result <- io (GHC.checkModule session modl)
691 Nothing -> io $ putStrLn "Nothing"
692 Just r -> io $ putStrLn (showSDoc (
693 case checkedModuleInfo r of
694 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
696 (local,global) = partition ((== modl) . GHC.nameModule) scope
698 (text "global names: " <+> ppr global) $$
699 (text "local names: " <+> ppr local)
701 afterLoad (successIf (isJust result)) session
703 reloadModule :: String -> GHCi ()
705 io (revertCAFs) -- always revert CAFs on reload.
706 session <- getSession
707 ok <- io (GHC.load session LoadAllTargets)
710 io (revertCAFs) -- always revert CAFs on reload.
711 session <- getSession
712 ok <- io (GHC.load session (LoadUpTo (mkModule m)))
715 afterLoad ok session = do
716 io (revertCAFs) -- always revert CAFs on load.
717 graph <- io (GHC.getModuleGraph session)
718 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod) graph
719 setContextAfterLoad session graph'
720 modulesLoadedMsg ok (map GHC.ms_mod graph')
722 setContextAfterLoad session [] = do
723 io (GHC.setContext session [] [prelude_mod])
724 setContextAfterLoad session ms = do
725 -- load a target if one is available, otherwise load the topmost module.
726 targets <- io (GHC.getTargets session)
727 case [ m | Just m <- map (findTarget ms) targets ] of
729 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
730 load_this (last graph')
735 = case filter (`matches` t) ms of
739 summary `matches` Target (TargetModule m) _
740 = GHC.ms_mod summary == m
741 summary `matches` Target (TargetFile f _) _
742 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
743 summary `matches` target
746 load_this summary | m <- GHC.ms_mod summary = do
747 b <- io (GHC.moduleIsInterpreted session m)
748 if b then io (GHC.setContext session [m] [])
749 else io (GHC.setContext session [] [prelude_mod,m])
752 modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi ()
753 modulesLoadedMsg ok mods = do
754 dflags <- getDynFlags
755 when (verbosity dflags > 0) $ do
757 | null mods = text "none."
759 punctuate comma (map pprModule mods)) <> text "."
762 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
764 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
767 typeOfExpr :: String -> GHCi ()
769 = do cms <- getSession
770 maybe_ty <- io (GHC.exprType cms str)
773 Just ty -> do ty' <- cleanType ty
774 tystr <- showForUser (ppr ty')
775 io (putStrLn (str ++ " :: " ++ tystr))
777 kindOfType :: String -> GHCi ()
779 = do cms <- getSession
780 maybe_ty <- io (GHC.typeKind cms str)
783 Just ty -> do tystr <- showForUser (ppr ty)
784 io (putStrLn (str ++ " :: " ++ tystr))
786 quit :: String -> GHCi Bool
789 shellEscape :: String -> GHCi Bool
790 shellEscape str = io (system str >> return False)
792 -----------------------------------------------------------------------------
793 -- create tags file for currently loaded modules.
795 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
797 createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
798 createCTagsFileCmd file = ghciCreateTagsFile CTags file
800 createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
801 createETagsFileCmd file = ghciCreateTagsFile ETags file
803 data TagsKind = ETags | CTags
805 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
806 ghciCreateTagsFile kind file = do
807 session <- getSession
808 io $ createTagsFile session kind file
811 -- - remove restriction that all modules must be interpreted
812 -- (problem: we don't know source locations for entities unless
813 -- we compiled the module.
815 -- - extract createTagsFile so it can be used from the command-line
816 -- (probably need to fix first problem before this is useful).
818 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
819 createTagsFile session tagskind tagFile = do
820 graph <- GHC.getModuleGraph session
821 let ms = map GHC.ms_mod graph
823 is_interpreted <- GHC.moduleIsInterpreted session m
824 -- should we just skip these?
825 when (not is_interpreted) $
826 throwDyn (CmdLineError ("module '" ++ moduleString m ++ "' is not interpreted"))
828 mbModInfo <- GHC.getModuleInfo session m
830 | Just modinfo <- mbModInfo,
831 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
832 | otherwise = GHC.alwaysQualify
835 Just modInfo -> return $! listTags unqual modInfo
838 mtags <- mapM tagModule ms
839 either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
841 Left e -> hPutStrLn stderr $ ioeGetErrorString e
844 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
845 listTags unqual modInfo =
846 [ tagInfo unqual name loc
847 | name <- GHC.modInfoExports modInfo
848 , let loc = nameSrcLoc name
852 type TagInfo = (String -- tag name
855 ,Int -- column number
858 -- get tag info, for later translation into Vim or Emacs style
859 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
860 tagInfo unqual name loc
861 = ( showSDocForUser unqual $ pprOccName (nameOccName name)
862 , showSDocForUser unqual $ ftext (srcLocFile loc)
867 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
868 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
869 let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
870 IO.try (writeFile file tags)
871 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
872 let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
873 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
874 tagGroups <- mapM tagFileGroup groups
875 IO.try (writeFile file $ concat tagGroups)
877 tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
878 tagFileGroup group@((_,fileName,_,_):_) = do
879 file <- readFile fileName -- need to get additional info from sources..
880 let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
881 sortedGroup = sortLe byLine group
882 tags = unlines $ perFile sortedGroup 1 0 $ lines file
883 return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
884 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
885 perFile (tagInfo:tags) (count+1) (pos+length line) lines
886 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
887 showETag tagInfo line pos : perFile tags count pos lines
888 perFile tags count pos lines = []
890 -- simple ctags format, for Vim et al
891 showTag :: TagInfo -> String
892 showTag (tag,file,lineNo,colNo)
893 = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
895 -- etags format, for Emacs/XEmacs
896 showETag :: TagInfo -> String -> Int -> String
897 showETag (tag,file,lineNo,colNo) line charPos
898 = take colNo line ++ tag
900 ++ "\x01" ++ show lineNo
901 ++ "," ++ show charPos
903 -----------------------------------------------------------------------------
904 -- Browsing a module's contents
906 browseCmd :: String -> GHCi ()
909 ['*':m] | looksLikeModuleName m -> browseModule m False
910 [m] | looksLikeModuleName m -> browseModule m True
911 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
913 browseModule m exports_only = do
916 let modl = mkModule m
917 is_interpreted <- io (GHC.moduleIsInterpreted s modl)
918 when (not is_interpreted && not exports_only) $
919 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
921 -- Temporarily set the context to the module we're interested in,
922 -- just so we can get an appropriate PrintUnqualified
923 (as,bs) <- io (GHC.getContext s)
924 io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
925 else GHC.setContext s [modl] [])
926 unqual <- io (GHC.getPrintUnqual s)
927 io (GHC.setContext s as bs)
929 mb_mod_info <- io $ GHC.getModuleInfo s modl
931 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
934 | exports_only = GHC.modInfoExports mod_info
935 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
937 filtered = filterOutChildren names
939 things <- io $ mapM (GHC.lookupName s) filtered
941 dflags <- getDynFlags
942 let exts = dopt Opt_GlasgowExts dflags
943 io (putStrLn (showSDocForUser unqual (
944 vcat (map (pprTyThingInContext exts) (catMaybes things))
946 -- ToDo: modInfoInstances currently throws an exception for
947 -- package modules. When it works, we can do this:
948 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
950 -----------------------------------------------------------------------------
951 -- Setting the module context
954 | all sensible mods = fn mods
955 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
957 (fn, mods) = case str of
958 '+':stuff -> (addToContext, words stuff)
959 '-':stuff -> (removeFromContext, words stuff)
960 stuff -> (newContext, words stuff)
962 sensible ('*':m) = looksLikeModuleName m
963 sensible m = looksLikeModuleName m
966 session <- getSession
967 (as,bs) <- separate session mods [] []
968 let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs
969 io (GHC.setContext session as bs')
971 separate :: Session -> [String] -> [Module] -> [Module]
972 -> GHCi ([Module],[Module])
973 separate session [] as bs = return (as,bs)
974 separate session (('*':m):ms) as bs = do
975 let modl = mkModule m
976 b <- io (GHC.moduleIsInterpreted session modl)
977 if b then separate session ms (modl:as) bs
978 else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
979 separate session (m:ms) as bs = separate session ms as (mkModule m:bs)
981 prelude_mod = mkModule "Prelude"
984 addToContext mods = do
986 (as,bs) <- io (GHC.getContext cms)
988 (as',bs') <- separate cms mods [] []
990 let as_to_add = as' \\ (as ++ bs)
991 bs_to_add = bs' \\ (as ++ bs)
993 io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add))
996 removeFromContext mods = do
998 (as,bs) <- io (GHC.getContext cms)
1000 (as_to_remove,bs_to_remove) <- separate cms mods [] []
1002 let as' = as \\ (as_to_remove ++ bs_to_remove)
1003 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1005 io (GHC.setContext cms as' bs')
1007 ----------------------------------------------------------------------------
1010 -- set options in the interpreter. Syntax is exactly the same as the
1011 -- ghc command line, except that certain options aren't available (-C,
1014 -- This is pretty fragile: most options won't work as expected. ToDo:
1015 -- figure out which ones & disallow them.
1017 setCmd :: String -> GHCi ()
1019 = do st <- getGHCiState
1020 let opts = options st
1021 io $ putStrLn (showSDoc (
1022 text "options currently set: " <>
1025 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1029 ("args":args) -> setArgs args
1030 ("prog":prog) -> setProg prog
1031 wds -> setOptions wds
1035 setGHCiState st{ args = args }
1039 setGHCiState st{ progname = prog }
1041 io (hPutStrLn stderr "syntax: :set prog <progname>")
1044 do -- first, deal with the GHCi opts (+s, +t, etc.)
1045 let (plus_opts, minus_opts) = partition isPlus wds
1046 mapM_ setOpt plus_opts
1048 -- then, dynamic flags
1049 dflags <- getDynFlags
1050 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1053 -- update things if the users wants more packages
1055 let new_packages = pkgs_after \\ pkgs_before
1056 when (not (null new_packages)) $
1057 newPackages new_packages
1060 if (not (null leftovers))
1061 then throwDyn (CmdLineError ("unrecognised flags: " ++
1066 unsetOptions :: String -> GHCi ()
1068 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1069 let opts = words str
1070 (minus_opts, rest1) = partition isMinus opts
1071 (plus_opts, rest2) = partition isPlus rest1
1073 if (not (null rest2))
1074 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1077 mapM_ unsetOpt plus_opts
1079 -- can't do GHC flags for now
1080 if (not (null minus_opts))
1081 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1084 isMinus ('-':s) = True
1087 isPlus ('+':s) = True
1091 = case strToGHCiOpt str of
1092 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1093 Just o -> setOption o
1096 = case strToGHCiOpt str of
1097 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1098 Just o -> unsetOption o
1100 strToGHCiOpt :: String -> (Maybe GHCiOption)
1101 strToGHCiOpt "s" = Just ShowTiming
1102 strToGHCiOpt "t" = Just ShowType
1103 strToGHCiOpt "r" = Just RevertCAFs
1104 strToGHCiOpt _ = Nothing
1106 optToStr :: GHCiOption -> String
1107 optToStr ShowTiming = "s"
1108 optToStr ShowType = "t"
1109 optToStr RevertCAFs = "r"
1112 newPackages new_pkgs = do -- The new packages are already in v_Packages
1113 session <- getSession
1114 io (GHC.setTargets session [])
1115 io (GHC.load session Nothing)
1116 dflags <- getDynFlags
1117 io (linkPackages dflags new_pkgs)
1118 setContextAfterLoad []
1121 -- ---------------------------------------------------------------------------
1126 ["modules" ] -> showModules
1127 ["bindings"] -> showBindings
1128 ["linker"] -> io showLinkerState
1129 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1132 session <- getSession
1133 let show_one ms = do m <- io (GHC.showModule session ms)
1135 graph <- io (GHC.getModuleGraph session)
1136 mapM_ show_one graph
1140 unqual <- io (GHC.getPrintUnqual s)
1141 bindings <- io (GHC.getBindings s)
1142 mapM_ showTyThing bindings
1145 showTyThing (AnId id) = do
1146 ty' <- cleanType (GHC.idType id)
1147 str <- showForUser (ppr id <> text " :: " <> ppr ty')
1149 showTyThing _ = return ()
1151 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1152 cleanType :: Type -> GHCi Type
1154 dflags <- getDynFlags
1155 if dopt Opt_GlasgowExts dflags
1157 else return $! GHC.dropForAlls ty
1159 -----------------------------------------------------------------------------
1162 data GHCiState = GHCiState
1166 session :: GHC.Session,
1167 options :: [GHCiOption]
1171 = ShowTiming -- show time/allocs after evaluation
1172 | ShowType -- show the type of expressions
1173 | RevertCAFs -- revert CAFs after every evaluation
1176 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1178 startGHCi :: GHCi a -> GHCiState -> IO a
1179 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1181 instance Monad GHCi where
1182 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1183 return a = GHCi $ \s -> return a
1185 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1186 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1187 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1189 getGHCiState = GHCi $ \r -> readIORef r
1190 setGHCiState s = GHCi $ \r -> writeIORef r s
1192 -- for convenience...
1193 getSession = getGHCiState >>= return . session
1197 io (GHC.getSessionDynFlags s)
1198 setDynFlags dflags = do
1200 io (GHC.setSessionDynFlags s dflags)
1202 isOptionSet :: GHCiOption -> GHCi Bool
1204 = do st <- getGHCiState
1205 return (opt `elem` options st)
1207 setOption :: GHCiOption -> GHCi ()
1209 = do st <- getGHCiState
1210 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1212 unsetOption :: GHCiOption -> GHCi ()
1214 = do st <- getGHCiState
1215 setGHCiState (st{ options = filter (/= opt) (options st) })
1217 io :: IO a -> GHCi a
1218 io m = GHCi { unGHCi = \s -> m >>= return }
1220 -----------------------------------------------------------------------------
1221 -- recursive exception handlers
1223 -- Don't forget to unblock async exceptions in the handler, or if we're
1224 -- in an exception loop (eg. let a = error a in a) the ^C exception
1225 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1227 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1228 ghciHandle h (GHCi m) = GHCi $ \s ->
1229 Exception.catch (m s)
1230 (\e -> unGHCi (ghciUnblock (h e)) s)
1232 ghciUnblock :: GHCi a -> GHCi a
1233 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1235 -----------------------------------------------------------------------------
1236 -- timing & statistics
1238 timeIt :: GHCi a -> GHCi a
1240 = do b <- isOptionSet ShowTiming
1243 else do allocs1 <- io $ getAllocations
1244 time1 <- io $ getCPUTime
1246 allocs2 <- io $ getAllocations
1247 time2 <- io $ getCPUTime
1248 io $ printTimes (fromIntegral (allocs2 - allocs1))
1252 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1253 -- defined in ghc/rts/Stats.c
1255 printTimes :: Integer -> Integer -> IO ()
1256 printTimes allocs psecs
1257 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1258 secs_str = showFFloat (Just 2) secs
1259 putStrLn (showSDoc (
1260 parens (text (secs_str "") <+> text "secs" <> comma <+>
1261 text (show allocs) <+> text "bytes")))
1263 -----------------------------------------------------------------------------
1270 -- Have to turn off buffering again, because we just
1271 -- reverted stdout, stderr & stdin to their defaults.
1273 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1274 -- Make it "safe", just in case
1276 -- -----------------------------------------------------------------------------
1279 expandPath :: String -> GHCi String
1281 case dropWhile isSpace path of
1283 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1284 return (tilde ++ '/':d)