1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005-2006
8 -----------------------------------------------------------------------------
14 #include "HsVersions.h"
16 #if defined(GHCI) && defined(BREAKPOINT)
17 import GHC.Exts ( Int(..), Ptr(..), int2Addr# )
18 import Foreign.StablePtr ( deRefStablePtr, castPtrToStablePtr )
19 import System.IO.Unsafe ( unsafePerformIO )
32 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
33 Type, Module, ModuleName, TyThing(..), Phase )
46 -- Other random utilities
49 import Panic hiding (showException)
55 #ifndef mingw32_HOST_OS
57 #if __GLASGOW_HASKELL__ > 504
61 import GHC.ConsoleHandler ( flushConsole )
62 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
63 import qualified System.Win32
67 import Control.Concurrent ( yield ) -- Used in readline loop
68 import System.Console.Readline as Readline
73 import Control.Exception as Exception
74 -- import Control.Concurrent
78 import Data.Int ( Int64 )
79 import Data.Maybe ( isJust, isNothing, fromMaybe, catMaybes )
81 import System.Environment
82 import System.Exit ( exitWith, ExitCode(..) )
83 import System.Directory
85 import System.IO.Error as IO
87 import Control.Monad as Monad
88 import Foreign.StablePtr ( newStablePtr )
90 import GHC.Exts ( unsafeCoerce# )
91 import GHC.IOBase ( IOErrorType(InvalidArgument) )
93 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
95 import System.Posix.Internals ( setNonBlockingFD )
97 -----------------------------------------------------------------------------
101 " / _ \\ /\\ /\\/ __(_)\n"++
102 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
103 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
104 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
106 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
107 cmdName (n,_,_,_) = n
109 GLOBAL_VAR(commands, builtin_commands, [Command])
111 builtin_commands :: [Command]
113 ("add", keepGoingPaths addModule, False, completeFilename),
114 ("browse", keepGoing browseCmd, False, completeModule),
115 ("cd", keepGoing changeDirectory, False, completeFilename),
116 ("def", keepGoing defineMacro, False, completeIdentifier),
117 ("e", keepGoing editFile, False, completeFilename),
118 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
119 ("edit", keepGoing editFile, False, completeFilename),
120 ("help", keepGoing help, False, completeNone),
121 ("?", keepGoing help, False, completeNone),
122 ("info", keepGoing info, False, completeIdentifier),
123 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
124 ("module", keepGoing setContext, False, completeModule),
125 ("main", keepGoing runMain, False, completeIdentifier),
126 ("reload", keepGoing reloadModule, False, completeNone),
127 ("check", keepGoing checkModule, False, completeHomeModule),
128 ("set", keepGoing setCmd, True, completeSetOptions),
129 ("show", keepGoing showCmd, False, completeNone),
130 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
131 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
132 ("type", keepGoing typeOfExpr, False, completeIdentifier),
133 ("kind", keepGoing kindOfType, False, completeIdentifier),
134 ("unset", keepGoing unsetOptions, True, completeSetOptions),
135 ("undef", keepGoing undefineMacro, False, completeMacro),
136 ("quit", quit, False, completeNone)
139 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
140 keepGoing a str = a str >> return False
142 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
143 keepGoingPaths a str = a (toArgs str) >> return False
145 shortHelpText = "use :? for help.\n"
147 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
149 " Commands available from the prompt:\n" ++
151 " <stmt> evaluate/run <stmt>\n" ++
152 " :add <filename> ... add module(s) to the current target set\n" ++
153 " :browse [*]<module> display the names defined by <module>\n" ++
154 " :cd <dir> change directory to <dir>\n" ++
155 " :def <cmd> <expr> define a command :<cmd>\n" ++
156 " :edit <file> edit file\n" ++
157 " :edit edit last module\n" ++
158 " :help, :? display this list of commands\n" ++
159 " :info [<name> ...] display information about the given names\n" ++
160 " :load <filename> ... load module(s) and their dependents\n" ++
161 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
162 " :main [<arguments> ...] run the main function with the given arguments\n" ++
163 " :reload reload the current module set\n" ++
165 " :set <option> ... set options\n" ++
166 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
167 " :set prog <progname> set the value returned by System.getProgName\n" ++
168 " :set prompt <prompt> set the prompt used in GHCi\n" ++
169 " :set editor <cmd> set the command used for :edit\n" ++
171 " :show modules show the currently loaded modules\n" ++
172 " :show bindings show the current bindings made at the prompt\n" ++
174 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
175 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
176 " :type <expr> show the type of <expr>\n" ++
177 " :kind <type> show the kind of <type>\n" ++
178 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
179 " :unset <option> ... unset options\n" ++
180 " :quit exit GHCi\n" ++
181 " :!<command> run the shell command <command>\n" ++
183 " Options for ':set' and ':unset':\n" ++
185 " +r revert top-level expressions after each evaluation\n" ++
186 " +s print timing/memory stats after each evaluation\n" ++
187 " +t print type after evaluation\n" ++
188 " -<flags> most GHC command line flags can also be set here\n" ++
189 " (eg. -v2, -fglasgow-exts, etc.)\n"
192 #if defined(GHCI) && defined(BREAKPOINT)
193 globaliseAndTidy :: Id -> Id
195 -- Give the Id a Global Name, and tidy its type
196 = Id.setIdType (globaliseId VanillaGlobal id) tidy_type
198 tidy_type = tidyTopType (idType id)
201 printScopeMsg :: Session -> String -> [Id] -> IO ()
202 printScopeMsg session location ids
203 = GHC.getPrintUnqual session >>= \unqual ->
204 printForUser stdout unqual $
205 text "Local bindings in scope:" $$
206 nest 2 (pprWithCommas showId ids)
207 where showId id = ppr (idName id) <+> dcolon <+> ppr (idType id)
209 jumpCondFunction :: Session -> Int -> [HValue] -> String -> Bool -> b -> b
210 jumpCondFunction session ptr hValues location True b = b
211 jumpCondFunction session ptr hValues location False b
212 = jumpFunction session ptr hValues location b
214 jumpFunction :: Session -> Int -> [HValue] -> String -> b -> b
215 jumpFunction session@(Session ref) (I# idsPtr) hValues location b
217 do ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr)))
218 let names = map idName ids
219 ASSERT (length names == length hValues) return ()
220 printScopeMsg session location ids
221 hsc_env <- readIORef ref
223 let ictxt = hsc_IC hsc_env
224 global_ids = map globaliseAndTidy ids
225 rn_env = ic_rn_local_env ictxt
226 type_env = ic_type_env ictxt
227 bound_names = map idName global_ids
228 new_rn_env = extendLocalRdrEnv rn_env bound_names
229 -- Remove any shadowed bindings from the type_env;
230 -- they are inaccessible but might, I suppose, cause
231 -- a space leak if we leave them there
232 shadowed = [ n | name <- bound_names,
233 let rdr_name = mkRdrUnqual (nameOccName name),
234 Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
235 filtered_type_env = delListFromNameEnv type_env shadowed
236 new_type_env = extendTypeEnvWithIds filtered_type_env global_ids
237 new_ic = ictxt { ic_rn_local_env = new_rn_env,
238 ic_type_env = new_type_env }
239 writeIORef ref (hsc_env { hsc_IC = new_ic })
240 is_tty <- hIsTerminalDevice stdin
241 prel_mod <- GHC.findModule session prel_name Nothing
242 default_editor <- findEditor
243 withExtendedLinkEnv (zip names hValues) $
244 startGHCi (interactiveLoop is_tty True)
245 GHCiState{ progname = "<interactive>",
247 prompt = location++"> ",
248 editor = default_editor,
252 writeIORef ref hsc_env
253 putStrLn $ "Returning to normal execution..."
261 win <- System.Win32.getWindowsDirectory
262 return (win `joinFileName` "notepad.exe")
267 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
268 interactiveUI session srcs maybe_expr = do
269 #if defined(GHCI) && defined(BREAKPOINT)
270 initDynLinker =<< GHC.getSessionDynFlags session
271 extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
272 ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))]
274 -- HACK! If we happen to get into an infinite loop (eg the user
275 -- types 'let x=x in x' at the prompt), then the thread will block
276 -- on a blackhole, and become unreachable during GC. The GC will
277 -- detect that it is unreachable and send it the NonTermination
278 -- exception. However, since the thread is unreachable, everything
279 -- it refers to might be finalized, including the standard Handles.
280 -- This sounds like a bug, but we don't have a good solution right
286 -- Initialise buffering for the *interpreted* I/O system
287 initInterpBuffering session
289 when (isNothing maybe_expr) $ do
290 -- Only for GHCi (not runghc and ghc -e):
291 -- Turn buffering off for the compiled program's stdout/stderr
293 -- Turn buffering off for GHCi's stdout
295 hSetBuffering stdout NoBuffering
296 -- We don't want the cmd line to buffer any input that might be
297 -- intended for the program, so unbuffer stdin.
298 hSetBuffering stdin NoBuffering
300 -- initial context is just the Prelude
301 prel_mod <- GHC.findModule session prel_name Nothing
302 GHC.setContext session [] [prel_mod]
306 Readline.setAttemptedCompletionFunction (Just completeWord)
307 --Readline.parseAndBind "set show-all-if-ambiguous 1"
309 let symbols = "!#$%&*+/<=>?@\\^|-~"
310 specials = "(),;[]`{}"
312 word_break_chars = spaces ++ specials ++ symbols
314 Readline.setBasicWordBreakCharacters word_break_chars
315 Readline.setCompleterWordBreakCharacters word_break_chars
318 default_editor <- findEditor
320 startGHCi (runGHCi srcs maybe_expr)
321 GHCiState{ progname = "<interactive>",
324 editor = default_editor,
330 Readline.resetTerminal Nothing
335 prel_name = GHC.mkModuleName "Prelude"
337 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
338 runGHCi paths maybe_expr = do
339 let read_dot_files = not opt_IgnoreDotGhci
341 when (read_dot_files) $ do
344 exists <- io (doesFileExist file)
346 dir_ok <- io (checkPerms ".")
347 file_ok <- io (checkPerms file)
348 when (dir_ok && file_ok) $ do
349 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
352 Right hdl -> fileLoop hdl False
354 when (read_dot_files) $ do
355 -- Read in $HOME/.ghci
356 either_dir <- io (IO.try (getEnv "HOME"))
360 cwd <- io (getCurrentDirectory)
361 when (dir /= cwd) $ do
362 let file = dir ++ "/.ghci"
363 ok <- io (checkPerms file)
365 either_hdl <- io (IO.try (openFile file ReadMode))
368 Right hdl -> fileLoop hdl False
370 -- Perform a :load for files given on the GHCi command line
371 -- When in -e mode, if the load fails then we want to stop
372 -- immediately rather than going on to evaluate the expression.
373 when (not (null paths)) $ do
374 ok <- ghciHandle (\e -> do showException e; return Failed) $
376 when (isJust maybe_expr && failed ok) $
377 io (exitWith (ExitFailure 1))
379 -- if verbosity is greater than 0, or we are connected to a
380 -- terminal, display the prompt in the interactive loop.
381 is_tty <- io (hIsTerminalDevice stdin)
382 dflags <- getDynFlags
383 let show_prompt = verbosity dflags > 0 || is_tty
388 #if defined(mingw32_HOST_OS)
389 -- The win32 Console API mutates the first character of
390 -- type-ahead when reading from it in a non-buffered manner. Work
391 -- around this by flushing the input buffer of type-ahead characters,
392 -- but only if stdin is available.
393 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
395 Left err | isDoesNotExistError err -> return ()
396 | otherwise -> io (ioError err)
397 Right () -> return ()
399 -- initialise the console if necessary
402 -- enter the interactive loop
403 interactiveLoop is_tty show_prompt
405 -- just evaluate the expression we were given
410 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
413 interactiveLoop is_tty show_prompt =
414 -- Ignore ^C exceptions caught here
415 ghciHandleDyn (\e -> case e of
417 #if defined(mingw32_HOST_OS)
420 interactiveLoop is_tty show_prompt
421 _other -> return ()) $
423 ghciUnblock $ do -- unblock necessary if we recursed from the
424 -- exception handler above.
426 -- read commands from stdin
430 else fileLoop stdin show_prompt
432 fileLoop stdin show_prompt
436 -- NOTE: We only read .ghci files if they are owned by the current user,
437 -- and aren't world writable. Otherwise, we could be accidentally
438 -- running code planted by a malicious third party.
440 -- Furthermore, We only read ./.ghci if . is owned by the current user
441 -- and isn't writable by anyone else. I think this is sufficient: we
442 -- don't need to check .. and ../.. etc. because "." always refers to
443 -- the same directory while a process is running.
445 checkPerms :: String -> IO Bool
447 #ifdef mingw32_HOST_OS
450 Util.handle (\_ -> return False) $ do
451 st <- getFileStatus name
453 if fileOwner st /= me then do
454 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
457 let mode = fileMode st
458 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
459 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
461 putStrLn $ "*** WARNING: " ++ name ++
462 " is writable by someone else, IGNORING!"
467 fileLoop :: Handle -> Bool -> GHCi ()
468 fileLoop hdl show_prompt = do
469 session <- getSession
470 (mod,imports) <- io (GHC.getContext session)
472 when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
473 l <- io (IO.try (hGetLine hdl))
475 Left e | isEOFError e -> return ()
476 | InvalidArgument <- etype -> return ()
477 | otherwise -> io (ioError e)
478 where etype = ioeGetErrorType e
479 -- treat InvalidArgument in the same way as EOF:
480 -- this can happen if the user closed stdin, or
481 -- perhaps did getContents which closes stdin at
484 case removeSpaces l of
485 "" -> fileLoop hdl show_prompt
486 l -> do quit <- runCommand l
487 if quit then return () else fileLoop hdl show_prompt
489 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
490 stringLoop [] = return False
491 stringLoop (s:ss) = do
492 case removeSpaces s of
494 l -> do quit <- runCommand l
495 if quit then return True else stringLoop ss
497 mkPrompt toplevs exports prompt
498 = showSDoc $ f prompt
500 f ('%':'s':xs) = perc_s <> f xs
501 f ('%':'%':xs) = char '%' <> f xs
502 f (x:xs) = char x <> f xs
505 perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
506 hsep (map (ppr . GHC.moduleName) exports)
510 readlineLoop :: GHCi ()
512 session <- getSession
513 (mod,imports) <- io (GHC.getContext session)
515 saveSession -- for use by completion
517 l <- io (readline (mkPrompt mod imports (prompt st))
518 `finally` setNonBlockingFD 0)
519 -- readline sometimes puts stdin into blocking mode,
520 -- so we need to put it back for the IO library
525 case removeSpaces l of
530 if quit then return () else readlineLoop
533 runCommand :: String -> GHCi Bool
534 runCommand c = ghciHandle handler (doCommand c)
536 doCommand (':' : command) = specialCommand command
538 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
541 -- This version is for the GHC command-line option -e. The only difference
542 -- from runCommand is that it catches the ExitException exception and
543 -- exits, rather than printing out the exception.
544 runCommandEval c = ghciHandle handleEval (doCommand c)
546 handleEval (ExitException code) = io (exitWith code)
547 handleEval e = do handler e
548 io (exitWith (ExitFailure 1))
550 doCommand (':' : command) = specialCommand command
552 = do nms <- runStmt stmt
554 Nothing -> io (exitWith (ExitFailure 1))
555 -- failure to run the command causes exit(1) for ghc -e.
556 _ -> finishEvalExpr nms
558 runStmt :: String -> GHCi (Maybe [Name])
560 | null (filter (not.isSpace) stmt) = return (Just [])
562 = do st <- getGHCiState
563 session <- getSession
564 result <- io $ withProgName (progname st) $ withArgs (args st) $
565 GHC.runStmt session stmt
567 GHC.RunFailed -> return Nothing
568 GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
569 GHC.RunOk names -> return (Just names)
571 -- possibly print the type and revert CAFs after evaluating an expression
572 finishEvalExpr mb_names
573 = do b <- isOptionSet ShowType
574 session <- getSession
577 Just names -> when b (mapM_ (showTypeOfName session) names)
580 io installSignalHandlers
581 b <- isOptionSet RevertCAFs
582 io (when b revertCAFs)
585 showTypeOfName :: Session -> Name -> GHCi ()
586 showTypeOfName session n
587 = do maybe_tything <- io (GHC.lookupName session n)
588 case maybe_tything of
590 Just thing -> showTyThing thing
592 specialCommand :: String -> GHCi Bool
593 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
594 specialCommand str = do
595 let (cmd,rest) = break isSpace str
596 maybe_cmd <- io (lookupCommand cmd)
598 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
599 ++ shortHelpText) >> return False)
600 Just (_,f,_,_) -> f (dropWhile isSpace rest)
602 lookupCommand :: String -> IO (Maybe Command)
603 lookupCommand str = do
604 cmds <- readIORef commands
605 -- look for exact match first, then the first prefix match
606 case [ c | c <- cmds, str == cmdName c ] of
607 c:_ -> return (Just c)
608 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
610 c:_ -> return (Just c)
612 -----------------------------------------------------------------------------
615 help :: String -> GHCi ()
616 help _ = io (putStr helpText)
618 info :: String -> GHCi ()
619 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
620 info s = do { let names = words s
621 ; session <- getSession
622 ; dflags <- getDynFlags
623 ; let exts = dopt Opt_GlasgowExts dflags
624 ; mapM_ (infoThing exts session) names }
626 infoThing exts session str = io $ do
627 names <- GHC.parseName session str
628 let filtered = filterOutChildren names
629 mb_stuffs <- mapM (GHC.getInfo session) filtered
630 unqual <- GHC.getPrintUnqual session
631 putStrLn (showSDocForUser unqual $
632 vcat (intersperse (text "") $
633 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
635 -- Filter out names whose parent is also there Good
636 -- example is '[]', which is both a type and data
637 -- constructor in the same type
638 filterOutChildren :: [Name] -> [Name]
639 filterOutChildren names = filter (not . parent_is_there) names
640 where parent_is_there n
641 -- | Just p <- GHC.nameParent_maybe n = p `elem` names
645 pprInfo exts (thing, fixity, insts)
646 = pprTyThingInContextLoc exts thing
647 $$ show_fixity fixity
648 $$ vcat (map GHC.pprInstance insts)
651 | fix == GHC.defaultFixity = empty
652 | otherwise = ppr fix <+> ppr (GHC.getName thing)
654 -----------------------------------------------------------------------------
657 runMain :: String -> GHCi ()
659 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
660 runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
663 addModule :: [FilePath] -> GHCi ()
665 io (revertCAFs) -- always revert CAFs on load/add.
666 files <- mapM expandPath files
667 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
668 session <- getSession
669 io (mapM_ (GHC.addTarget session) targets)
670 ok <- io (GHC.load session LoadAllTargets)
673 changeDirectory :: String -> GHCi ()
674 changeDirectory dir = do
675 session <- getSession
676 graph <- io (GHC.getModuleGraph session)
677 when (not (null graph)) $
678 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
679 io (GHC.setTargets session [])
680 io (GHC.load session LoadAllTargets)
681 setContextAfterLoad session []
682 io (GHC.workingDirectoryChanged session)
683 dir <- expandPath dir
684 io (setCurrentDirectory dir)
686 editFile :: String -> GHCi ()
689 -- find the name of the "topmost" file loaded
690 session <- getSession
691 graph0 <- io (GHC.getModuleGraph session)
692 graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
693 let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
694 case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
695 Just file -> do_edit file
696 Nothing -> throwDyn (CmdLineError "unknown file name")
697 | otherwise = do_edit str
703 throwDyn (CmdLineError "editor not set, use :set editor")
704 io $ system (cmd ++ ' ':file)
707 defineMacro :: String -> GHCi ()
709 let (macro_name, definition) = break isSpace s
710 cmds <- io (readIORef commands)
712 then throwDyn (CmdLineError "invalid macro name")
714 if (macro_name `elem` map cmdName cmds)
715 then throwDyn (CmdLineError
716 ("command '" ++ macro_name ++ "' is already defined"))
719 -- give the expression a type signature, so we can be sure we're getting
720 -- something of the right type.
721 let new_expr = '(' : definition ++ ") :: String -> IO String"
723 -- compile the expression
725 maybe_hv <- io (GHC.compileExpr cms new_expr)
728 Just hv -> io (writeIORef commands --
729 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
731 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
733 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
734 stringLoop (lines str)
736 undefineMacro :: String -> GHCi ()
737 undefineMacro macro_name = do
738 cmds <- io (readIORef commands)
739 if (macro_name `elem` map cmdName builtin_commands)
740 then throwDyn (CmdLineError
741 ("command '" ++ macro_name ++ "' cannot be undefined"))
743 if (macro_name `notElem` map cmdName cmds)
744 then throwDyn (CmdLineError
745 ("command '" ++ macro_name ++ "' not defined"))
747 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
750 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
751 loadModule fs = timeIt (loadModule' fs)
753 loadModule_ :: [FilePath] -> GHCi ()
754 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
756 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
757 loadModule' files = do
758 session <- getSession
761 io (GHC.setTargets session [])
762 io (GHC.load session LoadAllTargets)
765 let (filenames, phases) = unzip files
766 exp_filenames <- mapM expandPath filenames
767 let files' = zip exp_filenames phases
768 targets <- io (mapM (uncurry GHC.guessTarget) files')
770 -- NOTE: we used to do the dependency anal first, so that if it
771 -- fails we didn't throw away the current set of modules. This would
772 -- require some re-working of the GHC interface, so we'll leave it
773 -- as a ToDo for now.
775 io (GHC.setTargets session targets)
776 ok <- io (GHC.load session LoadAllTargets)
780 checkModule :: String -> GHCi ()
782 let modl = GHC.mkModuleName m
783 session <- getSession
784 result <- io (GHC.checkModule session modl)
786 Nothing -> io $ putStrLn "Nothing"
787 Just r -> io $ putStrLn (showSDoc (
788 case GHC.checkedModuleInfo r of
789 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
791 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
793 (text "global names: " <+> ppr global) $$
794 (text "local names: " <+> ppr local)
796 afterLoad (successIf (isJust result)) session
798 reloadModule :: String -> GHCi ()
800 io (revertCAFs) -- always revert CAFs on reload.
801 session <- getSession
802 ok <- io (GHC.load session LoadAllTargets)
805 io (revertCAFs) -- always revert CAFs on reload.
806 session <- getSession
807 ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
810 afterLoad ok session = do
811 io (revertCAFs) -- always revert CAFs on load.
812 graph <- io (GHC.getModuleGraph session)
813 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
814 setContextAfterLoad session graph'
815 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
816 #if defined(GHCI) && defined(BREAKPOINT)
817 io (extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
818 ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))])
821 setContextAfterLoad session [] = do
822 prel_mod <- getPrelude
823 io (GHC.setContext session [] [prel_mod])
824 setContextAfterLoad session ms = do
825 -- load a target if one is available, otherwise load the topmost module.
826 targets <- io (GHC.getTargets session)
827 case [ m | Just m <- map (findTarget ms) targets ] of
829 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
830 load_this (last graph')
835 = case filter (`matches` t) ms of
839 summary `matches` Target (TargetModule m) _
840 = GHC.ms_mod_name summary == m
841 summary `matches` Target (TargetFile f _) _
842 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
843 summary `matches` target
846 load_this summary | m <- GHC.ms_mod summary = do
847 b <- io (GHC.moduleIsInterpreted session m)
848 if b then io (GHC.setContext session [m] [])
850 prel_mod <- getPrelude
851 io (GHC.setContext session [] [prel_mod,m])
854 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
855 modulesLoadedMsg ok mods = do
856 dflags <- getDynFlags
857 when (verbosity dflags > 0) $ do
859 | null mods = text "none."
861 punctuate comma (map ppr mods)) <> text "."
864 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
866 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
869 typeOfExpr :: String -> GHCi ()
871 = do cms <- getSession
872 maybe_ty <- io (GHC.exprType cms str)
875 Just ty -> do ty' <- cleanType ty
876 tystr <- showForUser (ppr ty')
877 io (putStrLn (str ++ " :: " ++ tystr))
879 kindOfType :: String -> GHCi ()
881 = do cms <- getSession
882 maybe_ty <- io (GHC.typeKind cms str)
885 Just ty -> do tystr <- showForUser (ppr ty)
886 io (putStrLn (str ++ " :: " ++ tystr))
888 quit :: String -> GHCi Bool
891 shellEscape :: String -> GHCi Bool
892 shellEscape str = io (system str >> return False)
894 -----------------------------------------------------------------------------
895 -- create tags file for currently loaded modules.
897 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
899 createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
900 createCTagsFileCmd file = ghciCreateTagsFile CTags file
902 createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
903 createETagsFileCmd file = ghciCreateTagsFile ETags file
905 data TagsKind = ETags | CTags
907 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
908 ghciCreateTagsFile kind file = do
909 session <- getSession
910 io $ createTagsFile session kind file
913 -- - remove restriction that all modules must be interpreted
914 -- (problem: we don't know source locations for entities unless
915 -- we compiled the module.
917 -- - extract createTagsFile so it can be used from the command-line
918 -- (probably need to fix first problem before this is useful).
920 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
921 createTagsFile session tagskind tagFile = do
922 graph <- GHC.getModuleGraph session
923 let ms = map GHC.ms_mod graph
925 is_interpreted <- GHC.moduleIsInterpreted session m
926 -- should we just skip these?
927 when (not is_interpreted) $
928 throwDyn (CmdLineError ("module '"
929 ++ GHC.moduleNameString (GHC.moduleName m)
930 ++ "' is not interpreted"))
931 mbModInfo <- GHC.getModuleInfo session m
933 | Just modinfo <- mbModInfo,
934 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
935 | otherwise = GHC.alwaysQualify
938 Just modInfo -> return $! listTags unqual modInfo
941 mtags <- mapM tagModule ms
942 either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
944 Left e -> hPutStrLn stderr $ ioeGetErrorString e
947 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
948 listTags unqual modInfo =
949 [ tagInfo unqual name loc
950 | name <- GHC.modInfoExports modInfo
951 , let loc = nameSrcLoc name
955 type TagInfo = (String -- tag name
958 ,Int -- column number
961 -- get tag info, for later translation into Vim or Emacs style
962 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
963 tagInfo unqual name loc
964 = ( showSDocForUser unqual $ pprOccName (nameOccName name)
965 , showSDocForUser unqual $ ftext (srcLocFile loc)
970 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
971 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
972 let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
973 IO.try (writeFile file tags)
974 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
975 let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
976 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
977 tagGroups <- mapM tagFileGroup groups
978 IO.try (writeFile file $ concat tagGroups)
980 tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
981 tagFileGroup group@((_,fileName,_,_):_) = do
982 file <- readFile fileName -- need to get additional info from sources..
983 let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
984 sortedGroup = sortLe byLine group
985 tags = unlines $ perFile sortedGroup 1 0 $ lines file
986 return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
987 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
988 perFile (tagInfo:tags) (count+1) (pos+length line) lines
989 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
990 showETag tagInfo line pos : perFile tags count pos lines
991 perFile tags count pos lines = []
993 -- simple ctags format, for Vim et al
994 showTag :: TagInfo -> String
995 showTag (tag,file,lineNo,colNo)
996 = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
998 -- etags format, for Emacs/XEmacs
999 showETag :: TagInfo -> String -> Int -> String
1000 showETag (tag,file,lineNo,colNo) line charPos
1001 = take colNo line ++ tag
1003 ++ "\x01" ++ show lineNo
1004 ++ "," ++ show charPos
1006 -----------------------------------------------------------------------------
1007 -- Browsing a module's contents
1009 browseCmd :: String -> GHCi ()
1012 ['*':m] | looksLikeModuleName m -> browseModule m False
1013 [m] | looksLikeModuleName m -> browseModule m True
1014 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1016 browseModule m exports_only = do
1018 modl <- io $ GHC.findModule s (GHC.mkModuleName m) Nothing
1019 is_interpreted <- io (GHC.moduleIsInterpreted s modl)
1020 when (not is_interpreted && not exports_only) $
1021 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
1023 -- Temporarily set the context to the module we're interested in,
1024 -- just so we can get an appropriate PrintUnqualified
1025 (as,bs) <- io (GHC.getContext s)
1026 prel_mod <- getPrelude
1027 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1028 else GHC.setContext s [modl] [])
1029 unqual <- io (GHC.getPrintUnqual s)
1030 io (GHC.setContext s as bs)
1032 mb_mod_info <- io $ GHC.getModuleInfo s modl
1034 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1037 | exports_only = GHC.modInfoExports mod_info
1038 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
1040 filtered = filterOutChildren names
1042 things <- io $ mapM (GHC.lookupName s) filtered
1044 dflags <- getDynFlags
1045 let exts = dopt Opt_GlasgowExts dflags
1046 io (putStrLn (showSDocForUser unqual (
1047 vcat (map (pprTyThingInContext exts) (catMaybes things))
1049 -- ToDo: modInfoInstances currently throws an exception for
1050 -- package modules. When it works, we can do this:
1051 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1053 -----------------------------------------------------------------------------
1054 -- Setting the module context
1057 | all sensible mods = fn mods
1058 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1060 (fn, mods) = case str of
1061 '+':stuff -> (addToContext, words stuff)
1062 '-':stuff -> (removeFromContext, words stuff)
1063 stuff -> (newContext, words stuff)
1065 sensible ('*':m) = looksLikeModuleName m
1066 sensible m = looksLikeModuleName m
1068 separate :: Session -> [String] -> [Module] -> [Module]
1069 -> GHCi ([Module],[Module])
1070 separate session [] as bs = return (as,bs)
1071 separate session (('*':str):ms) as bs = do
1072 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1073 b <- io $ GHC.moduleIsInterpreted session m
1074 if b then separate session ms (m:as) bs
1075 else throwDyn (CmdLineError ("module '"
1076 ++ GHC.moduleNameString (GHC.moduleName m)
1077 ++ "' is not interpreted"))
1078 separate session (str:ms) as bs = do
1079 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1080 separate session ms as (m:bs)
1082 newContext :: [String] -> GHCi ()
1083 newContext strs = do
1085 (as,bs) <- separate s strs [] []
1086 prel_mod <- getPrelude
1087 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1088 io $ GHC.setContext s as bs'
1091 addToContext :: [String] -> GHCi ()
1092 addToContext strs = do
1094 (as,bs) <- io $ GHC.getContext s
1096 (new_as,new_bs) <- separate s strs [] []
1098 let as_to_add = new_as \\ (as ++ bs)
1099 bs_to_add = new_bs \\ (as ++ bs)
1101 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1104 removeFromContext :: [String] -> GHCi ()
1105 removeFromContext strs = do
1107 (as,bs) <- io $ GHC.getContext s
1109 (as_to_remove,bs_to_remove) <- separate s strs [] []
1111 let as' = as \\ (as_to_remove ++ bs_to_remove)
1112 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1114 io $ GHC.setContext s as' bs'
1116 ----------------------------------------------------------------------------
1119 -- set options in the interpreter. Syntax is exactly the same as the
1120 -- ghc command line, except that certain options aren't available (-C,
1123 -- This is pretty fragile: most options won't work as expected. ToDo:
1124 -- figure out which ones & disallow them.
1126 setCmd :: String -> GHCi ()
1128 = do st <- getGHCiState
1129 let opts = options st
1130 io $ putStrLn (showSDoc (
1131 text "options currently set: " <>
1134 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1137 = case toArgs str of
1138 ("args":args) -> setArgs args
1139 ("prog":prog) -> setProg prog
1140 ("prompt":prompt) -> setPrompt (after 6)
1141 ("editor":cmd) -> setEditor (after 6)
1142 wds -> setOptions wds
1143 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1147 setGHCiState st{ args = args }
1151 setGHCiState st{ progname = prog }
1153 io (hPutStrLn stderr "syntax: :set prog <progname>")
1157 setGHCiState st{ editor = cmd }
1159 setPrompt value = do
1162 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1163 else setGHCiState st{ prompt = remQuotes value }
1165 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1169 do -- first, deal with the GHCi opts (+s, +t, etc.)
1170 let (plus_opts, minus_opts) = partition isPlus wds
1171 mapM_ setOpt plus_opts
1173 -- then, dynamic flags
1174 dflags <- getDynFlags
1175 let pkg_flags = packageFlags dflags
1176 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1178 if (not (null leftovers))
1179 then throwDyn (CmdLineError ("unrecognised flags: " ++
1183 new_pkgs <- setDynFlags dflags'
1185 -- if the package flags changed, we should reset the context
1186 -- and link the new packages.
1187 dflags <- getDynFlags
1188 when (packageFlags dflags /= pkg_flags) $ do
1189 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1190 session <- getSession
1191 io (GHC.setTargets session [])
1192 io (GHC.load session LoadAllTargets)
1193 io (linkPackages dflags new_pkgs)
1194 setContextAfterLoad session []
1198 unsetOptions :: String -> GHCi ()
1200 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1201 let opts = words str
1202 (minus_opts, rest1) = partition isMinus opts
1203 (plus_opts, rest2) = partition isPlus rest1
1205 if (not (null rest2))
1206 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1209 mapM_ unsetOpt plus_opts
1211 -- can't do GHC flags for now
1212 if (not (null minus_opts))
1213 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1216 isMinus ('-':s) = True
1219 isPlus ('+':s) = True
1223 = case strToGHCiOpt str of
1224 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1225 Just o -> setOption o
1228 = case strToGHCiOpt str of
1229 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1230 Just o -> unsetOption o
1232 strToGHCiOpt :: String -> (Maybe GHCiOption)
1233 strToGHCiOpt "s" = Just ShowTiming
1234 strToGHCiOpt "t" = Just ShowType
1235 strToGHCiOpt "r" = Just RevertCAFs
1236 strToGHCiOpt _ = Nothing
1238 optToStr :: GHCiOption -> String
1239 optToStr ShowTiming = "s"
1240 optToStr ShowType = "t"
1241 optToStr RevertCAFs = "r"
1243 -- ---------------------------------------------------------------------------
1248 ["modules" ] -> showModules
1249 ["bindings"] -> showBindings
1250 ["linker"] -> io showLinkerState
1251 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1254 session <- getSession
1255 let show_one ms = do m <- io (GHC.showModule session ms)
1257 graph <- io (GHC.getModuleGraph session)
1258 mapM_ show_one graph
1262 unqual <- io (GHC.getPrintUnqual s)
1263 bindings <- io (GHC.getBindings s)
1264 mapM_ showTyThing bindings
1267 showTyThing (AnId id) = do
1268 ty' <- cleanType (GHC.idType id)
1269 str <- showForUser (ppr id <> text " :: " <> ppr ty')
1271 showTyThing _ = return ()
1273 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1274 cleanType :: Type -> GHCi Type
1276 dflags <- getDynFlags
1277 if dopt Opt_GlasgowExts dflags
1279 else return $! GHC.dropForAlls ty
1281 -- -----------------------------------------------------------------------------
1284 completeNone :: String -> IO [String]
1285 completeNone w = return []
1288 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1289 completeWord w start end = do
1290 line <- Readline.getLineBuffer
1292 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1294 | Just c <- is_cmd line -> do
1295 maybe_cmd <- lookupCommand c
1296 let (n,w') = selectWord (words' 0 line)
1298 Nothing -> return Nothing
1299 Just (_,_,False,complete) -> wrapCompleter complete w
1300 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1301 return (map (drop n) rets)
1302 in wrapCompleter complete' w'
1304 --printf "complete %s, start = %d, end = %d\n" w start end
1305 wrapCompleter completeIdentifier w
1306 where words' _ [] = []
1307 words' n str = let (w,r) = break isSpace str
1308 (s,r') = span isSpace r
1309 in (n,w):words' (n+length w+length s) r'
1310 -- In a Haskell expression we want to parse 'a-b' as three words
1311 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1312 -- only be a single word.
1313 selectWord [] = (0,w)
1314 selectWord ((offset,x):xs)
1315 | offset+length x >= start = (start-offset,take (end-offset) x)
1316 | otherwise = selectWord xs
1319 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1320 | otherwise = Nothing
1323 cmds <- readIORef commands
1324 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1326 completeMacro w = do
1327 cmds <- readIORef commands
1328 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1329 return (filter (w `isPrefixOf`) cmds')
1331 completeIdentifier w = do
1333 rdrs <- GHC.getRdrNamesInScope s
1334 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1336 completeModule w = do
1338 dflags <- GHC.getSessionDynFlags s
1339 let pkg_mods = allExposedModules dflags
1340 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1342 completeHomeModule w = do
1344 g <- GHC.getModuleGraph s
1345 let home_mods = map GHC.ms_mod_name g
1346 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1348 completeSetOptions w = do
1349 return (filter (w `isPrefixOf`) options)
1350 where options = "args":"prog":allFlags
1352 completeFilename = Readline.filenameCompletionFunction
1354 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1356 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1357 unionComplete f1 f2 w = do
1362 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1363 wrapCompleter fun w = do
1366 [] -> return Nothing
1367 [x] -> return (Just (x,[]))
1368 xs -> case getCommonPrefix xs of
1369 "" -> return (Just ("",xs))
1370 pref -> return (Just (pref,xs))
1372 getCommonPrefix :: [String] -> String
1373 getCommonPrefix [] = ""
1374 getCommonPrefix (s:ss) = foldl common s ss
1375 where common s "" = s
1377 common (c:cs) (d:ds)
1378 | c == d = c : common cs ds
1381 allExposedModules :: DynFlags -> [ModuleName]
1382 allExposedModules dflags
1383 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1385 pkg_db = pkgIdMap (pkgState dflags)
1387 completeCmd = completeNone
1388 completeMacro = completeNone
1389 completeIdentifier = completeNone
1390 completeModule = completeNone
1391 completeHomeModule = completeNone
1392 completeSetOptions = completeNone
1393 completeFilename = completeNone
1394 completeHomeModuleOrFile=completeNone
1397 -- ----------------------------------------------------------------------------
1400 expandPath :: String -> GHCi String
1402 case dropWhile isSpace path of
1404 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1405 return (tilde ++ '/':d)
1409 -- ----------------------------------------------------------------------------
1410 -- Windows console setup
1412 setUpConsole :: IO ()
1414 #ifdef mingw32_HOST_OS
1415 -- On Windows we need to set a known code page, otherwise the characters
1416 -- we read from the console will be be in some strange encoding, and
1417 -- similarly for characters we write to the console.
1419 -- At the moment, GHCi pretends all input is Latin-1. In the
1420 -- future we should support UTF-8, but for now we set the code pages
1423 -- It seems you have to set the font in the console window to
1424 -- a Unicode font in order for output to work properly,
1425 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1426 -- (see MSDN for SetConsoleOutputCP()).
1428 setConsoleCP 28591 -- ISO Latin-1
1429 setConsoleOutputCP 28591 -- ISO Latin-1