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 (Just basePackageId)
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'
784 bt' <- io$ refreshBkptTable session bt graph'
786 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
788 setContextAfterLoad session [] = do
789 prel_mod <- getPrelude
790 io (GHC.setContext session [] [prel_mod])
791 setContextAfterLoad session ms = do
792 -- load a target if one is available, otherwise load the topmost module.
793 targets <- io (GHC.getTargets session)
794 case [ m | Just m <- map (findTarget ms) targets ] of
796 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
797 load_this (last graph')
802 = case filter (`matches` t) ms of
806 summary `matches` Target (TargetModule m) _
807 = GHC.ms_mod_name summary == m
808 summary `matches` Target (TargetFile f _) _
809 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
810 summary `matches` target
813 load_this summary | m <- GHC.ms_mod summary = do
814 b <- io (GHC.moduleIsInterpreted session m)
815 if b then io (GHC.setContext session [m] [])
817 prel_mod <- getPrelude
818 io (GHC.setContext session [] [prel_mod,m])
821 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
822 modulesLoadedMsg ok mods = do
823 dflags <- getDynFlags
824 when (verbosity dflags > 0) $ do
826 | null mods = text "none."
828 punctuate comma (map ppr mods)) <> text "."
831 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
833 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
836 typeOfExpr :: String -> GHCi ()
838 = do cms <- getSession
839 maybe_ty <- io (GHC.exprType cms str)
842 Just ty -> do ty' <- cleanType ty
843 tystr <- showForUser (ppr ty')
844 io (putStrLn (str ++ " :: " ++ tystr))
846 kindOfType :: String -> GHCi ()
848 = do cms <- getSession
849 maybe_ty <- io (GHC.typeKind cms str)
852 Just ty -> do tystr <- showForUser (ppr ty)
853 io (putStrLn (str ++ " :: " ++ tystr))
855 quit :: String -> GHCi Bool
856 quit _ = do in_inferior_session <- liftM not isTopLevel
857 if in_inferior_session
858 then throwDyn StopParentSession
862 shellEscape :: String -> GHCi Bool
863 shellEscape str = io (system str >> return False)
865 -----------------------------------------------------------------------------
866 -- create tags file for currently loaded modules.
868 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
870 createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
871 createCTagsFileCmd file = ghciCreateTagsFile CTags file
873 createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
874 createETagsFileCmd file = ghciCreateTagsFile ETags file
876 data TagsKind = ETags | CTags
878 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
879 ghciCreateTagsFile kind file = do
880 session <- getSession
881 io $ createTagsFile session kind file
884 -- - remove restriction that all modules must be interpreted
885 -- (problem: we don't know source locations for entities unless
886 -- we compiled the module.
888 -- - extract createTagsFile so it can be used from the command-line
889 -- (probably need to fix first problem before this is useful).
891 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
892 createTagsFile session tagskind tagFile = do
893 graph <- GHC.getModuleGraph session
894 let ms = map GHC.ms_mod graph
896 is_interpreted <- GHC.moduleIsInterpreted session m
897 -- should we just skip these?
898 when (not is_interpreted) $
899 throwDyn (CmdLineError ("module '"
900 ++ GHC.moduleNameString (GHC.moduleName m)
901 ++ "' is not interpreted"))
902 mbModInfo <- GHC.getModuleInfo session m
904 | Just modinfo <- mbModInfo,
905 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
906 | otherwise = GHC.alwaysQualify
909 Just modInfo -> return $! listTags unqual modInfo
912 mtags <- mapM tagModule ms
913 either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
915 Left e -> hPutStrLn stderr $ ioeGetErrorString e
918 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
919 listTags unqual modInfo =
920 [ tagInfo unqual name loc
921 | name <- GHC.modInfoExports modInfo
922 , let loc = nameSrcLoc name
926 type TagInfo = (String -- tag name
929 ,Int -- column number
932 -- get tag info, for later translation into Vim or Emacs style
933 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
934 tagInfo unqual name loc
935 = ( showSDocForUser unqual $ pprOccName (nameOccName name)
936 , showSDocForUser unqual $ ftext (srcLocFile loc)
941 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
942 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
943 let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
944 IO.try (writeFile file tags)
945 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
946 let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
947 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
948 tagGroups <- mapM tagFileGroup groups
949 IO.try (writeFile file $ concat tagGroups)
951 tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
952 tagFileGroup group@((_,fileName,_,_):_) = do
953 file <- readFile fileName -- need to get additional info from sources..
954 let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
955 sortedGroup = sortLe byLine group
956 tags = unlines $ perFile sortedGroup 1 0 $ lines file
957 return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
958 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
959 perFile (tagInfo:tags) (count+1) (pos+length line) lines
960 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
961 showETag tagInfo line pos : perFile tags count pos lines
962 perFile tags count pos lines = []
964 -- simple ctags format, for Vim et al
965 showTag :: TagInfo -> String
966 showTag (tag,file,lineNo,colNo)
967 = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
969 -- etags format, for Emacs/XEmacs
970 showETag :: TagInfo -> String -> Int -> String
971 showETag (tag,file,lineNo,colNo) line charPos
972 = take colNo line ++ tag
974 ++ "\x01" ++ show lineNo
975 ++ "," ++ show charPos
977 -----------------------------------------------------------------------------
978 -- Browsing a module's contents
980 browseCmd :: String -> GHCi ()
983 ['*':m] | looksLikeModuleName m -> browseModule m False
984 [m] | looksLikeModuleName m -> browseModule m True
985 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
987 browseModule m exports_only = do
989 modl <- io $ GHC.findModule s (GHC.mkModuleName m) Nothing
990 is_interpreted <- io (GHC.moduleIsInterpreted s modl)
991 when (not is_interpreted && not exports_only) $
992 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
994 -- Temporarily set the context to the module we're interested in,
995 -- just so we can get an appropriate PrintUnqualified
996 (as,bs) <- io (GHC.getContext s)
997 prel_mod <- getPrelude
998 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
999 else GHC.setContext s [modl] [])
1000 unqual <- io (GHC.getPrintUnqual s)
1001 io (GHC.setContext s as bs)
1003 mb_mod_info <- io $ GHC.getModuleInfo s modl
1005 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1008 | exports_only = GHC.modInfoExports mod_info
1009 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
1011 filtered = filterOutChildren names
1013 things <- io $ mapM (GHC.lookupName s) filtered
1015 dflags <- getDynFlags
1016 let exts = dopt Opt_GlasgowExts dflags
1017 io (putStrLn (showSDocForUser unqual (
1018 vcat (map (pprTyThingInContext exts) (catMaybes things))
1020 -- ToDo: modInfoInstances currently throws an exception for
1021 -- package modules. When it works, we can do this:
1022 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1024 -----------------------------------------------------------------------------
1025 -- Setting the module context
1028 | all sensible mods = fn mods
1029 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1031 (fn, mods) = case str of
1032 '+':stuff -> (addToContext, words stuff)
1033 '-':stuff -> (removeFromContext, words stuff)
1034 stuff -> (newContext, words stuff)
1036 sensible ('*':m) = looksLikeModuleName m
1037 sensible m = looksLikeModuleName m
1039 separate :: Session -> [String] -> [Module] -> [Module]
1040 -> GHCi ([Module],[Module])
1041 separate session [] as bs = return (as,bs)
1042 separate session (('*':str):ms) as bs = do
1043 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1044 b <- io $ GHC.moduleIsInterpreted session m
1045 if b then separate session ms (m:as) bs
1046 else throwDyn (CmdLineError ("module '"
1047 ++ GHC.moduleNameString (GHC.moduleName m)
1048 ++ "' is not interpreted"))
1049 separate session (str:ms) as bs = do
1050 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1051 separate session ms as (m:bs)
1053 newContext :: [String] -> GHCi ()
1054 newContext strs = do
1056 (as,bs) <- separate s strs [] []
1057 prel_mod <- getPrelude
1058 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1059 io $ GHC.setContext s as bs'
1062 addToContext :: [String] -> GHCi ()
1063 addToContext strs = do
1065 (as,bs) <- io $ GHC.getContext s
1067 (new_as,new_bs) <- separate s strs [] []
1069 let as_to_add = new_as \\ (as ++ bs)
1070 bs_to_add = new_bs \\ (as ++ bs)
1072 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1075 removeFromContext :: [String] -> GHCi ()
1076 removeFromContext strs = do
1078 (as,bs) <- io $ GHC.getContext s
1080 (as_to_remove,bs_to_remove) <- separate s strs [] []
1082 let as' = as \\ (as_to_remove ++ bs_to_remove)
1083 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1085 io $ GHC.setContext s as' bs'
1087 ----------------------------------------------------------------------------
1090 -- set options in the interpreter. Syntax is exactly the same as the
1091 -- ghc command line, except that certain options aren't available (-C,
1094 -- This is pretty fragile: most options won't work as expected. ToDo:
1095 -- figure out which ones & disallow them.
1097 setCmd :: String -> GHCi ()
1099 = do st <- getGHCiState
1100 let opts = options st
1101 io $ putStrLn (showSDoc (
1102 text "options currently set: " <>
1105 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1108 = case toArgs str of
1109 ("args":args) -> setArgs args
1110 ("prog":prog) -> setProg prog
1111 ("prompt":prompt) -> setPrompt (after 6)
1112 ("editor":cmd) -> setEditor (after 6)
1113 wds -> setOptions wds
1114 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1118 setGHCiState st{ args = args }
1122 setGHCiState st{ progname = prog }
1124 io (hPutStrLn stderr "syntax: :set prog <progname>")
1128 setGHCiState st{ editor = cmd }
1130 setPrompt value = do
1133 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1134 else setGHCiState st{ prompt = remQuotes value }
1136 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1140 do -- first, deal with the GHCi opts (+s, +t, etc.)
1141 let (plus_opts, minus_opts) = partition isPlus wds
1142 mapM_ setOpt plus_opts
1144 -- then, dynamic flags
1145 dflags <- getDynFlags
1146 let pkg_flags = packageFlags dflags
1147 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1149 if (not (null leftovers))
1150 then throwDyn (CmdLineError ("unrecognised flags: " ++
1154 new_pkgs <- setDynFlags dflags'
1156 -- if the package flags changed, we should reset the context
1157 -- and link the new packages.
1158 dflags <- getDynFlags
1159 when (packageFlags dflags /= pkg_flags) $ do
1160 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1161 session <- getSession
1162 io (GHC.setTargets session [])
1163 io (GHC.load session LoadAllTargets)
1164 io (linkPackages dflags new_pkgs)
1165 setContextAfterLoad session []
1169 unsetOptions :: String -> GHCi ()
1171 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1172 let opts = words str
1173 (minus_opts, rest1) = partition isMinus opts
1174 (plus_opts, rest2) = partition isPlus rest1
1176 if (not (null rest2))
1177 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1180 mapM_ unsetOpt plus_opts
1182 -- can't do GHC flags for now
1183 if (not (null minus_opts))
1184 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1187 isMinus ('-':s) = True
1190 isPlus ('+':s) = True
1194 = case strToGHCiOpt str of
1195 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1196 Just o -> setOption o
1199 = case strToGHCiOpt str of
1200 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1201 Just o -> unsetOption o
1203 strToGHCiOpt :: String -> (Maybe GHCiOption)
1204 strToGHCiOpt "s" = Just ShowTiming
1205 strToGHCiOpt "t" = Just ShowType
1206 strToGHCiOpt "r" = Just RevertCAFs
1207 strToGHCiOpt _ = Nothing
1209 optToStr :: GHCiOption -> String
1210 optToStr ShowTiming = "s"
1211 optToStr ShowType = "t"
1212 optToStr RevertCAFs = "r"
1214 -- ---------------------------------------------------------------------------
1219 ["modules" ] -> showModules
1220 ["bindings"] -> showBindings
1221 ["linker"] -> io showLinkerState
1222 ["breakpoints"] -> showBkptTable
1223 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1226 session <- getSession
1227 let show_one ms = do m <- io (GHC.showModule session ms)
1229 graph <- io (GHC.getModuleGraph session)
1230 mapM_ show_one graph
1234 unqual <- io (GHC.getPrintUnqual s)
1235 bindings <- io (GHC.getBindings s)
1236 mapM_ showTyThing bindings
1239 showTyThing (AnId id) = do
1240 ty' <- cleanType (GHC.idType id)
1241 str <- showForUser (ppr id <> text " :: " <> ppr ty')
1243 showTyThing _ = return ()
1245 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1246 cleanType :: Type -> GHCi Type
1248 dflags <- getDynFlags
1249 if dopt Opt_GlasgowExts dflags
1251 else return $! GHC.dropForAlls ty
1253 showBkptTable :: GHCi ()
1256 msg <- showForUser . vcat $
1257 [ ppr mod <> colon <+> fcat
1258 [ parens(int row <> comma <> int col) | (row,col) <- sites]
1259 | (mod, sites) <- sitesList bt ]
1261 -- -----------------------------------------------------------------------------
1264 completeNone :: String -> IO [String]
1265 completeNone w = return []
1268 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1269 completeWord w start end = do
1270 line <- Readline.getLineBuffer
1272 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1274 | Just c <- is_cmd line -> do
1275 maybe_cmd <- lookupCommand c
1276 let (n,w') = selectWord (words' 0 line)
1278 Nothing -> return Nothing
1279 Just (_,_,False,complete) -> wrapCompleter complete w
1280 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1281 return (map (drop n) rets)
1282 in wrapCompleter complete' w'
1284 --printf "complete %s, start = %d, end = %d\n" w start end
1285 wrapCompleter completeIdentifier w
1286 where words' _ [] = []
1287 words' n str = let (w,r) = break isSpace str
1288 (s,r') = span isSpace r
1289 in (n,w):words' (n+length w+length s) r'
1290 -- In a Haskell expression we want to parse 'a-b' as three words
1291 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1292 -- only be a single word.
1293 selectWord [] = (0,w)
1294 selectWord ((offset,x):xs)
1295 | offset+length x >= start = (start-offset,take (end-offset) x)
1296 | otherwise = selectWord xs
1299 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1300 | otherwise = Nothing
1303 cmds <- readIORef commands
1304 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1306 completeMacro w = do
1307 cmds <- readIORef commands
1308 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1309 return (filter (w `isPrefixOf`) cmds')
1311 completeIdentifier w = do
1313 rdrs <- GHC.getRdrNamesInScope s
1314 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1316 completeModule w = do
1318 dflags <- GHC.getSessionDynFlags s
1319 let pkg_mods = allExposedModules dflags
1320 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1322 completeHomeModule w = do
1324 g <- GHC.getModuleGraph s
1325 let home_mods = map GHC.ms_mod_name g
1326 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1328 completeSetOptions w = do
1329 return (filter (w `isPrefixOf`) options)
1330 where options = "args":"prog":allFlags
1332 completeBkpt = unionComplete completeModule completeBkptCmds
1334 completeBkptCmds w = do
1335 return (filter (w `isPrefixOf`) options)
1336 where options = ["add","del","list","stop"]
1338 completeFilename = Readline.filenameCompletionFunction
1340 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1342 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1343 unionComplete f1 f2 w = do
1348 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1349 wrapCompleter fun w = do
1352 [] -> return Nothing
1353 [x] -> return (Just (x,[]))
1354 xs -> case getCommonPrefix xs of
1355 "" -> return (Just ("",xs))
1356 pref -> return (Just (pref,xs))
1358 getCommonPrefix :: [String] -> String
1359 getCommonPrefix [] = ""
1360 getCommonPrefix (s:ss) = foldl common s ss
1361 where common s "" = ""
1363 common (c:cs) (d:ds)
1364 | c == d = c : common cs ds
1367 allExposedModules :: DynFlags -> [ModuleName]
1368 allExposedModules dflags
1369 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1371 pkg_db = pkgIdMap (pkgState dflags)
1373 completeCmd = completeNone
1374 completeMacro = completeNone
1375 completeIdentifier = completeNone
1376 completeModule = completeNone
1377 completeHomeModule = completeNone
1378 completeSetOptions = completeNone
1379 completeFilename = completeNone
1380 completeHomeModuleOrFile=completeNone
1381 completeBkpt = completeNone
1384 -- ---------------------------------------------------------------------------
1385 -- User code exception handling
1387 -- This is the exception handler for exceptions generated by the
1388 -- user's code and exceptions coming from children sessions;
1389 -- it normally just prints out the exception. The
1390 -- handler must be recursive, in case showing the exception causes
1391 -- more exceptions to be raised.
1393 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1394 -- raising another exception. We therefore don't put the recursive
1395 -- handler arond the flushing operation, so if stderr is closed
1396 -- GHCi will just die gracefully rather than going into an infinite loop.
1397 handler :: Exception -> GHCi Bool
1398 handler (DynException dyn)
1399 | Just StopChildSession <- fromDynamic dyn
1400 -- propagate to the parent session
1401 = do ASSERTM (liftM not isTopLevel)
1402 throwDyn StopChildSession
1404 | Just StopParentSession <- fromDynamic dyn
1405 = do at_topLevel <- isTopLevel
1406 if at_topLevel then return True else throwDyn StopParentSession
1408 | Just (ChildSessionStopped msg) <- fromDynamic dyn
1409 = io(putStrLn msg) >> return False
1411 handler exception = do
1413 io installSignalHandlers
1414 ghciHandle handler (showException exception >> return False)
1416 showException (DynException dyn) =
1417 case fromDynamic dyn of
1418 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1419 Just Interrupted -> io (putStrLn "Interrupted.")
1420 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1421 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1422 Just other_ghc_ex -> io (print other_ghc_ex)
1424 showException other_exception
1425 = io (putStrLn ("*** Exception: " ++ show other_exception))
1427 -----------------------------------------------------------------------------
1428 -- recursive exception handlers
1430 -- Don't forget to unblock async exceptions in the handler, or if we're
1431 -- in an exception loop (eg. let a = error a in a) the ^C exception
1432 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1434 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1435 ghciHandle h (GHCi m) = GHCi $ \s ->
1436 Exception.catch (m s)
1437 (\e -> unGHCi (ghciUnblock (h e)) s)
1439 ghciUnblock :: GHCi a -> GHCi a
1440 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1443 -- ----------------------------------------------------------------------------
1446 expandPath :: String -> GHCi String
1448 case dropWhile isSpace path of
1450 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1451 return (tilde ++ '/':d)
1455 -- ----------------------------------------------------------------------------
1456 -- Windows console setup
1458 setUpConsole :: IO ()
1460 #ifdef mingw32_HOST_OS
1461 -- On Windows we need to set a known code page, otherwise the characters
1462 -- we read from the console will be be in some strange encoding, and
1463 -- similarly for characters we write to the console.
1465 -- At the moment, GHCi pretends all input is Latin-1. In the
1466 -- future we should support UTF-8, but for now we set the code pages
1469 -- It seems you have to set the font in the console window to
1470 -- a Unicode font in order for output to work properly,
1471 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1472 -- (see MSDN for SetConsoleOutputCP()).
1474 setConsoleCP 28591 -- ISO Latin-1
1475 setConsoleOutputCP 28591 -- ISO Latin-1
1480 instrumentationBkptHandler :: IORef (BkptTable Module) -> BkptHandler Module
1481 instrumentationBkptHandler ref_bkptTable = BkptHandler {
1482 isAutoBkptEnabled = \sess bkptLoc -> do
1483 bktpTable <- readIORef ref_bkptTable
1484 return$ isBkptEnabled bktpTable bkptLoc
1486 , handleBreakpoint = doBreakpoint ref_bkptTable
1489 doBreakpoint :: IORef (BkptTable Module)-> Session -> [(Id,HValue)] -> BkptLocation Module -> String -> b -> IO b
1490 doBreakpoint ref_bkptTable s@(Session ref) values _ locMsg b = do
1491 let (ids, hValues) = unzip values
1492 names = map idName ids
1493 ASSERT (length names == length hValues) return ()
1494 let global_ids = map globaliseAndTidy ids
1495 printScopeMsg locMsg global_ids
1496 typed_ids <- mapM instantiateIdType global_ids
1497 hsc_env <- readIORef ref
1498 let ictxt = hsc_IC hsc_env
1499 rn_env = ic_rn_local_env ictxt
1500 type_env = ic_type_env ictxt
1501 bound_names = map idName typed_ids
1502 new_rn_env = extendLocalRdrEnv rn_env bound_names
1503 -- Remove any shadowed bindings from the type_env;
1504 -- they are inaccessible but might, I suppose, cause
1505 -- a space leak if we leave them there
1506 shadowed = [ n | name <- bound_names,
1507 let rdr_name = mkRdrUnqual (nameOccName name),
1508 Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
1509 filtered_type_env = delListFromNameEnv type_env shadowed
1510 new_type_env = extendTypeEnvWithIds filtered_type_env (typed_ids)
1511 new_ic = ictxt { ic_rn_local_env = new_rn_env,
1512 ic_type_env = new_type_env }
1513 writeIORef ref (hsc_env { hsc_IC = new_ic })
1514 is_tty <- hIsTerminalDevice stdin
1515 prel_mod <- GHC.findModule s prel_name Nothing
1516 withExtendedLinkEnv (zip names hValues) $
1517 startGHCi (interactiveLoop is_tty True) GHCiState{
1518 progname = "<interactive>",
1520 prompt = locMsg ++ "> ",
1523 bkptTable= ref_bkptTable,
1526 `catchDyn` (\e -> case e of
1527 StopChildSession -> evaluate$
1528 throwDyn (ChildSessionStopped "")
1529 StopParentSession -> throwDyn StopParentSession
1531 writeIORef ref hsc_env
1532 putStrLn $ "Returning to normal execution..."
1535 printScopeMsg :: String -> [Id] -> IO ()
1536 printScopeMsg location ids = do
1537 unqual <- GHC.getPrintUnqual s
1538 printForUser stdout unqual $
1539 text "Stopped at a breakpoint in " <> text (stripColumn location) <>
1540 char '.' <+> text "Local bindings in scope:" $$
1541 nest 2 (pprWithCommas showId ids)
1544 ppr (idName id) <+> dcolon <+> ppr (idType id)
1545 stripColumn = reverse . tail . dropWhile (/= ':') . reverse
1547 -- | Give the Id a Global Name, and tidy its type
1548 globaliseAndTidy :: Id -> Id
1550 = let tidied_type = tidyTopType$ idType id
1551 in setIdType (globaliseId VanillaGlobal id) tidied_type
1553 -- | Instantiate the tyVars with GHC.Base.Unknown
1554 instantiateIdType :: Id -> IO Id
1555 instantiateIdType id = do
1556 instantiatedType <- instantiateTyVarsToUnknown s (idType id)
1557 return$ setIdType id instantiatedType