1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005-2006
8 -----------------------------------------------------------------------------
14 #include "HsVersions.h"
20 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
21 Type, Module, ModuleName, TyThing(..), Phase )
34 -- Other random utilities
36 import BasicTypes hiding (isTopLevel)
37 import Panic hiding (showException)
45 import Debugger hiding ( addModule )
48 import Var ( globaliseId )
56 #ifndef mingw32_HOST_OS
58 #if __GLASGOW_HASKELL__ > 504
62 import GHC.ConsoleHandler ( flushConsole )
63 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
64 import qualified System.Win32
68 import Control.Concurrent ( yield ) -- Used in readline loop
69 import System.Console.Readline as Readline
74 import Control.Exception as Exception
75 -- import Control.Concurrent
79 import Data.Int ( Int64 )
80 import Data.Maybe ( isJust, isNothing, fromMaybe, catMaybes )
82 import System.Environment
83 import System.Exit ( exitWith, ExitCode(..) )
84 import System.Directory
86 import System.IO.Error as IO
89 import Control.Monad as Monad
90 import Foreign.StablePtr ( newStablePtr )
92 import GHC.Exts ( unsafeCoerce# )
93 import GHC.IOBase ( IOErrorType(InvalidArgument) )
95 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
97 import System.Posix.Internals ( setNonBlockingFD )
99 -----------------------------------------------------------------------------
103 " / _ \\ /\\ /\\/ __(_)\n"++
104 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
105 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
106 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
108 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
109 cmdName (n,_,_,_) = n
111 GLOBAL_VAR(commands, builtin_commands, [Command])
113 builtin_commands :: [Command]
115 ("add", tlC$ keepGoingPaths addModule, False, completeFilename),
116 ("browse", keepGoing browseCmd, False, completeModule),
118 -- I think that :c should mean :continue rather than :cd, makes more sense
120 ("continue", const(bkptOptions "continue"), False, completeNone),
122 ("cd", tlC$ keepGoing changeDirectory, False, completeFilename),
123 ("def", keepGoing defineMacro, False, completeIdentifier),
124 ("e", keepGoing editFile, False, completeFilename),
125 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
126 ("edit", keepGoing editFile, False, completeFilename),
127 ("help", keepGoing help, False, completeNone),
128 ("?", keepGoing help, False, completeNone),
129 ("info", keepGoing info, False, completeIdentifier),
130 ("load", tlC$ keepGoingPaths loadModule_,False, completeHomeModuleOrFile),
131 ("module", keepGoing setContext, False, completeModule),
132 ("main", tlC$ keepGoing runMain, False, completeIdentifier),
133 ("reload", tlC$ keepGoing reloadModule, False, completeNone),
134 ("check", keepGoing checkModule, False, completeHomeModule),
135 ("set", keepGoing setCmd, True, completeSetOptions),
136 ("show", keepGoing showCmd, False, completeNone),
137 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
138 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
139 ("type", keepGoing typeOfExpr, False, completeIdentifier),
140 #if defined(DEBUGGER)
141 ("print", keepGoing (pprintClosureCommand True False), False, completeIdentifier),
142 ("sprint", keepGoing (pprintClosureCommand False False),False, completeIdentifier),
143 ("force", keepGoing (pprintClosureCommand False True), False, completeIdentifier),
144 ("breakpoint",bkptOptions, False, completeBkpt),
146 ("kind", keepGoing kindOfType, False, completeIdentifier),
147 ("unset", keepGoing unsetOptions, True, completeSetOptions),
148 ("undef", keepGoing undefineMacro, False, completeMacro),
149 ("quit", quit, False, completeNone)
152 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
153 keepGoing a str = a str >> return False
155 -- tlC: Top Level Command, not allowed in inferior sessions
156 tlC :: (String -> GHCi Bool) -> (String -> GHCi Bool)
158 top_level <- isTopLevel
160 then throwDyn (CmdLineError "Command only allowed at Top Level")
163 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
164 keepGoingPaths a str = a (toArgs str) >> return False
166 shortHelpText = "use :? for help.\n"
168 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
170 " Commands available from the prompt:\n" ++
172 " <stmt> evaluate/run <stmt>\n" ++
173 " :add <filename> ... add module(s) to the current target set\n" ++
174 " :breakpoint <option> commands for the GHCi debugger\n" ++
175 " :browse [*]<module> display the names defined by <module>\n" ++
176 " :cd <dir> change directory to <dir>\n" ++
177 " :continue equivalent to ':breakpoint continue'\n" ++
178 " :def <cmd> <expr> define a command :<cmd>\n" ++
179 " :edit <file> edit file\n" ++
180 " :edit edit last module\n" ++
181 " :help, :? display this list of commands\n" ++
182 " :info [<name> ...] display information about the given names\n" ++
183 " :print [<name> ...] prints a value without forcing its computation\n" ++
184 " :sprint [<name> ...] simplified version of :print\n" ++
185 " :load <filename> ... load module(s) and their dependents\n" ++
186 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
187 " :main [<arguments> ...] run the main function with the given arguments\n" ++
188 " :reload reload the current module set\n" ++
190 " :set <option> ... set options\n" ++
191 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
192 " :set prog <progname> set the value returned by System.getProgName\n" ++
193 " :set prompt <prompt> set the prompt used in GHCi\n" ++
194 " :set editor <cmd> set the command used for :edit\n" ++
196 " :show modules show the currently loaded modules\n" ++
197 " :show bindings show the current bindings made at the prompt\n" ++
199 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
200 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
201 " :type <expr> show the type of <expr>\n" ++
202 " :kind <type> show the kind of <type>\n" ++
203 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
204 " :unset <option> ... unset options\n" ++
205 " :quit exit GHCi\n" ++
206 " :!<command> run the shell command <command>\n" ++
208 " Options for ':set' and ':unset':\n" ++
210 " +r revert top-level expressions after each evaluation\n" ++
211 " +s print timing/memory stats after each evaluation\n" ++
212 " +t print type after evaluation\n" ++
213 " -<flags> most GHC command line flags can also be set here\n" ++
214 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
216 " Options for ':breakpoint':\n" ++
217 " list list the current breakpoints\n" ++
218 " add Module line [col] add a new breakpoint\n" ++
219 " del (breakpoint# | Module line [col]) delete a breakpoint\n" ++
220 " continue continue execution\n" ++
221 " stop Stop a computation and return to the top level\n" ++
222 " step [count] Step by step execution (DISABLED)\n"
228 win <- System.Win32.getWindowsDirectory
229 return (win `joinFileName` "notepad.exe")
234 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
235 interactiveUI session srcs maybe_expr = do
236 -- HACK! If we happen to get into an infinite loop (eg the user
237 -- types 'let x=x in x' at the prompt), then the thread will block
238 -- on a blackhole, and become unreachable during GC. The GC will
239 -- detect that it is unreachable and send it the NonTermination
240 -- exception. However, since the thread is unreachable, everything
241 -- it refers to might be finalized, including the standard Handles.
242 -- This sounds like a bug, but we don't have a good solution right
248 -- Initialise buffering for the *interpreted* I/O system
249 initInterpBuffering session
251 when (isNothing maybe_expr) $ do
252 -- Only for GHCi (not runghc and ghc -e):
253 -- Turn buffering off for the compiled program's stdout/stderr
255 -- Turn buffering off for GHCi's stdout
257 hSetBuffering stdout NoBuffering
258 -- We don't want the cmd line to buffer any input that might be
259 -- intended for the program, so unbuffer stdin.
260 hSetBuffering stdin NoBuffering
262 -- initial context is just the Prelude
263 prel_mod <- GHC.findModule session prel_name Nothing
264 GHC.setContext session [] [prel_mod]
268 Readline.setAttemptedCompletionFunction (Just completeWord)
269 --Readline.parseAndBind "set show-all-if-ambiguous 1"
271 let symbols = "!#$%&*+/<=>?@\\^|-~"
272 specials = "(),;[]`{}"
274 word_break_chars = spaces ++ specials ++ symbols
276 Readline.setBasicWordBreakCharacters word_break_chars
277 Readline.setCompleterWordBreakCharacters word_break_chars
280 bkptTable <- newIORef emptyBkptTable
281 GHC.setBreakpointHandler session (instrumentationBkptHandler bkptTable)
282 default_editor <- findEditor
284 startGHCi (runGHCi srcs maybe_expr)
285 GHCiState{ progname = "<interactive>",
288 editor = default_editor,
292 bkptTable = bkptTable,
297 Readline.resetTerminal Nothing
302 prel_name = GHC.mkModuleName "Prelude"
304 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
305 runGHCi paths maybe_expr = do
306 let read_dot_files = not opt_IgnoreDotGhci
308 when (read_dot_files) $ do
311 exists <- io (doesFileExist file)
313 dir_ok <- io (checkPerms ".")
314 file_ok <- io (checkPerms file)
315 when (dir_ok && file_ok) $ do
316 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
319 Right hdl -> fileLoop hdl False
321 when (read_dot_files) $ do
322 -- Read in $HOME/.ghci
323 either_dir <- io (IO.try (getEnv "HOME"))
327 cwd <- io (getCurrentDirectory)
328 when (dir /= cwd) $ do
329 let file = dir ++ "/.ghci"
330 ok <- io (checkPerms file)
332 either_hdl <- io (IO.try (openFile file ReadMode))
335 Right hdl -> fileLoop hdl False
337 -- Perform a :load for files given on the GHCi command line
338 -- When in -e mode, if the load fails then we want to stop
339 -- immediately rather than going on to evaluate the expression.
340 when (not (null paths)) $ do
341 ok <- ghciHandle (\e -> do showException e; return Failed) $
343 when (isJust maybe_expr && failed ok) $
344 io (exitWith (ExitFailure 1))
346 -- if verbosity is greater than 0, or we are connected to a
347 -- terminal, display the prompt in the interactive loop.
348 is_tty <- io (hIsTerminalDevice stdin)
349 dflags <- getDynFlags
350 let show_prompt = verbosity dflags > 0 || is_tty
355 #if defined(mingw32_HOST_OS)
356 -- The win32 Console API mutates the first character of
357 -- type-ahead when reading from it in a non-buffered manner. Work
358 -- around this by flushing the input buffer of type-ahead characters,
359 -- but only if stdin is available.
360 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
362 Left err | isDoesNotExistError err -> return ()
363 | otherwise -> io (ioError err)
364 Right () -> return ()
366 -- initialise the console if necessary
369 -- enter the interactive loop
370 interactiveLoop is_tty show_prompt
372 -- just evaluate the expression we were given
377 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
380 interactiveLoop is_tty show_prompt =
381 -- Ignore ^C exceptions caught here
382 ghciHandleDyn (\e -> case e of
384 #if defined(mingw32_HOST_OS)
387 interactiveLoop is_tty show_prompt
388 _other -> return ()) $
390 ghciUnblock $ do -- unblock necessary if we recursed from the
391 -- exception handler above.
393 -- read commands from stdin
397 else fileLoop stdin show_prompt
399 fileLoop stdin show_prompt
403 -- NOTE: We only read .ghci files if they are owned by the current user,
404 -- and aren't world writable. Otherwise, we could be accidentally
405 -- running code planted by a malicious third party.
407 -- Furthermore, We only read ./.ghci if . is owned by the current user
408 -- and isn't writable by anyone else. I think this is sufficient: we
409 -- don't need to check .. and ../.. etc. because "." always refers to
410 -- the same directory while a process is running.
412 checkPerms :: String -> IO Bool
414 #ifdef mingw32_HOST_OS
417 Util.handle (\_ -> return False) $ do
418 st <- getFileStatus name
420 if fileOwner st /= me then do
421 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
424 let mode = fileMode st
425 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
426 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
428 putStrLn $ "*** WARNING: " ++ name ++
429 " is writable by someone else, IGNORING!"
434 fileLoop :: Handle -> Bool -> GHCi ()
435 fileLoop hdl show_prompt = do
436 session <- getSession
437 (mod,imports) <- io (GHC.getContext session)
439 when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
440 l <- io (IO.try (hGetLine hdl))
442 Left e | isEOFError e -> return ()
443 | InvalidArgument <- etype -> return ()
444 | otherwise -> io (ioError e)
445 where etype = ioeGetErrorType e
446 -- treat InvalidArgument in the same way as EOF:
447 -- this can happen if the user closed stdin, or
448 -- perhaps did getContents which closes stdin at
451 case removeSpaces l of
452 "" -> fileLoop hdl show_prompt
453 l -> do quit <- runCommand l
454 if quit then return () else fileLoop hdl show_prompt
456 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
457 stringLoop [] = return False
458 stringLoop (s:ss) = do
459 case removeSpaces s of
461 l -> do quit <- runCommand l
462 if quit then return True else stringLoop ss
464 mkPrompt toplevs exports prompt
465 = showSDoc $ f prompt
467 f ('%':'s':xs) = perc_s <> f xs
468 f ('%':'%':xs) = char '%' <> f xs
469 f (x:xs) = char x <> f xs
472 perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
473 hsep (map (ppr . GHC.moduleName) exports)
477 readlineLoop :: GHCi ()
479 session <- getSession
480 (mod,imports) <- io (GHC.getContext session)
482 saveSession -- for use by completion
484 l <- io (readline (mkPrompt mod imports (prompt st))
485 `finally` setNonBlockingFD 0)
486 -- readline sometimes puts stdin into blocking mode,
487 -- so we need to put it back for the IO library
492 case removeSpaces l of
497 if quit then return () else readlineLoop
500 runCommand :: String -> GHCi Bool
501 runCommand c = ghciHandle handler (doCommand c)
503 doCommand (':' : command) = specialCommand command
505 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
508 -- This version is for the GHC command-line option -e. The only difference
509 -- from runCommand is that it catches the ExitException exception and
510 -- exits, rather than printing out the exception.
511 runCommandEval c = ghciHandle handleEval (doCommand c)
513 handleEval (ExitException code) = io (exitWith code)
514 handleEval e = do handler e
515 io (exitWith (ExitFailure 1))
517 doCommand (':' : command) = specialCommand command
519 = do nms <- runStmt stmt
521 Nothing -> io (exitWith (ExitFailure 1))
522 -- failure to run the command causes exit(1) for ghc -e.
523 _ -> finishEvalExpr nms
525 runStmt :: String -> GHCi (Maybe [Name])
527 | null (filter (not.isSpace) stmt) = return (Just [])
529 = do st <- getGHCiState
530 session <- getSession
531 result <- io $ withProgName (progname st) $ withArgs (args st) $
532 GHC.runStmt session stmt
534 GHC.RunFailed -> return Nothing
535 GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
536 GHC.RunOk names -> return (Just names)
538 -- possibly print the type and revert CAFs after evaluating an expression
539 finishEvalExpr mb_names
540 = do b <- isOptionSet ShowType
541 session <- getSession
544 Just names -> when b (mapM_ (showTypeOfName session) names)
547 io installSignalHandlers
548 b <- isOptionSet RevertCAFs
549 io (when b revertCAFs)
552 showTypeOfName :: Session -> Name -> GHCi ()
553 showTypeOfName session n
554 = do maybe_tything <- io (GHC.lookupName session n)
555 case maybe_tything of
557 Just thing -> showTyThing thing
559 specialCommand :: String -> GHCi Bool
560 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
561 specialCommand str = do
562 let (cmd,rest) = break isSpace str
563 maybe_cmd <- io (lookupCommand cmd)
565 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
566 ++ shortHelpText) >> return False)
567 Just (_,f,_,_) -> f (dropWhile isSpace rest)
569 lookupCommand :: String -> IO (Maybe Command)
570 lookupCommand str = do
571 cmds <- readIORef commands
572 -- look for exact match first, then the first prefix match
573 case [ c | c <- cmds, str == cmdName c ] of
574 c:_ -> return (Just c)
575 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
577 c:_ -> return (Just c)
579 -----------------------------------------------------------------------------
582 help :: String -> GHCi ()
583 help _ = io (putStr helpText)
585 info :: String -> GHCi ()
586 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
587 info s = do { let names = words s
588 ; session <- getSession
589 ; dflags <- getDynFlags
590 ; let exts = dopt Opt_GlasgowExts dflags
591 ; mapM_ (infoThing exts session) names }
593 infoThing exts session str = io $ do
594 names <- GHC.parseName session str
595 let filtered = filterOutChildren names
596 mb_stuffs <- mapM (GHC.getInfo session) filtered
597 unqual <- GHC.getPrintUnqual session
598 putStrLn (showSDocForUser unqual $
599 vcat (intersperse (text "") $
600 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
602 -- Filter out names whose parent is also there Good
603 -- example is '[]', which is both a type and data
604 -- constructor in the same type
605 filterOutChildren :: [Name] -> [Name]
606 filterOutChildren names = filter (not . parent_is_there) names
607 where parent_is_there n
608 -- | Just p <- GHC.nameParent_maybe n = p `elem` names
612 pprInfo exts (thing, fixity, insts)
613 = pprTyThingInContextLoc exts thing
614 $$ show_fixity fixity
615 $$ vcat (map GHC.pprInstance insts)
618 | fix == GHC.defaultFixity = empty
619 | otherwise = ppr fix <+> ppr (GHC.getName thing)
621 -----------------------------------------------------------------------------
624 runMain :: String -> GHCi ()
626 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
627 runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
630 addModule :: [FilePath] -> GHCi ()
632 io (revertCAFs) -- always revert CAFs on load/add.
633 files <- mapM expandPath files
634 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
635 session <- getSession
636 io (mapM_ (GHC.addTarget session) targets)
637 ok <- io (GHC.load session LoadAllTargets)
640 changeDirectory :: String -> GHCi ()
641 changeDirectory dir = do
642 session <- getSession
643 graph <- io (GHC.getModuleGraph session)
644 when (not (null graph)) $
645 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
646 io (GHC.setTargets session [])
647 io (GHC.load session LoadAllTargets)
648 setContextAfterLoad session []
649 io (GHC.workingDirectoryChanged session)
650 dir <- expandPath dir
651 io (setCurrentDirectory dir)
653 editFile :: String -> GHCi ()
656 -- find the name of the "topmost" file loaded
657 session <- getSession
658 graph0 <- io (GHC.getModuleGraph session)
659 graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
660 let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
661 case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
662 Just file -> do_edit file
663 Nothing -> throwDyn (CmdLineError "unknown file name")
664 | otherwise = do_edit str
670 throwDyn (CmdLineError "editor not set, use :set editor")
671 io $ system (cmd ++ ' ':file)
674 defineMacro :: String -> GHCi ()
676 let (macro_name, definition) = break isSpace s
677 cmds <- io (readIORef commands)
679 then throwDyn (CmdLineError "invalid macro name")
681 if (macro_name `elem` map cmdName cmds)
682 then throwDyn (CmdLineError
683 ("command '" ++ macro_name ++ "' is already defined"))
686 -- give the expression a type signature, so we can be sure we're getting
687 -- something of the right type.
688 let new_expr = '(' : definition ++ ") :: String -> IO String"
690 -- compile the expression
692 maybe_hv <- io (GHC.compileExpr cms new_expr)
695 Just hv -> io (writeIORef commands --
696 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
698 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
700 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
701 stringLoop (lines str)
703 undefineMacro :: String -> GHCi ()
704 undefineMacro macro_name = do
705 cmds <- io (readIORef commands)
706 if (macro_name `elem` map cmdName builtin_commands)
707 then throwDyn (CmdLineError
708 ("command '" ++ macro_name ++ "' cannot be undefined"))
710 if (macro_name `notElem` map cmdName cmds)
711 then throwDyn (CmdLineError
712 ("command '" ++ macro_name ++ "' not defined"))
714 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
717 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
718 loadModule fs = timeIt (loadModule' fs)
720 loadModule_ :: [FilePath] -> GHCi ()
721 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
723 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
724 loadModule' files = do
725 session <- getSession
728 io (GHC.setTargets session [])
729 io (GHC.load session LoadAllTargets)
732 let (filenames, phases) = unzip files
733 exp_filenames <- mapM expandPath filenames
734 let files' = zip exp_filenames phases
735 targets <- io (mapM (uncurry GHC.guessTarget) files')
737 -- NOTE: we used to do the dependency anal first, so that if it
738 -- fails we didn't throw away the current set of modules. This would
739 -- require some re-working of the GHC interface, so we'll leave it
740 -- as a ToDo for now.
742 io (GHC.setTargets session targets)
743 ok <- io (GHC.load session LoadAllTargets)
747 checkModule :: String -> GHCi ()
749 let modl = GHC.mkModuleName m
750 session <- getSession
751 result <- io (GHC.checkModule session modl)
753 Nothing -> io $ putStrLn "Nothing"
754 Just r -> io $ putStrLn (showSDoc (
755 case GHC.checkedModuleInfo r of
756 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
758 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
760 (text "global names: " <+> ppr global) $$
761 (text "local names: " <+> ppr local)
763 afterLoad (successIf (isJust result)) session
765 reloadModule :: String -> GHCi ()
767 io (revertCAFs) -- always revert CAFs on reload.
768 session <- getSession
769 ok <- io (GHC.load session LoadAllTargets)
772 io (revertCAFs) -- always revert CAFs on reload.
773 session <- getSession
774 ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
777 afterLoad ok session = do
778 io (revertCAFs) -- always revert CAFs on load.
779 graph <- io (GHC.getModuleGraph session)
780 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
781 setContextAfterLoad session graph'
782 refreshBkptTable graph'
783 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
785 setContextAfterLoad session [] = do
786 prel_mod <- getPrelude
787 io (GHC.setContext session [] [prel_mod])
788 setContextAfterLoad session ms = do
789 -- load a target if one is available, otherwise load the topmost module.
790 targets <- io (GHC.getTargets session)
791 case [ m | Just m <- map (findTarget ms) targets ] of
793 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
794 load_this (last graph')
799 = case filter (`matches` t) ms of
803 summary `matches` Target (TargetModule m) _
804 = GHC.ms_mod_name summary == m
805 summary `matches` Target (TargetFile f _) _
806 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
807 summary `matches` target
810 load_this summary | m <- GHC.ms_mod summary = do
811 b <- io (GHC.moduleIsInterpreted session m)
812 if b then io (GHC.setContext session [m] [])
814 prel_mod <- getPrelude
815 io (GHC.setContext session [] [prel_mod,m])
818 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
819 modulesLoadedMsg ok mods = do
820 dflags <- getDynFlags
821 when (verbosity dflags > 0) $ do
823 | null mods = text "none."
825 punctuate comma (map ppr mods)) <> text "."
828 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
830 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
833 typeOfExpr :: String -> GHCi ()
835 = do cms <- getSession
836 maybe_ty <- io (GHC.exprType cms str)
839 Just ty -> do ty' <- cleanType ty
840 tystr <- showForUser (ppr ty')
841 io (putStrLn (str ++ " :: " ++ tystr))
843 kindOfType :: String -> GHCi ()
845 = do cms <- getSession
846 maybe_ty <- io (GHC.typeKind cms str)
849 Just ty -> do tystr <- showForUser (ppr ty)
850 io (putStrLn (str ++ " :: " ++ tystr))
852 quit :: String -> GHCi Bool
853 quit _ = do in_inferior_session <- liftM not isTopLevel
854 if in_inferior_session
855 then throwDyn StopParentSession
859 shellEscape :: String -> GHCi Bool
860 shellEscape str = io (system str >> return False)
862 -----------------------------------------------------------------------------
863 -- create tags file for currently loaded modules.
865 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
867 createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
868 createCTagsFileCmd file = ghciCreateTagsFile CTags file
870 createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
871 createETagsFileCmd file = ghciCreateTagsFile ETags file
873 data TagsKind = ETags | CTags
875 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
876 ghciCreateTagsFile kind file = do
877 session <- getSession
878 io $ createTagsFile session kind file
881 -- - remove restriction that all modules must be interpreted
882 -- (problem: we don't know source locations for entities unless
883 -- we compiled the module.
885 -- - extract createTagsFile so it can be used from the command-line
886 -- (probably need to fix first problem before this is useful).
888 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
889 createTagsFile session tagskind tagFile = do
890 graph <- GHC.getModuleGraph session
891 let ms = map GHC.ms_mod graph
893 is_interpreted <- GHC.moduleIsInterpreted session m
894 -- should we just skip these?
895 when (not is_interpreted) $
896 throwDyn (CmdLineError ("module '"
897 ++ GHC.moduleNameString (GHC.moduleName m)
898 ++ "' is not interpreted"))
899 mbModInfo <- GHC.getModuleInfo session m
901 | Just modinfo <- mbModInfo,
902 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
903 | otherwise = GHC.alwaysQualify
906 Just modInfo -> return $! listTags unqual modInfo
909 mtags <- mapM tagModule ms
910 either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
912 Left e -> hPutStrLn stderr $ ioeGetErrorString e
915 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
916 listTags unqual modInfo =
917 [ tagInfo unqual name loc
918 | name <- GHC.modInfoExports modInfo
919 , let loc = nameSrcLoc name
923 type TagInfo = (String -- tag name
926 ,Int -- column number
929 -- get tag info, for later translation into Vim or Emacs style
930 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
931 tagInfo unqual name loc
932 = ( showSDocForUser unqual $ pprOccName (nameOccName name)
933 , showSDocForUser unqual $ ftext (srcLocFile loc)
938 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
939 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
940 let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
941 IO.try (writeFile file tags)
942 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
943 let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
944 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
945 tagGroups <- mapM tagFileGroup groups
946 IO.try (writeFile file $ concat tagGroups)
948 tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
949 tagFileGroup group@((_,fileName,_,_):_) = do
950 file <- readFile fileName -- need to get additional info from sources..
951 let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
952 sortedGroup = sortLe byLine group
953 tags = unlines $ perFile sortedGroup 1 0 $ lines file
954 return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
955 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
956 perFile (tagInfo:tags) (count+1) (pos+length line) lines
957 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
958 showETag tagInfo line pos : perFile tags count pos lines
959 perFile tags count pos lines = []
961 -- simple ctags format, for Vim et al
962 showTag :: TagInfo -> String
963 showTag (tag,file,lineNo,colNo)
964 = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
966 -- etags format, for Emacs/XEmacs
967 showETag :: TagInfo -> String -> Int -> String
968 showETag (tag,file,lineNo,colNo) line charPos
969 = take colNo line ++ tag
971 ++ "\x01" ++ show lineNo
972 ++ "," ++ show charPos
974 -----------------------------------------------------------------------------
975 -- Browsing a module's contents
977 browseCmd :: String -> GHCi ()
980 ['*':m] | looksLikeModuleName m -> browseModule m False
981 [m] | looksLikeModuleName m -> browseModule m True
982 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
984 browseModule m exports_only = do
986 modl <- io $ GHC.findModule s (GHC.mkModuleName m) Nothing
987 is_interpreted <- io (GHC.moduleIsInterpreted s modl)
988 when (not is_interpreted && not exports_only) $
989 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
991 -- Temporarily set the context to the module we're interested in,
992 -- just so we can get an appropriate PrintUnqualified
993 (as,bs) <- io (GHC.getContext s)
994 prel_mod <- getPrelude
995 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
996 else GHC.setContext s [modl] [])
997 unqual <- io (GHC.getPrintUnqual s)
998 io (GHC.setContext s as bs)
1000 mb_mod_info <- io $ GHC.getModuleInfo s modl
1002 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1005 | exports_only = GHC.modInfoExports mod_info
1006 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
1008 filtered = filterOutChildren names
1010 things <- io $ mapM (GHC.lookupName s) filtered
1012 dflags <- getDynFlags
1013 let exts = dopt Opt_GlasgowExts dflags
1014 io (putStrLn (showSDocForUser unqual (
1015 vcat (map (pprTyThingInContext exts) (catMaybes things))
1017 -- ToDo: modInfoInstances currently throws an exception for
1018 -- package modules. When it works, we can do this:
1019 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1021 -----------------------------------------------------------------------------
1022 -- Setting the module context
1025 | all sensible mods = fn mods
1026 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1028 (fn, mods) = case str of
1029 '+':stuff -> (addToContext, words stuff)
1030 '-':stuff -> (removeFromContext, words stuff)
1031 stuff -> (newContext, words stuff)
1033 sensible ('*':m) = looksLikeModuleName m
1034 sensible m = looksLikeModuleName m
1036 separate :: Session -> [String] -> [Module] -> [Module]
1037 -> GHCi ([Module],[Module])
1038 separate session [] as bs = return (as,bs)
1039 separate session (('*':str):ms) as bs = do
1040 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1041 b <- io $ GHC.moduleIsInterpreted session m
1042 if b then separate session ms (m:as) bs
1043 else throwDyn (CmdLineError ("module '"
1044 ++ GHC.moduleNameString (GHC.moduleName m)
1045 ++ "' is not interpreted"))
1046 separate session (str:ms) as bs = do
1047 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1048 separate session ms as (m:bs)
1050 newContext :: [String] -> GHCi ()
1051 newContext strs = do
1053 (as,bs) <- separate s strs [] []
1054 prel_mod <- getPrelude
1055 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1056 io $ GHC.setContext s as bs'
1059 addToContext :: [String] -> GHCi ()
1060 addToContext strs = do
1062 (as,bs) <- io $ GHC.getContext s
1064 (new_as,new_bs) <- separate s strs [] []
1066 let as_to_add = new_as \\ (as ++ bs)
1067 bs_to_add = new_bs \\ (as ++ bs)
1069 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1072 removeFromContext :: [String] -> GHCi ()
1073 removeFromContext strs = do
1075 (as,bs) <- io $ GHC.getContext s
1077 (as_to_remove,bs_to_remove) <- separate s strs [] []
1079 let as' = as \\ (as_to_remove ++ bs_to_remove)
1080 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1082 io $ GHC.setContext s as' bs'
1084 ----------------------------------------------------------------------------
1087 -- set options in the interpreter. Syntax is exactly the same as the
1088 -- ghc command line, except that certain options aren't available (-C,
1091 -- This is pretty fragile: most options won't work as expected. ToDo:
1092 -- figure out which ones & disallow them.
1094 setCmd :: String -> GHCi ()
1096 = do st <- getGHCiState
1097 let opts = options st
1098 io $ putStrLn (showSDoc (
1099 text "options currently set: " <>
1102 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1105 = case toArgs str of
1106 ("args":args) -> setArgs args
1107 ("prog":prog) -> setProg prog
1108 ("prompt":prompt) -> setPrompt (after 6)
1109 ("editor":cmd) -> setEditor (after 6)
1110 wds -> setOptions wds
1111 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1115 setGHCiState st{ args = args }
1119 setGHCiState st{ progname = prog }
1121 io (hPutStrLn stderr "syntax: :set prog <progname>")
1125 setGHCiState st{ editor = cmd }
1127 setPrompt value = do
1130 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1131 else setGHCiState st{ prompt = remQuotes value }
1133 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1137 do -- first, deal with the GHCi opts (+s, +t, etc.)
1138 let (plus_opts, minus_opts) = partition isPlus wds
1139 mapM_ setOpt plus_opts
1141 -- then, dynamic flags
1142 dflags <- getDynFlags
1143 let pkg_flags = packageFlags dflags
1144 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1146 if (not (null leftovers))
1147 then throwDyn (CmdLineError ("unrecognised flags: " ++
1151 new_pkgs <- setDynFlags dflags'
1153 -- if the package flags changed, we should reset the context
1154 -- and link the new packages.
1155 dflags <- getDynFlags
1156 when (packageFlags dflags /= pkg_flags) $ do
1157 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1158 session <- getSession
1159 io (GHC.setTargets session [])
1160 io (GHC.load session LoadAllTargets)
1161 io (linkPackages dflags new_pkgs)
1162 setContextAfterLoad session []
1166 unsetOptions :: String -> GHCi ()
1168 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1169 let opts = words str
1170 (minus_opts, rest1) = partition isMinus opts
1171 (plus_opts, rest2) = partition isPlus rest1
1173 if (not (null rest2))
1174 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1177 mapM_ unsetOpt plus_opts
1179 -- can't do GHC flags for now
1180 if (not (null minus_opts))
1181 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1184 isMinus ('-':s) = True
1187 isPlus ('+':s) = True
1191 = case strToGHCiOpt str of
1192 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1193 Just o -> setOption o
1196 = case strToGHCiOpt str of
1197 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1198 Just o -> unsetOption o
1200 strToGHCiOpt :: String -> (Maybe GHCiOption)
1201 strToGHCiOpt "s" = Just ShowTiming
1202 strToGHCiOpt "t" = Just ShowType
1203 strToGHCiOpt "r" = Just RevertCAFs
1204 strToGHCiOpt _ = Nothing
1206 optToStr :: GHCiOption -> String
1207 optToStr ShowTiming = "s"
1208 optToStr ShowType = "t"
1209 optToStr RevertCAFs = "r"
1211 -- ---------------------------------------------------------------------------
1216 ["modules" ] -> showModules
1217 ["bindings"] -> showBindings
1218 ["linker"] -> io showLinkerState
1219 ["breakpoints"] -> showBkptTable
1220 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1223 session <- getSession
1224 let show_one ms = do m <- io (GHC.showModule session ms)
1226 graph <- io (GHC.getModuleGraph session)
1227 mapM_ show_one graph
1231 unqual <- io (GHC.getPrintUnqual s)
1232 bindings <- io (GHC.getBindings s)
1233 mapM_ showTyThing bindings
1236 showTyThing (AnId id) = do
1237 ty' <- cleanType (GHC.idType id)
1238 str <- showForUser (ppr id <> text " :: " <> ppr ty')
1240 showTyThing _ = return ()
1242 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1243 cleanType :: Type -> GHCi Type
1245 dflags <- getDynFlags
1246 if dopt Opt_GlasgowExts dflags
1248 else return $! GHC.dropForAlls ty
1250 showBkptTable :: GHCi ()
1253 msg <- showForUser . vcat $
1254 [ ppr mod <> colon <+> fcat
1255 [ parens(int row <> comma <> int col) | (row,col) <- sites]
1256 | (mod, sites) <- sitesList bt ]
1258 -- -----------------------------------------------------------------------------
1261 completeNone :: String -> IO [String]
1262 completeNone w = return []
1265 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1266 completeWord w start end = do
1267 line <- Readline.getLineBuffer
1269 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1271 | Just c <- is_cmd line -> do
1272 maybe_cmd <- lookupCommand c
1273 let (n,w') = selectWord (words' 0 line)
1275 Nothing -> return Nothing
1276 Just (_,_,False,complete) -> wrapCompleter complete w
1277 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1278 return (map (drop n) rets)
1279 in wrapCompleter complete' w'
1281 --printf "complete %s, start = %d, end = %d\n" w start end
1282 wrapCompleter completeIdentifier w
1283 where words' _ [] = []
1284 words' n str = let (w,r) = break isSpace str
1285 (s,r') = span isSpace r
1286 in (n,w):words' (n+length w+length s) r'
1287 -- In a Haskell expression we want to parse 'a-b' as three words
1288 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1289 -- only be a single word.
1290 selectWord [] = (0,w)
1291 selectWord ((offset,x):xs)
1292 | offset+length x >= start = (start-offset,take (end-offset) x)
1293 | otherwise = selectWord xs
1296 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1297 | otherwise = Nothing
1300 cmds <- readIORef commands
1301 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1303 completeMacro w = do
1304 cmds <- readIORef commands
1305 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1306 return (filter (w `isPrefixOf`) cmds')
1308 completeIdentifier w = do
1310 rdrs <- GHC.getRdrNamesInScope s
1311 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1313 completeModule w = do
1315 dflags <- GHC.getSessionDynFlags s
1316 let pkg_mods = allExposedModules dflags
1317 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1319 completeHomeModule w = do
1321 g <- GHC.getModuleGraph s
1322 let home_mods = map GHC.ms_mod_name g
1323 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1325 completeSetOptions w = do
1326 return (filter (w `isPrefixOf`) options)
1327 where options = "args":"prog":allFlags
1329 completeBkpt = unionComplete completeModule completeBkptCmds
1331 completeBkptCmds w = do
1332 return (filter (w `isPrefixOf`) options)
1333 where options = ["add","del","list","stop"]
1335 completeFilename = Readline.filenameCompletionFunction
1337 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1339 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1340 unionComplete f1 f2 w = do
1345 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1346 wrapCompleter fun w = do
1349 [] -> return Nothing
1350 [x] -> return (Just (x,[]))
1351 xs -> case getCommonPrefix xs of
1352 "" -> return (Just ("",xs))
1353 pref -> return (Just (pref,xs))
1355 getCommonPrefix :: [String] -> String
1356 getCommonPrefix [] = ""
1357 getCommonPrefix (s:ss) = foldl common s ss
1358 where common s "" = s
1360 common (c:cs) (d:ds)
1361 | c == d = c : common cs ds
1364 allExposedModules :: DynFlags -> [ModuleName]
1365 allExposedModules dflags
1366 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1368 pkg_db = pkgIdMap (pkgState dflags)
1370 completeCmd = completeNone
1371 completeMacro = completeNone
1372 completeIdentifier = completeNone
1373 completeModule = completeNone
1374 completeHomeModule = completeNone
1375 completeSetOptions = completeNone
1376 completeFilename = completeNone
1377 completeHomeModuleOrFile=completeNone
1378 completeBkpt = completeNone
1381 -- ---------------------------------------------------------------------------
1382 -- User code exception handling
1384 -- This is the exception handler for exceptions generated by the
1385 -- user's code and exceptions coming from children sessions;
1386 -- it normally just prints out the exception. The
1387 -- handler must be recursive, in case showing the exception causes
1388 -- more exceptions to be raised.
1390 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1391 -- raising another exception. We therefore don't put the recursive
1392 -- handler arond the flushing operation, so if stderr is closed
1393 -- GHCi will just die gracefully rather than going into an infinite loop.
1394 handler :: Exception -> GHCi Bool
1395 handler (DynException dyn)
1396 | Just StopChildSession <- fromDynamic dyn
1397 -- propagate to the parent session
1398 = do ASSERTM (liftM not isTopLevel)
1399 throwDyn StopChildSession
1401 | Just StopParentSession <- fromDynamic dyn
1402 = do at_topLevel <- isTopLevel
1403 if at_topLevel then return True else throwDyn StopParentSession
1405 | Just (ChildSessionStopped msg) <- fromDynamic dyn
1406 -- Reload modules and display some message
1407 = do ASSERTM (isTopLevel)
1408 io(putStrLn msg) >> return False
1410 handler exception = do
1412 io installSignalHandlers
1413 ghciHandle handler (showException exception >> return False)
1415 showException (DynException dyn) =
1416 case fromDynamic dyn of
1417 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1418 Just Interrupted -> io (putStrLn "Interrupted.")
1419 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1420 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1421 Just other_ghc_ex -> io (print other_ghc_ex)
1423 showException other_exception
1424 = io (putStrLn ("*** Exception: " ++ show other_exception))
1426 -----------------------------------------------------------------------------
1427 -- recursive exception handlers
1429 -- Don't forget to unblock async exceptions in the handler, or if we're
1430 -- in an exception loop (eg. let a = error a in a) the ^C exception
1431 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1433 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1434 ghciHandle h (GHCi m) = GHCi $ \s ->
1435 Exception.catch (m s)
1436 (\e -> unGHCi (ghciUnblock (h e)) s)
1438 ghciUnblock :: GHCi a -> GHCi a
1439 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1442 -- ----------------------------------------------------------------------------
1445 expandPath :: String -> GHCi String
1447 case dropWhile isSpace path of
1449 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1450 return (tilde ++ '/':d)
1454 -- ----------------------------------------------------------------------------
1455 -- Windows console setup
1457 setUpConsole :: IO ()
1459 #ifdef mingw32_HOST_OS
1460 -- On Windows we need to set a known code page, otherwise the characters
1461 -- we read from the console will be be in some strange encoding, and
1462 -- similarly for characters we write to the console.
1464 -- At the moment, GHCi pretends all input is Latin-1. In the
1465 -- future we should support UTF-8, but for now we set the code pages
1468 -- It seems you have to set the font in the console window to
1469 -- a Unicode font in order for output to work properly,
1470 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1471 -- (see MSDN for SetConsoleOutputCP()).
1473 setConsoleCP 28591 -- ISO Latin-1
1474 setConsoleOutputCP 28591 -- ISO Latin-1
1479 instrumentationBkptHandler :: IORef (BkptTable Module) -> BkptHandler Module
1480 instrumentationBkptHandler ref_bkptTable = BkptHandler {
1481 isAutoBkptEnabled = \sess bkptLoc -> do
1482 bktpTable <- readIORef ref_bkptTable
1483 return$ isBkptEnabled bktpTable bkptLoc
1485 , handleBreakpoint = doBreakpoint ref_bkptTable
1488 doBreakpoint :: IORef (BkptTable Module)-> Session -> [(Id,HValue)] -> BkptLocation Module -> String -> b -> IO b
1489 doBreakpoint ref_bkptTable s@(Session ref) values _ locMsg b = do
1490 let (ids, hValues) = unzip values
1491 names = map idName ids
1492 ASSERT (length names == length hValues) return ()
1493 let global_ids = map globaliseAndTidy ids
1494 printScopeMsg locMsg global_ids
1495 typed_ids <- mapM instantiateIdType global_ids
1496 hsc_env <- readIORef ref
1497 let ictxt = hsc_IC hsc_env
1498 rn_env = ic_rn_local_env ictxt
1499 type_env = ic_type_env ictxt
1500 bound_names = map idName typed_ids
1501 new_rn_env = extendLocalRdrEnv rn_env bound_names
1502 -- Remove any shadowed bindings from the type_env;
1503 -- they are inaccessible but might, I suppose, cause
1504 -- a space leak if we leave them there
1505 shadowed = [ n | name <- bound_names,
1506 let rdr_name = mkRdrUnqual (nameOccName name),
1507 Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
1508 filtered_type_env = delListFromNameEnv type_env shadowed
1509 new_type_env = extendTypeEnvWithIds filtered_type_env (typed_ids)
1510 new_ic = ictxt { ic_rn_local_env = new_rn_env,
1511 ic_type_env = new_type_env }
1512 writeIORef ref (hsc_env { hsc_IC = new_ic })
1513 is_tty <- hIsTerminalDevice stdin
1514 prel_mod <- GHC.findModule s prel_name Nothing
1515 withExtendedLinkEnv (zip names hValues) $
1516 startGHCi (interactiveLoop is_tty True) GHCiState{
1517 progname = "<interactive>",
1519 prompt = locMsg ++ "> ",
1522 bkptTable= ref_bkptTable,
1525 `catchDyn` (\e -> case e of
1526 StopChildSession -> evaluate$
1527 throwDyn (ChildSessionStopped "")
1528 StopParentSession -> throwDyn StopParentSession
1530 writeIORef ref hsc_env
1531 putStrLn $ "Returning to normal execution..."
1534 printScopeMsg :: String -> [Id] -> IO ()
1535 printScopeMsg location ids = do
1536 unqual <- GHC.getPrintUnqual s
1537 printForUser stdout unqual $
1538 text "Stopped at a breakpoint in " <> text (stripColumn location) <>
1539 char '.' <+> text "Local bindings in scope:" $$
1540 nest 2 (pprWithCommas showId ids)
1543 ppr (idName id) <+> dcolon <+> ppr (idType id)
1544 stripColumn = reverse . tail . dropWhile (/= ':') . reverse
1546 -- | Give the Id a Global Name, and tidy its type
1547 globaliseAndTidy :: Id -> Id
1549 = let tidied_type = tidyTopType$ idType id
1550 in setIdType (globaliseId VanillaGlobal id) tidied_type
1552 -- | Instantiate the tyVars with GHC.Base.Unknown
1553 instantiateIdType :: Id -> IO Id
1554 instantiateIdType id = do
1555 instantiatedType <- instantiateTyVarsToUnknown s (idType id)
1556 return$ setIdType id instantiatedType