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 ("reload", keepGoing reloadModule),
108 ("check", keepGoing checkModule),
109 ("set", keepGoing setCmd),
110 ("show", keepGoing showCmd),
111 ("etags", keepGoing createETagsFileCmd),
112 ("ctags", keepGoing createCTagsFileCmd),
113 ("type", keepGoing typeOfExpr),
114 ("kind", keepGoing kindOfType),
115 ("unset", keepGoing unsetOptions),
116 ("undef", keepGoing undefineMacro),
120 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
121 keepGoing a str = a str >> return False
123 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
124 keepGoingPaths a str = a (toArgs str) >> return False
126 shortHelpText = "use :? for help.\n"
128 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
130 " Commands available from the prompt:\n" ++
132 " <stmt> evaluate/run <stmt>\n" ++
133 " :add <filename> ... add module(s) to the current target set\n" ++
134 " :browse [*]<module> display the names defined by <module>\n" ++
135 " :cd <dir> change directory to <dir>\n" ++
136 " :def <cmd> <expr> define a command :<cmd>\n" ++
137 " :help, :? display this list of commands\n" ++
138 " :info [<name> ...] display information about the given names\n" ++
139 " :load <filename> ... load module(s) and their dependents\n" ++
140 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
141 " :reload reload the current module set\n" ++
143 " :set <option> ... set options\n" ++
144 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
145 " :set prog <progname> set the value returned by System.getProgName\n" ++
147 " :show modules show the currently loaded modules\n" ++
148 " :show bindings show the current bindings made at the prompt\n" ++
150 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
151 " :etags [<file>] create tags file for Emacs (defauilt: \"TAGS\")\n" ++
152 " :type <expr> show the type of <expr>\n" ++
153 " :kind <type> show the kind of <type>\n" ++
154 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
155 " :unset <option> ... unset options\n" ++
156 " :quit exit GHCi\n" ++
157 " :!<command> run the shell command <command>\n" ++
159 " Options for ':set' and ':unset':\n" ++
161 " +r revert top-level expressions after each evaluation\n" ++
162 " +s print timing/memory stats after each evaluation\n" ++
163 " +t print type after evaluation\n" ++
164 " -<flags> most GHC command line flags can also be set here\n" ++
165 " (eg. -v2, -fglasgow-exts, etc.)\n"
168 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
169 interactiveUI session srcs maybe_expr = do
171 -- HACK! If we happen to get into an infinite loop (eg the user
172 -- types 'let x=x in x' at the prompt), then the thread will block
173 -- on a blackhole, and become unreachable during GC. The GC will
174 -- detect that it is unreachable and send it the NonTermination
175 -- exception. However, since the thread is unreachable, everything
176 -- it refers to might be finalized, including the standard Handles.
177 -- This sounds like a bug, but we don't have a good solution right
184 hSetBuffering stdout NoBuffering
186 -- Initialise buffering for the *interpreted* I/O system
187 initInterpBuffering session
189 -- We don't want the cmd line to buffer any input that might be
190 -- intended for the program, so unbuffer stdin.
191 hSetBuffering stdin NoBuffering
193 -- initial context is just the Prelude
194 GHC.setContext session [] [prelude_mod]
200 startGHCi (runGHCi srcs maybe_expr)
201 GHCiState{ progname = "<interactive>",
207 Readline.resetTerminal Nothing
212 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
213 runGHCi paths maybe_expr = do
214 let read_dot_files = not opt_IgnoreDotGhci
216 when (read_dot_files) $ do
219 exists <- io (doesFileExist file)
221 dir_ok <- io (checkPerms ".")
222 file_ok <- io (checkPerms file)
223 when (dir_ok && file_ok) $ do
224 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
227 Right hdl -> fileLoop hdl False
229 when (read_dot_files) $ do
230 -- Read in $HOME/.ghci
231 either_dir <- io (IO.try (getEnv "HOME"))
235 cwd <- io (getCurrentDirectory)
236 when (dir /= cwd) $ do
237 let file = dir ++ "/.ghci"
238 ok <- io (checkPerms file)
240 either_hdl <- io (IO.try (openFile file ReadMode))
243 Right hdl -> fileLoop hdl False
245 -- Perform a :load for files given on the GHCi command line
246 -- When in -e mode, if the load fails then we want to stop
247 -- immediately rather than going on to evaluate the expression.
248 when (not (null paths)) $ do
249 ok <- ghciHandle (\e -> do showException e; return Failed) $
251 when (isJust maybe_expr && failed ok) $
252 io (exitWith (ExitFailure 1))
254 -- if verbosity is greater than 0, or we are connected to a
255 -- terminal, display the prompt in the interactive loop.
256 is_tty <- io (hIsTerminalDevice stdin)
257 dflags <- getDynFlags
258 let show_prompt = verbosity dflags > 0 || is_tty
262 #if defined(mingw32_HOST_OS)
264 -- The win32 Console API mutates the first character of
265 -- type-ahead when reading from it in a non-buffered manner. Work
266 -- around this by flushing the input buffer of type-ahead characters,
267 -- but only if stdin is available.
268 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
270 Left err | isDoesNotExistError err -> return ()
271 | otherwise -> io (ioError err)
272 Right () -> return ()
274 -- enter the interactive loop
275 interactiveLoop is_tty show_prompt
277 -- just evaluate the expression we were given
282 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
285 interactiveLoop is_tty show_prompt = do
286 -- Ignore ^C exceptions caught here
287 ghciHandleDyn (\e -> case e of
288 Interrupted -> ghciUnblock (
289 #if defined(mingw32_HOST_OS)
292 interactiveLoop is_tty show_prompt)
293 _other -> return ()) $ do
295 -- read commands from stdin
299 else fileLoop stdin show_prompt
301 fileLoop stdin show_prompt
305 -- NOTE: We only read .ghci files if they are owned by the current user,
306 -- and aren't world writable. Otherwise, we could be accidentally
307 -- running code planted by a malicious third party.
309 -- Furthermore, We only read ./.ghci if . is owned by the current user
310 -- and isn't writable by anyone else. I think this is sufficient: we
311 -- don't need to check .. and ../.. etc. because "." always refers to
312 -- the same directory while a process is running.
314 checkPerms :: String -> IO Bool
316 #ifdef mingw32_HOST_OS
319 Util.handle (\_ -> return False) $ do
320 st <- getFileStatus name
322 if fileOwner st /= me then do
323 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
326 let mode = fileMode st
327 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
328 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
330 putStrLn $ "*** WARNING: " ++ name ++
331 " is writable by someone else, IGNORING!"
336 fileLoop :: Handle -> Bool -> GHCi ()
337 fileLoop hdl prompt = do
338 session <- getSession
339 (mod,imports) <- io (GHC.getContext session)
340 when prompt (io (putStr (mkPrompt mod imports)))
341 l <- io (IO.try (hGetLine hdl))
343 Left e | isEOFError e -> return ()
344 | InvalidArgument <- etype -> return ()
345 | otherwise -> io (ioError e)
346 where etype = ioeGetErrorType e
347 -- treat InvalidArgument in the same way as EOF:
348 -- this can happen if the user closed stdin, or
349 -- perhaps did getContents which closes stdin at
352 case removeSpaces l of
353 "" -> fileLoop hdl prompt
354 l -> do quit <- runCommand l
355 if quit then return () else fileLoop hdl prompt
357 stringLoop :: [String] -> GHCi ()
358 stringLoop [] = return ()
359 stringLoop (s:ss) = do
360 case removeSpaces s of
362 l -> do quit <- runCommand l
363 if quit then return () else stringLoop ss
365 mkPrompt toplevs exports
366 = showSDoc (hsep (map (\m -> char '*' <> pprModule m) toplevs)
367 <+> hsep (map pprModule exports)
371 readlineLoop :: GHCi ()
373 session <- getSession
374 (mod,imports) <- io (GHC.getContext session)
376 l <- io (readline (mkPrompt mod imports)
377 `finally` setNonBlockingFD 0)
378 -- readline sometimes puts stdin into blocking mode,
379 -- so we need to put it back for the IO library
383 case removeSpaces l of
388 if quit then return () else readlineLoop
391 runCommand :: String -> GHCi Bool
392 runCommand c = ghciHandle handler (doCommand c)
394 doCommand (':' : command) = specialCommand command
396 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
399 -- This version is for the GHC command-line option -e. The only difference
400 -- from runCommand is that it catches the ExitException exception and
401 -- exits, rather than printing out the exception.
402 runCommandEval c = ghciHandle handleEval (doCommand c)
404 handleEval (ExitException code) = io (exitWith code)
405 handleEval e = do showException e
406 io (exitWith (ExitFailure 1))
408 doCommand (':' : command) = specialCommand command
410 = do nms <- runStmt stmt
412 Nothing -> io (exitWith (ExitFailure 1))
413 -- failure to run the command causes exit(1) for ghc -e.
414 _ -> finishEvalExpr nms
416 -- This is the exception handler for exceptions generated by the
417 -- user's code; it normally just prints out the exception. The
418 -- handler must be recursive, in case showing the exception causes
419 -- more exceptions to be raised.
421 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
422 -- raising another exception. We therefore don't put the recursive
423 -- handler arond the flushing operation, so if stderr is closed
424 -- GHCi will just die gracefully rather than going into an infinite loop.
425 handler :: Exception -> GHCi Bool
426 handler exception = do
428 io installSignalHandlers
429 ghciHandle handler (showException exception >> return False)
431 showException (DynException dyn) =
432 case fromDynamic dyn of
433 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
434 Just Interrupted -> io (putStrLn "Interrupted.")
435 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
436 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
437 Just other_ghc_ex -> io (print other_ghc_ex)
439 showException other_exception
440 = io (putStrLn ("*** Exception: " ++ show other_exception))
442 runStmt :: String -> GHCi (Maybe [Name])
444 | null (filter (not.isSpace) stmt) = return (Just [])
446 = do st <- getGHCiState
447 session <- getSession
448 result <- io $ withProgName (progname st) $ withArgs (args st) $
449 GHC.runStmt session stmt
451 GHC.RunFailed -> return Nothing
452 GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
453 GHC.RunOk names -> return (Just names)
455 -- possibly print the type and revert CAFs after evaluating an expression
456 finishEvalExpr mb_names
457 = do b <- isOptionSet ShowType
458 session <- getSession
461 Just names -> when b (mapM_ (showTypeOfName session) names)
464 io installSignalHandlers
465 b <- isOptionSet RevertCAFs
466 io (when b revertCAFs)
469 showTypeOfName :: Session -> Name -> GHCi ()
470 showTypeOfName session n
471 = do maybe_tything <- io (GHC.lookupName session n)
472 case maybe_tything of
474 Just thing -> showTyThing thing
476 showForUser :: SDoc -> GHCi String
478 session <- getSession
479 unqual <- io (GHC.getPrintUnqual session)
480 return $! showSDocForUser unqual doc
482 specialCommand :: String -> GHCi Bool
483 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
484 specialCommand str = do
485 let (cmd,rest) = break isSpace str
486 cmds <- io (readIORef commands)
487 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
488 [] -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
489 ++ shortHelpText) >> return False)
490 [(_,f)] -> f (dropWhile isSpace rest)
491 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
492 " matches multiple commands (" ++
493 foldr1 (\a b -> a ++ ',':b) (map fst cs)
494 ++ ")") >> return False)
496 -----------------------------------------------------------------------------
497 -- To flush buffers for the *interpreted* computation we need
498 -- to refer to *its* stdout/stderr handles
500 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
501 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
503 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
504 " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
505 flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
507 initInterpBuffering :: Session -> IO ()
508 initInterpBuffering session
509 = do maybe_hval <- GHC.compileExpr session no_buf_cmd
512 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
513 other -> panic "interactiveUI:setBuffering"
515 maybe_hval <- GHC.compileExpr session flush_cmd
517 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
518 _ -> panic "interactiveUI:flush"
520 turnOffBuffering -- Turn it off right now
525 flushInterpBuffers :: GHCi ()
527 = io $ do Monad.join (readIORef flush_interp)
530 turnOffBuffering :: IO ()
532 = do Monad.join (readIORef turn_off_buffering)
535 -----------------------------------------------------------------------------
538 help :: String -> GHCi ()
539 help _ = io (putStr helpText)
541 info :: String -> GHCi ()
542 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
543 info s = do { let names = words s
544 ; session <- getSession
545 ; dflags <- getDynFlags
546 ; let exts = dopt Opt_GlasgowExts dflags
547 ; mapM_ (infoThing exts session) names }
549 infoThing exts session str = io $ do
550 names <- GHC.parseName session str
551 let filtered = filterOutChildren names
552 mb_stuffs <- mapM (GHC.getInfo session) filtered
553 unqual <- GHC.getPrintUnqual session
554 putStrLn (showSDocForUser unqual $
555 vcat (intersperse (text "") $
556 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
558 -- Filter out names whose parent is also there Good
559 -- example is '[]', which is both a type and data
560 -- constructor in the same type
561 filterOutChildren :: [Name] -> [Name]
562 filterOutChildren names = filter (not . parent_is_there) names
563 where parent_is_there n
564 | Just p <- GHC.nameParent_maybe n = p `elem` names
567 pprInfo exts (thing, fixity, insts)
568 = pprTyThingInContextLoc exts thing
569 $$ show_fixity fixity
570 $$ vcat (map GHC.pprInstance insts)
573 | fix == GHC.defaultFixity = empty
574 | otherwise = ppr fix <+> ppr (GHC.getName thing)
576 -----------------------------------------------------------------------------
579 addModule :: [FilePath] -> GHCi ()
581 io (revertCAFs) -- always revert CAFs on load/add.
582 files <- mapM expandPath files
583 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
584 session <- getSession
585 io (mapM_ (GHC.addTarget session) targets)
586 ok <- io (GHC.load session LoadAllTargets)
589 changeDirectory :: String -> GHCi ()
590 changeDirectory dir = do
591 session <- getSession
592 graph <- io (GHC.getModuleGraph session)
593 when (not (null graph)) $
594 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
595 io (GHC.setTargets session [])
596 io (GHC.load session LoadAllTargets)
597 setContextAfterLoad session []
598 io (GHC.workingDirectoryChanged session)
599 dir <- expandPath dir
600 io (setCurrentDirectory dir)
602 defineMacro :: String -> GHCi ()
604 let (macro_name, definition) = break isSpace s
605 cmds <- io (readIORef commands)
607 then throwDyn (CmdLineError "invalid macro name")
609 if (macro_name `elem` map fst cmds)
610 then throwDyn (CmdLineError
611 ("command '" ++ macro_name ++ "' is already defined"))
614 -- give the expression a type signature, so we can be sure we're getting
615 -- something of the right type.
616 let new_expr = '(' : definition ++ ") :: String -> IO String"
618 -- compile the expression
620 maybe_hv <- io (GHC.compileExpr cms new_expr)
623 Just hv -> io (writeIORef commands --
624 ((macro_name, keepGoing (runMacro hv)) : cmds))
626 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi ()
628 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
629 stringLoop (lines str)
631 undefineMacro :: String -> GHCi ()
632 undefineMacro macro_name = do
633 cmds <- io (readIORef commands)
634 if (macro_name `elem` map fst builtin_commands)
635 then throwDyn (CmdLineError
636 ("command '" ++ macro_name ++ "' cannot be undefined"))
638 if (macro_name `notElem` map fst cmds)
639 then throwDyn (CmdLineError
640 ("command '" ++ macro_name ++ "' not defined"))
642 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
645 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
646 loadModule fs = timeIt (loadModule' fs)
648 loadModule_ :: [FilePath] -> GHCi ()
649 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
651 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
652 loadModule' files = do
653 session <- getSession
656 io (GHC.setTargets session [])
657 io (GHC.load session LoadAllTargets)
660 let (filenames, phases) = unzip files
661 exp_filenames <- mapM expandPath filenames
662 let files' = zip exp_filenames phases
663 targets <- io (mapM (uncurry GHC.guessTarget) files')
665 -- NOTE: we used to do the dependency anal first, so that if it
666 -- fails we didn't throw away the current set of modules. This would
667 -- require some re-working of the GHC interface, so we'll leave it
668 -- as a ToDo for now.
670 io (GHC.setTargets session targets)
671 ok <- io (GHC.load session LoadAllTargets)
675 checkModule :: String -> GHCi ()
677 let modl = mkModule m
678 session <- getSession
679 result <- io (GHC.checkModule session modl)
681 Nothing -> io $ putStrLn "Nothing"
682 Just r -> io $ putStrLn (showSDoc (
683 case checkedModuleInfo r of
684 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
686 (local,global) = partition ((== modl) . GHC.nameModule) scope
688 (text "global names: " <+> ppr global) $$
689 (text "local names: " <+> ppr local)
691 afterLoad (successIf (isJust result)) session
693 reloadModule :: String -> GHCi ()
695 io (revertCAFs) -- always revert CAFs on reload.
696 session <- getSession
697 ok <- io (GHC.load session LoadAllTargets)
700 io (revertCAFs) -- always revert CAFs on reload.
701 session <- getSession
702 ok <- io (GHC.load session (LoadUpTo (mkModule m)))
705 afterLoad ok session = do
706 io (revertCAFs) -- always revert CAFs on load.
707 graph <- io (GHC.getModuleGraph session)
708 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod) graph
709 setContextAfterLoad session graph'
710 modulesLoadedMsg ok (map GHC.ms_mod graph')
712 setContextAfterLoad session [] = do
713 io (GHC.setContext session [] [prelude_mod])
714 setContextAfterLoad session ms = do
715 -- load a target if one is available, otherwise load the topmost module.
716 targets <- io (GHC.getTargets session)
717 case [ m | Just m <- map (findTarget ms) targets ] of
719 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
720 load_this (last graph')
725 = case filter (`matches` t) ms of
729 summary `matches` Target (TargetModule m) _
730 = GHC.ms_mod summary == m
731 summary `matches` Target (TargetFile f _) _
732 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
733 summary `matches` target
736 load_this summary | m <- GHC.ms_mod summary = do
737 b <- io (GHC.moduleIsInterpreted session m)
738 if b then io (GHC.setContext session [m] [])
739 else io (GHC.setContext session [] [prelude_mod,m])
742 modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi ()
743 modulesLoadedMsg ok mods = do
744 dflags <- getDynFlags
745 when (verbosity dflags > 0) $ do
747 | null mods = text "none."
749 punctuate comma (map pprModule mods)) <> text "."
752 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
754 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
757 typeOfExpr :: String -> GHCi ()
759 = do cms <- getSession
760 maybe_ty <- io (GHC.exprType cms str)
763 Just ty -> do ty' <- cleanType ty
764 tystr <- showForUser (ppr ty')
765 io (putStrLn (str ++ " :: " ++ tystr))
767 kindOfType :: String -> GHCi ()
769 = do cms <- getSession
770 maybe_ty <- io (GHC.typeKind cms str)
773 Just ty -> do tystr <- showForUser (ppr ty)
774 io (putStrLn (str ++ " :: " ++ tystr))
776 quit :: String -> GHCi Bool
779 shellEscape :: String -> GHCi Bool
780 shellEscape str = io (system str >> return False)
782 -----------------------------------------------------------------------------
783 -- create tags file for currently loaded modules.
785 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
787 createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
788 createCTagsFileCmd file = ghciCreateTagsFile CTags file
790 createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
791 createETagsFileCmd file = ghciCreateTagsFile ETags file
793 data TagsKind = ETags | CTags
795 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
796 ghciCreateTagsFile kind file = do
797 session <- getSession
798 io $ createTagsFile session kind file
801 -- - remove restriction that all modules must be interpreted
802 -- (problem: we don't know source locations for entities unless
803 -- we compiled the module.
805 -- - extract createTagsFile so it can be used from the command-line
806 -- (probably need to fix first problem before this is useful).
808 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
809 createTagsFile session tagskind tagFile = do
810 graph <- GHC.getModuleGraph session
811 let ms = map GHC.ms_mod graph
813 is_interpreted <- GHC.moduleIsInterpreted session m
814 -- should we just skip these?
815 when (not is_interpreted) $
816 throwDyn (CmdLineError ("module '" ++ moduleString m ++ "' is not interpreted"))
818 mbModInfo <- GHC.getModuleInfo session m
820 | Just modinfo <- mbModInfo,
821 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
822 | otherwise = GHC.alwaysQualify
825 Just modInfo -> return $! listTags unqual modInfo
828 mtags <- mapM tagModule ms
829 either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
831 Left e -> hPutStrLn stderr $ ioeGetErrorString e
834 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
835 listTags unqual modInfo =
836 [ tagInfo unqual name loc
837 | name <- GHC.modInfoExports modInfo
838 , let loc = nameSrcLoc name
842 type TagInfo = (String -- tag name
845 ,Int -- column number
848 -- get tag info, for later translation into Vim or Emacs style
849 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
850 tagInfo unqual name loc
851 = ( showSDocForUser unqual $ pprOccName (nameOccName name)
852 , showSDocForUser unqual $ ftext (srcLocFile loc)
857 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
858 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
859 let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
860 IO.try (writeFile file tags)
861 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
862 let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
863 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
864 tagGroups <- mapM tagFileGroup groups
865 IO.try (writeFile file $ concat tagGroups)
867 tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
868 tagFileGroup group@((_,fileName,_,_):_) = do
869 file <- readFile fileName -- need to get additional info from sources..
870 let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
871 sortedGroup = sortLe byLine group
872 tags = unlines $ perFile sortedGroup 1 0 $ lines file
873 return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
874 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
875 perFile (tagInfo:tags) (count+1) (pos+length line) lines
876 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
877 showETag tagInfo line pos : perFile tags count pos lines
878 perFile tags count pos lines = []
880 -- simple ctags format, for Vim et al
881 showTag :: TagInfo -> String
882 showTag (tag,file,lineNo,colNo)
883 = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
885 -- etags format, for Emacs/XEmacs
886 showETag :: TagInfo -> String -> Int -> String
887 showETag (tag,file,lineNo,colNo) line charPos
888 = take colNo line ++ tag
890 ++ "\x01" ++ show lineNo
891 ++ "," ++ show charPos
893 -----------------------------------------------------------------------------
894 -- Browsing a module's contents
896 browseCmd :: String -> GHCi ()
899 ['*':m] | looksLikeModuleName m -> browseModule m False
900 [m] | looksLikeModuleName m -> browseModule m True
901 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
903 browseModule m exports_only = do
906 let modl = mkModule m
907 is_interpreted <- io (GHC.moduleIsInterpreted s modl)
908 when (not is_interpreted && not exports_only) $
909 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
911 -- Temporarily set the context to the module we're interested in,
912 -- just so we can get an appropriate PrintUnqualified
913 (as,bs) <- io (GHC.getContext s)
914 io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
915 else GHC.setContext s [modl] [])
916 unqual <- io (GHC.getPrintUnqual s)
917 io (GHC.setContext s as bs)
919 mb_mod_info <- io $ GHC.getModuleInfo s modl
921 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
924 | exports_only = GHC.modInfoExports mod_info
925 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
927 filtered = filterOutChildren names
929 things <- io $ mapM (GHC.lookupName s) filtered
931 dflags <- getDynFlags
932 let exts = dopt Opt_GlasgowExts dflags
933 io (putStrLn (showSDocForUser unqual (
934 vcat (map (pprTyThingInContext exts) (catMaybes things))
936 -- ToDo: modInfoInstances currently throws an exception for
937 -- package modules. When it works, we can do this:
938 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
940 -----------------------------------------------------------------------------
941 -- Setting the module context
944 | all sensible mods = fn mods
945 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
947 (fn, mods) = case str of
948 '+':stuff -> (addToContext, words stuff)
949 '-':stuff -> (removeFromContext, words stuff)
950 stuff -> (newContext, words stuff)
952 sensible ('*':m) = looksLikeModuleName m
953 sensible m = looksLikeModuleName m
956 session <- getSession
957 (as,bs) <- separate session mods [] []
958 let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs
959 io (GHC.setContext session as bs')
961 separate :: Session -> [String] -> [Module] -> [Module]
962 -> GHCi ([Module],[Module])
963 separate session [] as bs = return (as,bs)
964 separate session (('*':m):ms) as bs = do
965 let modl = mkModule m
966 b <- io (GHC.moduleIsInterpreted session modl)
967 if b then separate session ms (modl:as) bs
968 else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
969 separate session (m:ms) as bs = separate session ms as (mkModule m:bs)
971 prelude_mod = mkModule "Prelude"
974 addToContext mods = do
976 (as,bs) <- io (GHC.getContext cms)
978 (as',bs') <- separate cms mods [] []
980 let as_to_add = as' \\ (as ++ bs)
981 bs_to_add = bs' \\ (as ++ bs)
983 io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add))
986 removeFromContext mods = do
988 (as,bs) <- io (GHC.getContext cms)
990 (as_to_remove,bs_to_remove) <- separate cms mods [] []
992 let as' = as \\ (as_to_remove ++ bs_to_remove)
993 bs' = bs \\ (as_to_remove ++ bs_to_remove)
995 io (GHC.setContext cms as' bs')
997 ----------------------------------------------------------------------------
1000 -- set options in the interpreter. Syntax is exactly the same as the
1001 -- ghc command line, except that certain options aren't available (-C,
1004 -- This is pretty fragile: most options won't work as expected. ToDo:
1005 -- figure out which ones & disallow them.
1007 setCmd :: String -> GHCi ()
1009 = do st <- getGHCiState
1010 let opts = options st
1011 io $ putStrLn (showSDoc (
1012 text "options currently set: " <>
1015 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1019 ("args":args) -> setArgs args
1020 ("prog":prog) -> setProg prog
1021 wds -> setOptions wds
1025 setGHCiState st{ args = args }
1029 setGHCiState st{ progname = prog }
1031 io (hPutStrLn stderr "syntax: :set prog <progname>")
1034 do -- first, deal with the GHCi opts (+s, +t, etc.)
1035 let (plus_opts, minus_opts) = partition isPlus wds
1036 mapM_ setOpt plus_opts
1038 -- then, dynamic flags
1039 dflags <- getDynFlags
1040 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1043 -- update things if the users wants more packages
1045 let new_packages = pkgs_after \\ pkgs_before
1046 when (not (null new_packages)) $
1047 newPackages new_packages
1050 if (not (null leftovers))
1051 then throwDyn (CmdLineError ("unrecognised flags: " ++
1056 unsetOptions :: String -> GHCi ()
1058 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1059 let opts = words str
1060 (minus_opts, rest1) = partition isMinus opts
1061 (plus_opts, rest2) = partition isPlus rest1
1063 if (not (null rest2))
1064 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1067 mapM_ unsetOpt plus_opts
1069 -- can't do GHC flags for now
1070 if (not (null minus_opts))
1071 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1074 isMinus ('-':s) = True
1077 isPlus ('+':s) = True
1081 = case strToGHCiOpt str of
1082 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1083 Just o -> setOption o
1086 = case strToGHCiOpt str of
1087 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1088 Just o -> unsetOption o
1090 strToGHCiOpt :: String -> (Maybe GHCiOption)
1091 strToGHCiOpt "s" = Just ShowTiming
1092 strToGHCiOpt "t" = Just ShowType
1093 strToGHCiOpt "r" = Just RevertCAFs
1094 strToGHCiOpt _ = Nothing
1096 optToStr :: GHCiOption -> String
1097 optToStr ShowTiming = "s"
1098 optToStr ShowType = "t"
1099 optToStr RevertCAFs = "r"
1102 newPackages new_pkgs = do -- The new packages are already in v_Packages
1103 session <- getSession
1104 io (GHC.setTargets session [])
1105 io (GHC.load session Nothing)
1106 dflags <- getDynFlags
1107 io (linkPackages dflags new_pkgs)
1108 setContextAfterLoad []
1111 -- ---------------------------------------------------------------------------
1116 ["modules" ] -> showModules
1117 ["bindings"] -> showBindings
1118 ["linker"] -> io showLinkerState
1119 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1122 session <- getSession
1123 let show_one ms = do m <- io (GHC.showModule session ms)
1125 graph <- io (GHC.getModuleGraph session)
1126 mapM_ show_one graph
1130 unqual <- io (GHC.getPrintUnqual s)
1131 bindings <- io (GHC.getBindings s)
1132 mapM_ showTyThing bindings
1135 showTyThing (AnId id) = do
1136 ty' <- cleanType (GHC.idType id)
1137 str <- showForUser (ppr id <> text " :: " <> ppr ty')
1139 showTyThing _ = return ()
1141 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1142 cleanType :: Type -> GHCi Type
1144 dflags <- getDynFlags
1145 if dopt Opt_GlasgowExts dflags
1147 else return $! GHC.dropForAlls ty
1149 -----------------------------------------------------------------------------
1152 data GHCiState = GHCiState
1156 session :: GHC.Session,
1157 options :: [GHCiOption]
1161 = ShowTiming -- show time/allocs after evaluation
1162 | ShowType -- show the type of expressions
1163 | RevertCAFs -- revert CAFs after every evaluation
1166 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1168 startGHCi :: GHCi a -> GHCiState -> IO a
1169 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1171 instance Monad GHCi where
1172 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1173 return a = GHCi $ \s -> return a
1175 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1176 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1177 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1179 getGHCiState = GHCi $ \r -> readIORef r
1180 setGHCiState s = GHCi $ \r -> writeIORef r s
1182 -- for convenience...
1183 getSession = getGHCiState >>= return . session
1187 io (GHC.getSessionDynFlags s)
1188 setDynFlags dflags = do
1190 io (GHC.setSessionDynFlags s dflags)
1192 isOptionSet :: GHCiOption -> GHCi Bool
1194 = do st <- getGHCiState
1195 return (opt `elem` options st)
1197 setOption :: GHCiOption -> GHCi ()
1199 = do st <- getGHCiState
1200 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1202 unsetOption :: GHCiOption -> GHCi ()
1204 = do st <- getGHCiState
1205 setGHCiState (st{ options = filter (/= opt) (options st) })
1207 io :: IO a -> GHCi a
1208 io m = GHCi { unGHCi = \s -> m >>= return }
1210 -----------------------------------------------------------------------------
1211 -- recursive exception handlers
1213 -- Don't forget to unblock async exceptions in the handler, or if we're
1214 -- in an exception loop (eg. let a = error a in a) the ^C exception
1215 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1217 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1218 ghciHandle h (GHCi m) = GHCi $ \s ->
1219 Exception.catch (m s)
1220 (\e -> unGHCi (ghciUnblock (h e)) s)
1222 ghciUnblock :: GHCi a -> GHCi a
1223 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1225 -----------------------------------------------------------------------------
1226 -- timing & statistics
1228 timeIt :: GHCi a -> GHCi a
1230 = do b <- isOptionSet ShowTiming
1233 else do allocs1 <- io $ getAllocations
1234 time1 <- io $ getCPUTime
1236 allocs2 <- io $ getAllocations
1237 time2 <- io $ getCPUTime
1238 io $ printTimes (fromIntegral (allocs2 - allocs1))
1242 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1243 -- defined in ghc/rts/Stats.c
1245 printTimes :: Integer -> Integer -> IO ()
1246 printTimes allocs psecs
1247 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1248 secs_str = showFFloat (Just 2) secs
1249 putStrLn (showSDoc (
1250 parens (text (secs_str "") <+> text "secs" <> comma <+>
1251 text (show allocs) <+> text "bytes")))
1253 -----------------------------------------------------------------------------
1260 -- Have to turn off buffering again, because we just
1261 -- reverted stdout, stderr & stdin to their defaults.
1263 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1264 -- Make it "safe", just in case
1266 -- -----------------------------------------------------------------------------
1269 expandPath :: String -> GHCi String
1271 case dropWhile isSpace path of
1273 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1274 return (tilde ++ '/':d)