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 ("tags", keepGoing createTagsFileCmd),
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 " :tags -e|-c create tags file for Vi (-c) or Emacs (-e)\n" ++
149 " :type <expr> show the type of <expr>\n" ++
150 " :kind <type> show the kind of <type>\n" ++
151 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
152 " :unset <option> ... unset options\n" ++
153 " :quit exit GHCi\n" ++
154 " :!<command> run the shell command <command>\n" ++
156 " Options for ':set' and ':unset':\n" ++
158 " +r revert top-level expressions after each evaluation\n" ++
159 " +s print timing/memory stats after each evaluation\n" ++
160 " +t print type after evaluation\n" ++
161 " -<flags> most GHC command line flags can also be set here\n" ++
162 " (eg. -v2, -fglasgow-exts, etc.)\n"
165 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
166 interactiveUI session srcs maybe_expr = do
168 -- HACK! If we happen to get into an infinite loop (eg the user
169 -- types 'let x=x in x' at the prompt), then the thread will block
170 -- on a blackhole, and become unreachable during GC. The GC will
171 -- detect that it is unreachable and send it the NonTermination
172 -- exception. However, since the thread is unreachable, everything
173 -- it refers to might be finalized, including the standard Handles.
174 -- This sounds like a bug, but we don't have a good solution right
181 hSetBuffering stdout NoBuffering
183 -- Initialise buffering for the *interpreted* I/O system
184 initInterpBuffering session
186 -- We don't want the cmd line to buffer any input that might be
187 -- intended for the program, so unbuffer stdin.
188 hSetBuffering stdin NoBuffering
190 -- initial context is just the Prelude
191 GHC.setContext session [] [prelude_mod]
197 #if defined(mingw32_HOST_OS)
198 -- The win32 Console API mutates the first character of
199 -- type-ahead when reading from it in a non-buffered manner. Work
200 -- around this by flushing the input buffer of type-ahead characters.
202 GHC.ConsoleHandler.flushConsole stdin
204 startGHCi (runGHCi srcs maybe_expr)
205 GHCiState{ progname = "<interactive>",
211 Readline.resetTerminal Nothing
216 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
217 runGHCi paths maybe_expr = do
218 let read_dot_files = not opt_IgnoreDotGhci
220 when (read_dot_files) $ do
223 exists <- io (doesFileExist file)
225 dir_ok <- io (checkPerms ".")
226 file_ok <- io (checkPerms file)
227 when (dir_ok && file_ok) $ do
228 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
231 Right hdl -> fileLoop hdl False
233 when (read_dot_files) $ do
234 -- Read in $HOME/.ghci
235 either_dir <- io (IO.try (getEnv "HOME"))
239 cwd <- io (getCurrentDirectory)
240 when (dir /= cwd) $ do
241 let file = dir ++ "/.ghci"
242 ok <- io (checkPerms file)
244 either_hdl <- io (IO.try (openFile file ReadMode))
247 Right hdl -> fileLoop hdl False
249 -- Perform a :load for files given on the GHCi command line
250 -- When in -e mode, if the load fails then we want to stop
251 -- immediately rather than going on to evaluate the expression.
252 when (not (null paths)) $ do
253 ok <- ghciHandle (\e -> do showException e; return Failed) $
255 when (isJust maybe_expr && failed ok) $
256 io (exitWith (ExitFailure 1))
258 -- if verbosity is greater than 0, or we are connected to a
259 -- terminal, display the prompt in the interactive loop.
260 is_tty <- io (hIsTerminalDevice stdin)
261 dflags <- getDynFlags
262 let show_prompt = verbosity dflags > 0 || is_tty
266 -- enter the interactive loop
267 interactiveLoop is_tty show_prompt
269 -- just evaluate the expression we were given
274 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
277 interactiveLoop is_tty show_prompt = do
278 -- Ignore ^C exceptions caught here
279 ghciHandleDyn (\e -> case e of
280 Interrupted -> ghciUnblock (
281 #if defined(mingw32_HOST_OS)
284 interactiveLoop is_tty show_prompt)
285 _other -> return ()) $ do
287 -- read commands from stdin
291 else fileLoop stdin show_prompt
293 fileLoop stdin show_prompt
297 -- NOTE: We only read .ghci files if they are owned by the current user,
298 -- and aren't world writable. Otherwise, we could be accidentally
299 -- running code planted by a malicious third party.
301 -- Furthermore, We only read ./.ghci if . is owned by the current user
302 -- and isn't writable by anyone else. I think this is sufficient: we
303 -- don't need to check .. and ../.. etc. because "." always refers to
304 -- the same directory while a process is running.
306 checkPerms :: String -> IO Bool
308 #ifdef mingw32_HOST_OS
311 Util.handle (\_ -> return False) $ do
312 st <- getFileStatus name
314 if fileOwner st /= me then do
315 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
318 let mode = fileMode st
319 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
320 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
322 putStrLn $ "*** WARNING: " ++ name ++
323 " is writable by someone else, IGNORING!"
328 fileLoop :: Handle -> Bool -> GHCi ()
329 fileLoop hdl prompt = do
330 session <- getSession
331 (mod,imports) <- io (GHC.getContext session)
332 when prompt (io (putStr (mkPrompt mod imports)))
333 l <- io (IO.try (hGetLine hdl))
335 Left e | isEOFError e -> return ()
336 | InvalidArgument <- etype -> return ()
337 | otherwise -> io (ioError e)
338 where etype = ioeGetErrorType e
339 -- treat InvalidArgument in the same way as EOF:
340 -- this can happen if the user closed stdin, or
341 -- perhaps did getContents which closes stdin at
344 case removeSpaces l of
345 "" -> fileLoop hdl prompt
346 l -> do quit <- runCommand l
347 if quit then return () else fileLoop hdl prompt
349 stringLoop :: [String] -> GHCi ()
350 stringLoop [] = return ()
351 stringLoop (s:ss) = do
352 case removeSpaces s of
354 l -> do quit <- runCommand l
355 if quit then return () else stringLoop ss
357 mkPrompt toplevs exports
358 = showSDoc (hsep (map (\m -> char '*' <> pprModule m) toplevs)
359 <+> hsep (map pprModule exports)
363 readlineLoop :: GHCi ()
365 session <- getSession
366 (mod,imports) <- io (GHC.getContext session)
368 l <- io (readline (mkPrompt mod imports)
369 `finally` setNonBlockingFD 0)
370 -- readline sometimes puts stdin into blocking mode,
371 -- so we need to put it back for the IO library
375 case removeSpaces l of
380 if quit then return () else readlineLoop
383 runCommand :: String -> GHCi Bool
384 runCommand c = ghciHandle handler (doCommand c)
386 -- This version is for the GHC command-line option -e. The only difference
387 -- from runCommand is that it catches the ExitException exception and
388 -- exits, rather than printing out the exception.
389 runCommandEval c = ghciHandle handleEval (doCommand c)
391 handleEval (ExitException code) = io (exitWith code)
392 handleEval e = do showException e
393 io (exitWith (ExitFailure 1))
395 -- This is the exception handler for exceptions generated by the
396 -- user's code; it normally just prints out the exception. The
397 -- handler must be recursive, in case showing the exception causes
398 -- more exceptions to be raised.
400 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
401 -- raising another exception. We therefore don't put the recursive
402 -- handler arond the flushing operation, so if stderr is closed
403 -- GHCi will just die gracefully rather than going into an infinite loop.
404 handler :: Exception -> GHCi Bool
405 handler exception = do
407 io installSignalHandlers
408 ghciHandle handler (showException exception >> return False)
410 showException (DynException dyn) =
411 case fromDynamic dyn of
412 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
413 Just Interrupted -> io (putStrLn "Interrupted.")
414 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
415 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
416 Just other_ghc_ex -> io (print other_ghc_ex)
418 showException other_exception
419 = io (putStrLn ("*** Exception: " ++ show other_exception))
421 doCommand (':' : command) = specialCommand command
423 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
426 runStmt :: String -> GHCi [Name]
428 | null (filter (not.isSpace) stmt) = return []
430 = do st <- getGHCiState
431 session <- getSession
432 result <- io $ withProgName (progname st) $ withArgs (args st) $
433 GHC.runStmt session stmt
435 GHC.RunFailed -> return []
436 GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
437 GHC.RunOk names -> return names
439 -- possibly print the type and revert CAFs after evaluating an expression
441 = do b <- isOptionSet ShowType
442 session <- getSession
443 when b (mapM_ (showTypeOfName session) names)
446 io installSignalHandlers
447 b <- isOptionSet RevertCAFs
448 io (when b revertCAFs)
451 showTypeOfName :: Session -> Name -> GHCi ()
452 showTypeOfName session n
453 = do maybe_tything <- io (GHC.lookupName session n)
454 case maybe_tything of
456 Just thing -> showTyThing thing
458 showForUser :: SDoc -> GHCi String
460 session <- getSession
461 unqual <- io (GHC.getPrintUnqual session)
462 return $! showSDocForUser unqual doc
464 specialCommand :: String -> GHCi Bool
465 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
466 specialCommand str = do
467 let (cmd,rest) = break isSpace str
468 cmds <- io (readIORef commands)
469 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
470 [] -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
471 ++ shortHelpText) >> return False)
472 [(_,f)] -> f (dropWhile isSpace rest)
473 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
474 " matches multiple commands (" ++
475 foldr1 (\a b -> a ++ ',':b) (map fst cs)
476 ++ ")") >> return False)
478 -----------------------------------------------------------------------------
479 -- To flush buffers for the *interpreted* computation we need
480 -- to refer to *its* stdout/stderr handles
482 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
483 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
485 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
486 " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
487 flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
489 initInterpBuffering :: Session -> IO ()
490 initInterpBuffering session
491 = do maybe_hval <- GHC.compileExpr session no_buf_cmd
494 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
495 other -> panic "interactiveUI:setBuffering"
497 maybe_hval <- GHC.compileExpr session flush_cmd
499 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
500 _ -> panic "interactiveUI:flush"
502 turnOffBuffering -- Turn it off right now
507 flushInterpBuffers :: GHCi ()
509 = io $ do Monad.join (readIORef flush_interp)
512 turnOffBuffering :: IO ()
514 = do Monad.join (readIORef turn_off_buffering)
517 -----------------------------------------------------------------------------
520 help :: String -> GHCi ()
521 help _ = io (putStr helpText)
523 info :: String -> GHCi ()
524 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
525 info s = do { let names = words s
526 ; session <- getSession
527 ; dflags <- getDynFlags
528 ; let exts = dopt Opt_GlasgowExts dflags
529 ; mapM_ (infoThing exts session) names }
531 infoThing exts session str = io $ do
532 names <- GHC.parseName session str
533 let filtered = filterOutChildren names
534 mb_stuffs <- mapM (GHC.getInfo session) filtered
535 unqual <- GHC.getPrintUnqual session
536 putStrLn (showSDocForUser unqual $
537 vcat (intersperse (text "") $
538 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
540 -- Filter out names whose parent is also there Good
541 -- example is '[]', which is both a type and data
542 -- constructor in the same type
543 filterOutChildren :: [Name] -> [Name]
544 filterOutChildren names = filter (not . parent_is_there) names
545 where parent_is_there n
546 | Just p <- GHC.nameParent_maybe n = p `elem` names
549 pprInfo exts (thing, fixity, insts)
550 = pprTyThingLoc exts thing
551 $$ show_fixity fixity
552 $$ vcat (map GHC.pprInstance insts)
555 | fix == GHC.defaultFixity = empty
556 | otherwise = ppr fix <+> ppr (GHC.getName thing)
558 -----------------------------------------------------------------------------
561 addModule :: [FilePath] -> GHCi ()
563 io (revertCAFs) -- always revert CAFs on load/add.
564 files <- mapM expandPath files
565 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
566 session <- getSession
567 io (mapM_ (GHC.addTarget session) targets)
568 ok <- io (GHC.load session LoadAllTargets)
571 changeDirectory :: String -> GHCi ()
572 changeDirectory dir = do
573 session <- getSession
574 graph <- io (GHC.getModuleGraph session)
575 when (not (null graph)) $
576 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
577 io (GHC.setTargets session [])
578 io (GHC.load session LoadAllTargets)
579 setContextAfterLoad []
580 io (GHC.workingDirectoryChanged session)
581 dir <- expandPath dir
582 io (setCurrentDirectory dir)
584 defineMacro :: String -> GHCi ()
586 let (macro_name, definition) = break isSpace s
587 cmds <- io (readIORef commands)
589 then throwDyn (CmdLineError "invalid macro name")
591 if (macro_name `elem` map fst cmds)
592 then throwDyn (CmdLineError
593 ("command '" ++ macro_name ++ "' is already defined"))
596 -- give the expression a type signature, so we can be sure we're getting
597 -- something of the right type.
598 let new_expr = '(' : definition ++ ") :: String -> IO String"
600 -- compile the expression
602 maybe_hv <- io (GHC.compileExpr cms new_expr)
605 Just hv -> io (writeIORef commands --
606 ((macro_name, keepGoing (runMacro hv)) : cmds))
608 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi ()
610 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
611 stringLoop (lines str)
613 undefineMacro :: String -> GHCi ()
614 undefineMacro macro_name = do
615 cmds <- io (readIORef commands)
616 if (macro_name `elem` map fst builtin_commands)
617 then throwDyn (CmdLineError
618 ("command '" ++ macro_name ++ "' cannot be undefined"))
620 if (macro_name `notElem` map fst cmds)
621 then throwDyn (CmdLineError
622 ("command '" ++ macro_name ++ "' not defined"))
624 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
627 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
628 loadModule fs = timeIt (loadModule' fs)
630 loadModule_ :: [FilePath] -> GHCi ()
631 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
633 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
634 loadModule' files = do
635 session <- getSession
638 io (GHC.setTargets session [])
639 io (GHC.load session LoadAllTargets)
642 let (filenames, phases) = unzip files
643 exp_filenames <- mapM expandPath filenames
644 let files' = zip exp_filenames phases
645 targets <- io (mapM (uncurry GHC.guessTarget) files')
647 -- NOTE: we used to do the dependency anal first, so that if it
648 -- fails we didn't throw away the current set of modules. This would
649 -- require some re-working of the GHC interface, so we'll leave it
650 -- as a ToDo for now.
652 io (GHC.setTargets session targets)
653 ok <- io (GHC.load session LoadAllTargets)
657 checkModule :: String -> GHCi ()
659 let modl = mkModule m
660 session <- getSession
661 result <- io (GHC.checkModule session modl printErrorsAndWarnings)
663 Nothing -> io $ putStrLn "Nothing"
664 Just r -> io $ putStrLn (showSDoc (
665 case checkedModuleInfo r of
666 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
668 (local,global) = partition ((== modl) . GHC.nameModule) scope
670 (text "global names: " <+> ppr global) $$
671 (text "local names: " <+> ppr local)
673 afterLoad (successIf (isJust result)) session
675 reloadModule :: String -> GHCi ()
677 io (revertCAFs) -- always revert CAFs on reload.
678 session <- getSession
679 ok <- io (GHC.load session LoadAllTargets)
682 io (revertCAFs) -- always revert CAFs on reload.
683 session <- getSession
684 ok <- io (GHC.load session (LoadUpTo (mkModule m)))
687 afterLoad ok session = do
688 io (revertCAFs) -- always revert CAFs on load.
689 graph <- io (GHC.getModuleGraph session)
690 let mods = map GHC.ms_mod graph
691 mods' <- filterM (io . GHC.isLoaded session) mods
692 setContextAfterLoad mods'
693 modulesLoadedMsg ok mods'
695 setContextAfterLoad [] = do
696 session <- getSession
697 io (GHC.setContext session [] [prelude_mod])
698 setContextAfterLoad (m:_) = do
699 session <- getSession
700 b <- io (GHC.moduleIsInterpreted session m)
701 if b then io (GHC.setContext session [m] [])
702 else io (GHC.setContext session [] [m])
704 modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi ()
705 modulesLoadedMsg ok mods = do
706 dflags <- getDynFlags
707 when (verbosity dflags > 0) $ do
709 | null mods = text "none."
711 punctuate comma (map pprModule mods)) <> text "."
714 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
716 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
719 typeOfExpr :: String -> GHCi ()
721 = do cms <- getSession
722 maybe_ty <- io (GHC.exprType cms str)
725 Just ty -> do ty' <- cleanType ty
726 tystr <- showForUser (ppr ty')
727 io (putStrLn (str ++ " :: " ++ tystr))
729 kindOfType :: String -> GHCi ()
731 = do cms <- getSession
732 maybe_ty <- io (GHC.typeKind cms str)
735 Just ty -> do tystr <- showForUser (ppr ty)
736 io (putStrLn (str ++ " :: " ++ tystr))
738 quit :: String -> GHCi Bool
741 shellEscape :: String -> GHCi Bool
742 shellEscape str = io (system str >> return False)
744 -----------------------------------------------------------------------------
745 -- create tags file for currently loaded modules.
747 createTagsFileCmd :: String -> GHCi ()
748 createTagsFileCmd "-c" = ghciCreateTagsFile CTags "tags"
749 createTagsFileCmd "-e" = ghciCreateTagsFile ETags "TAGS"
750 createTagsFileCmd _ = throwDyn (CmdLineError "syntax: :tags -c|-e")
752 data TagsKind = ETags | CTags
754 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
755 ghciCreateTagsFile kind file = do
756 session <- getSession
757 io $ createTagsFile session kind file
760 -- - remove restriction that all modules must be interpreted
761 -- (problem: we don't know source locations for entities unless
762 -- we compiled the module.
764 -- - extract createTagsFile so it can be used from the command-line
765 -- (probably need to fix first problem before this is useful).
767 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
768 createTagsFile session tagskind tagFile = do
769 graph <- GHC.getModuleGraph session
770 let ms = map GHC.ms_mod graph
772 is_interpreted <- GHC.moduleIsInterpreted session m
773 -- should we just skip these?
774 when (not is_interpreted) $
775 throwDyn (CmdLineError ("module '" ++ moduleUserString m ++ "' is not interpreted"))
777 mbModInfo <- GHC.getModuleInfo session m
779 | Just modinfo <- mbModInfo,
780 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
781 | otherwise = GHC.alwaysQualify
784 Just modInfo -> return $! listTags unqual modInfo
787 mtags <- mapM tagModule ms
788 either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
790 Left e -> hPutStrLn stderr $ ioeGetErrorString e
793 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
794 listTags unqual modInfo =
795 [ tagInfo unqual name loc
796 | name <- GHC.modInfoExports modInfo
797 , let loc = nameSrcLoc name
801 type TagInfo = (String -- tag name
804 ,Int -- column number
807 -- get tag info, for later translation into Vim or Emacs style
808 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
809 tagInfo unqual name loc
810 = ( showSDocForUser unqual $ pprOccName (nameOccName name)
811 , showSDocForUser unqual $ ftext (srcLocFile loc)
816 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
817 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
818 let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
819 IO.try (writeFile file tags)
820 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
821 let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
822 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
823 tagGroups <- mapM tagFileGroup groups
824 IO.try (writeFile file $ concat tagGroups)
826 tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
827 tagFileGroup group@((_,fileName,_,_):_) = do
828 file <- readFile fileName -- need to get additional info from sources..
829 let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
830 sortedGroup = sortLe byLine group
831 tags = unlines $ perFile sortedGroup 1 0 $ lines file
832 return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
833 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
834 perFile (tagInfo:tags) (count+1) (pos+length line) lines
835 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
836 showETag tagInfo line pos : perFile tags count pos lines
837 perFile tags count pos lines = []
839 -- simple ctags format, for Vim et al
840 showTag :: TagInfo -> String
841 showTag (tag,file,lineNo,colNo)
842 = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
844 -- etags format, for Emacs/XEmacs
845 showETag :: TagInfo -> String -> Int -> String
846 showETag (tag,file,lineNo,colNo) line charPos
847 = take colNo line ++ tag
849 ++ "\x01" ++ show lineNo
850 ++ "," ++ show charPos
852 -----------------------------------------------------------------------------
853 -- Browsing a module's contents
855 browseCmd :: String -> GHCi ()
858 ['*':m] | looksLikeModuleName m -> browseModule m False
859 [m] | looksLikeModuleName m -> browseModule m True
860 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
862 browseModule m exports_only = do
865 let modl = mkModule m
866 is_interpreted <- io (GHC.moduleIsInterpreted s modl)
867 when (not is_interpreted && not exports_only) $
868 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
870 -- Temporarily set the context to the module we're interested in,
871 -- just so we can get an appropriate PrintUnqualified
872 (as,bs) <- io (GHC.getContext s)
873 io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
874 else GHC.setContext s [modl] [])
875 unqual <- io (GHC.getPrintUnqual s)
876 io (GHC.setContext s as bs)
878 mb_mod_info <- io $ GHC.getModuleInfo s modl
880 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
883 | exports_only = GHC.modInfoExports mod_info
884 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
886 filtered = filterOutChildren names
888 things <- io $ mapM (GHC.lookupName s) filtered
890 dflags <- getDynFlags
891 let exts = dopt Opt_GlasgowExts dflags
892 io (putStrLn (showSDocForUser unqual (
893 vcat (map (pprTyThing exts) (catMaybes things))
895 -- ToDo: modInfoInstances currently throws an exception for
896 -- package modules. When it works, we can do this:
897 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
899 -----------------------------------------------------------------------------
900 -- Setting the module context
903 | all sensible mods = fn mods
904 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
906 (fn, mods) = case str of
907 '+':stuff -> (addToContext, words stuff)
908 '-':stuff -> (removeFromContext, words stuff)
909 stuff -> (newContext, words stuff)
911 sensible ('*':m) = looksLikeModuleName m
912 sensible m = looksLikeModuleName m
915 session <- getSession
916 (as,bs) <- separate session mods [] []
917 let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs
918 io (GHC.setContext session as bs')
920 separate :: Session -> [String] -> [Module] -> [Module]
921 -> GHCi ([Module],[Module])
922 separate session [] as bs = return (as,bs)
923 separate session (('*':m):ms) as bs = do
924 let modl = mkModule m
925 b <- io (GHC.moduleIsInterpreted session modl)
926 if b then separate session ms (modl:as) bs
927 else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
928 separate session (m:ms) as bs = separate session ms as (mkModule m:bs)
930 prelude_mod = mkModule "Prelude"
933 addToContext mods = do
935 (as,bs) <- io (GHC.getContext cms)
937 (as',bs') <- separate cms mods [] []
939 let as_to_add = as' \\ (as ++ bs)
940 bs_to_add = bs' \\ (as ++ bs)
942 io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add))
945 removeFromContext mods = do
947 (as,bs) <- io (GHC.getContext cms)
949 (as_to_remove,bs_to_remove) <- separate cms mods [] []
951 let as' = as \\ (as_to_remove ++ bs_to_remove)
952 bs' = bs \\ (as_to_remove ++ bs_to_remove)
954 io (GHC.setContext cms as' bs')
956 ----------------------------------------------------------------------------
959 -- set options in the interpreter. Syntax is exactly the same as the
960 -- ghc command line, except that certain options aren't available (-C,
963 -- This is pretty fragile: most options won't work as expected. ToDo:
964 -- figure out which ones & disallow them.
966 setCmd :: String -> GHCi ()
968 = do st <- getGHCiState
969 let opts = options st
970 io $ putStrLn (showSDoc (
971 text "options currently set: " <>
974 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
978 ("args":args) -> setArgs args
979 ("prog":prog) -> setProg prog
980 wds -> setOptions wds
984 setGHCiState st{ args = args }
988 setGHCiState st{ progname = prog }
990 io (hPutStrLn stderr "syntax: :set prog <progname>")
993 do -- first, deal with the GHCi opts (+s, +t, etc.)
994 let (plus_opts, minus_opts) = partition isPlus wds
995 mapM_ setOpt plus_opts
997 -- then, dynamic flags
998 dflags <- getDynFlags
999 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1002 -- update things if the users wants more packages
1004 let new_packages = pkgs_after \\ pkgs_before
1005 when (not (null new_packages)) $
1006 newPackages new_packages
1009 if (not (null leftovers))
1010 then throwDyn (CmdLineError ("unrecognised flags: " ++
1015 unsetOptions :: String -> GHCi ()
1017 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1018 let opts = words str
1019 (minus_opts, rest1) = partition isMinus opts
1020 (plus_opts, rest2) = partition isPlus rest1
1022 if (not (null rest2))
1023 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1026 mapM_ unsetOpt plus_opts
1028 -- can't do GHC flags for now
1029 if (not (null minus_opts))
1030 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1033 isMinus ('-':s) = True
1036 isPlus ('+':s) = True
1040 = case strToGHCiOpt str of
1041 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1042 Just o -> setOption o
1045 = case strToGHCiOpt str of
1046 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1047 Just o -> unsetOption o
1049 strToGHCiOpt :: String -> (Maybe GHCiOption)
1050 strToGHCiOpt "s" = Just ShowTiming
1051 strToGHCiOpt "t" = Just ShowType
1052 strToGHCiOpt "r" = Just RevertCAFs
1053 strToGHCiOpt _ = Nothing
1055 optToStr :: GHCiOption -> String
1056 optToStr ShowTiming = "s"
1057 optToStr ShowType = "t"
1058 optToStr RevertCAFs = "r"
1061 newPackages new_pkgs = do -- The new packages are already in v_Packages
1062 session <- getSession
1063 io (GHC.setTargets session [])
1064 io (GHC.load session Nothing)
1065 dflags <- getDynFlags
1066 io (linkPackages dflags new_pkgs)
1067 setContextAfterLoad []
1070 -- ---------------------------------------------------------------------------
1075 ["modules" ] -> showModules
1076 ["bindings"] -> showBindings
1077 ["linker"] -> io showLinkerState
1078 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1081 session <- getSession
1082 let show_one ms = do m <- io (GHC.showModule session ms)
1084 graph <- io (GHC.getModuleGraph session)
1085 mapM_ show_one graph
1089 unqual <- io (GHC.getPrintUnqual s)
1090 bindings <- io (GHC.getBindings s)
1091 mapM_ showTyThing bindings
1094 showTyThing (AnId id) = do
1095 ty' <- cleanType (GHC.idType id)
1096 str <- showForUser (ppr id <> text " :: " <> ppr ty')
1098 showTyThing _ = return ()
1100 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1101 cleanType :: Type -> GHCi Type
1103 dflags <- getDynFlags
1104 if dopt Opt_GlasgowExts dflags
1106 else return $! GHC.dropForAlls ty
1108 -----------------------------------------------------------------------------
1111 data GHCiState = GHCiState
1115 session :: GHC.Session,
1116 options :: [GHCiOption]
1120 = ShowTiming -- show time/allocs after evaluation
1121 | ShowType -- show the type of expressions
1122 | RevertCAFs -- revert CAFs after every evaluation
1125 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1127 startGHCi :: GHCi a -> GHCiState -> IO a
1128 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1130 instance Monad GHCi where
1131 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1132 return a = GHCi $ \s -> return a
1134 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1135 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1136 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1138 getGHCiState = GHCi $ \r -> readIORef r
1139 setGHCiState s = GHCi $ \r -> writeIORef r s
1141 -- for convenience...
1142 getSession = getGHCiState >>= return . session
1146 io (GHC.getSessionDynFlags s)
1147 setDynFlags dflags = do
1149 io (GHC.setSessionDynFlags s dflags)
1151 isOptionSet :: GHCiOption -> GHCi Bool
1153 = do st <- getGHCiState
1154 return (opt `elem` options st)
1156 setOption :: GHCiOption -> GHCi ()
1158 = do st <- getGHCiState
1159 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1161 unsetOption :: GHCiOption -> GHCi ()
1163 = do st <- getGHCiState
1164 setGHCiState (st{ options = filter (/= opt) (options st) })
1166 io :: IO a -> GHCi a
1167 io m = GHCi { unGHCi = \s -> m >>= return }
1169 -----------------------------------------------------------------------------
1170 -- recursive exception handlers
1172 -- Don't forget to unblock async exceptions in the handler, or if we're
1173 -- in an exception loop (eg. let a = error a in a) the ^C exception
1174 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1176 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1177 ghciHandle h (GHCi m) = GHCi $ \s ->
1178 Exception.catch (m s)
1179 (\e -> unGHCi (ghciUnblock (h e)) s)
1181 ghciUnblock :: GHCi a -> GHCi a
1182 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1184 -----------------------------------------------------------------------------
1185 -- timing & statistics
1187 timeIt :: GHCi a -> GHCi a
1189 = do b <- isOptionSet ShowTiming
1192 else do allocs1 <- io $ getAllocations
1193 time1 <- io $ getCPUTime
1195 allocs2 <- io $ getAllocations
1196 time2 <- io $ getCPUTime
1197 io $ printTimes (fromIntegral (allocs2 - allocs1))
1201 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1202 -- defined in ghc/rts/Stats.c
1204 printTimes :: Integer -> Integer -> IO ()
1205 printTimes allocs psecs
1206 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1207 secs_str = showFFloat (Just 2) secs
1208 putStrLn (showSDoc (
1209 parens (text (secs_str "") <+> text "secs" <> comma <+>
1210 text (show allocs) <+> text "bytes")))
1212 -----------------------------------------------------------------------------
1219 -- Have to turn off buffering again, because we just
1220 -- reverted stdout, stderr & stdin to their defaults.
1222 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1223 -- Make it "safe", just in case
1225 -- -----------------------------------------------------------------------------
1228 expandPath :: String -> GHCi String
1230 case dropWhile isSpace path of
1232 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1233 return (tilde ++ '/':d)