1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005-2006
8 -----------------------------------------------------------------------------
9 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
11 #include "HsVersions.h"
19 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
20 Type, Module, ModuleName, TyThing(..), Phase,
21 BreakIndex, SrcSpan, Resume, SingleStep )
26 import HscTypes ( implicitTyThings )
28 import Outputable hiding (printForUser)
29 import Module -- for ModuleEnv
33 -- Other random utilities
35 import BasicTypes hiding (isTopLevel)
36 import Panic hiding (showException)
42 import Maybes ( orElse )
45 #ifndef mingw32_HOST_OS
46 import System.Posix hiding (getEnv)
48 import GHC.ConsoleHandler ( flushConsole )
49 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
50 import qualified System.Win32
54 import Control.Concurrent ( yield ) -- Used in readline loop
55 import System.Console.Readline as Readline
60 import Control.Exception as Exception
61 -- import Control.Concurrent
63 import qualified Data.ByteString.Char8 as BS
67 import System.Environment
68 import System.Exit ( exitWith, ExitCode(..) )
69 import System.Directory
71 import System.IO.Error as IO
75 import Control.Monad as Monad
78 import Foreign.StablePtr ( newStablePtr )
79 import GHC.Exts ( unsafeCoerce# )
80 import GHC.IOBase ( IOErrorType(InvalidArgument) )
82 import Data.IORef ( IORef, readIORef, writeIORef )
84 import System.Posix.Internals ( setNonBlockingFD )
86 -----------------------------------------------------------------------------
88 ghciWelcomeMsg :: String
89 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
90 ": http://www.haskell.org/ghc/ :? for help"
92 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
95 GLOBAL_VAR(commands, builtin_commands, [Command])
97 builtin_commands :: [Command]
99 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
100 ("?", keepGoing help, False, completeNone),
101 ("add", keepGoingPaths addModule, False, completeFilename),
102 ("abandon", keepGoing abandonCmd, False, completeNone),
103 ("break", keepGoing breakCmd, False, completeIdentifier),
104 ("back", keepGoing backCmd, False, completeNone),
105 ("browse", keepGoing browseCmd, False, completeModule),
106 ("cd", keepGoing changeDirectory, False, completeFilename),
107 ("check", keepGoing checkModule, False, completeHomeModule),
108 ("continue", keepGoing continueCmd, False, completeNone),
109 ("cmd", keepGoing cmdCmd, False, completeIdentifier),
110 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
111 ("def", keepGoing defineMacro, False, completeIdentifier),
112 ("delete", keepGoing deleteCmd, False, completeNone),
113 ("e", keepGoing editFile, False, completeFilename),
114 ("edit", keepGoing editFile, False, completeFilename),
115 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
116 ("force", keepGoing forceCmd, False, completeIdentifier),
117 ("forward", keepGoing forwardCmd, False, completeNone),
118 ("help", keepGoing help, False, completeNone),
119 ("history", keepGoing historyCmd, False, completeNone),
120 ("info", keepGoing info, False, completeIdentifier),
121 ("kind", keepGoing kindOfType, False, completeIdentifier),
122 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
123 ("list", keepGoing listCmd, False, completeNone),
124 ("module", keepGoing setContext, False, completeModule),
125 ("main", keepGoing runMain, False, completeIdentifier),
126 ("print", keepGoing printCmd, False, completeIdentifier),
127 ("quit", quit, False, completeNone),
128 ("reload", keepGoing reloadModule, False, completeNone),
129 ("set", keepGoing setCmd, True, completeSetOptions),
130 ("show", keepGoing showCmd, False, completeNone),
131 ("sprint", keepGoing sprintCmd, False, completeIdentifier),
132 ("step", keepGoing stepCmd, False, completeIdentifier),
133 ("stepover", keepGoing stepOverCmd, False, completeIdentifier),
134 ("type", keepGoing typeOfExpr, False, completeIdentifier),
135 ("trace", keepGoing traceCmd, False, completeIdentifier),
136 ("undef", keepGoing undefineMacro, False, completeMacro),
137 ("unset", keepGoing unsetOptions, True, completeSetOptions)
140 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
141 keepGoing a str = a str >> return False
143 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
144 keepGoingPaths a str = a (toArgs str) >> return False
146 shortHelpText = "use :? for help.\n"
149 " Commands available from the prompt:\n" ++
151 " <statement> evaluate/run <statement>\n" ++
152 " :add <filename> ... add module(s) to the current target set\n" ++
153 " :browse [*]<module> display the names defined by <module>\n" ++
154 " :cd <dir> change directory to <dir>\n" ++
155 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
156 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
157 " :def <cmd> <expr> define a command :<cmd>\n" ++
158 " :edit <file> edit file\n" ++
159 " :edit edit last module\n" ++
160 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
161 " :help, :? display this list of commands\n" ++
162 " :info [<name> ...] display information about the given names\n" ++
163 " :kind <type> show the kind of <type>\n" ++
164 " :load <filename> ... load module(s) and their dependents\n" ++
165 " :main [<arguments> ...] run the main function with the given arguments\n" ++
166 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
167 " :quit exit GHCi\n" ++
168 " :reload reload the current module set\n" ++
169 " :type <expr> show the type of <expr>\n" ++
170 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
171 " :!<command> run the shell command <command>\n" ++
173 " -- Commands for debugging:\n" ++
175 " :abandon at a breakpoint, abandon current computation\n" ++
176 " :back go back in the history (after :trace)\n" ++
177 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
178 " :break <name> set a breakpoint on the specified function\n" ++
179 " :continue resume after a breakpoint\n" ++
180 " :delete <number> delete the specified breakpoint\n" ++
181 " :delete * delete all breakpoints\n" ++
182 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
183 " :forward go forward in the history (after :back)\n" ++
184 " :history [<n>] show the last <n> items in the history (after :trace)\n" ++
185 " :print [<name> ...] prints a value without forcing its computation\n" ++
186 " :sprint [<name> ...] simplifed version of :print\n" ++
187 " :step single-step after stopping at a breakpoint\n"++
188 " :step <expr> single-step into <expr>\n"++
189 " :stepover single-step without following function applications\n"++
190 " :trace trace after stopping at a breakpoint\n"++
191 " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
194 " -- Commands for changing settings:\n" ++
196 " :set <option> ... set options\n" ++
197 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
198 " :set prog <progname> set the value returned by System.getProgName\n" ++
199 " :set prompt <prompt> set the prompt used in GHCi\n" ++
200 " :set editor <cmd> set the command used for :edit\n" ++
201 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
202 " :unset <option> ... unset options\n" ++
204 " Options for ':set' and ':unset':\n" ++
206 " +r revert top-level expressions after each evaluation\n" ++
207 " +s print timing/memory stats after each evaluation\n" ++
208 " +t print type after evaluation\n" ++
209 " -<flags> most GHC command line flags can also be set here\n" ++
210 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
212 " -- Commands for displaying information:\n" ++
214 " :show bindings show the current bindings made at the prompt\n" ++
215 " :show breaks show the active breakpoints\n" ++
216 " :show context show the breakpoint context\n" ++
217 " :show modules show the currently loaded modules\n" ++
218 " :show <setting> show anything that can be set with :set (e.g. args)\n" ++
225 win <- System.Win32.getWindowsDirectory
226 return (win `joinFileName` "notepad.exe")
231 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
232 interactiveUI session srcs maybe_expr = do
233 -- HACK! If we happen to get into an infinite loop (eg the user
234 -- types 'let x=x in x' at the prompt), then the thread will block
235 -- on a blackhole, and become unreachable during GC. The GC will
236 -- detect that it is unreachable and send it the NonTermination
237 -- exception. However, since the thread is unreachable, everything
238 -- it refers to might be finalized, including the standard Handles.
239 -- This sounds like a bug, but we don't have a good solution right
245 -- Initialise buffering for the *interpreted* I/O system
246 initInterpBuffering session
248 when (isNothing maybe_expr) $ do
249 -- Only for GHCi (not runghc and ghc -e):
251 -- Turn buffering off for the compiled program's stdout/stderr
253 -- Turn buffering off for GHCi's stdout
255 hSetBuffering stdout NoBuffering
256 -- We don't want the cmd line to buffer any input that might be
257 -- intended for the program, so unbuffer stdin.
258 hSetBuffering stdin NoBuffering
260 -- initial context is just the Prelude
261 prel_mod <- GHC.findModule session prel_name (Just basePackageId)
262 GHC.setContext session [] [prel_mod]
266 Readline.setAttemptedCompletionFunction (Just completeWord)
267 --Readline.parseAndBind "set show-all-if-ambiguous 1"
269 let symbols = "!#$%&*+/<=>?@\\^|-~"
270 specials = "(),;[]`{}"
272 word_break_chars = spaces ++ specials ++ symbols
274 Readline.setBasicWordBreakCharacters word_break_chars
275 Readline.setCompleterWordBreakCharacters word_break_chars
278 default_editor <- findEditor
280 startGHCi (runGHCi srcs maybe_expr)
281 GHCiState{ progname = "<interactive>",
285 editor = default_editor,
291 tickarrays = emptyModuleEnv,
296 Readline.resetTerminal Nothing
301 prel_name = GHC.mkModuleName "Prelude"
303 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
304 runGHCi paths maybe_expr = do
305 let read_dot_files = not opt_IgnoreDotGhci
307 when (read_dot_files) $ do
310 exists <- io (doesFileExist file)
312 dir_ok <- io (checkPerms ".")
313 file_ok <- io (checkPerms file)
314 when (dir_ok && file_ok) $ do
315 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
318 Right hdl -> fileLoop hdl False
320 when (read_dot_files) $ do
321 -- Read in $HOME/.ghci
322 either_dir <- io (IO.try (getEnv "HOME"))
326 cwd <- io (getCurrentDirectory)
327 when (dir /= cwd) $ do
328 let file = dir ++ "/.ghci"
329 ok <- io (checkPerms file)
331 either_hdl <- io (IO.try (openFile file ReadMode))
334 Right hdl -> fileLoop hdl False
336 -- Perform a :load for files given on the GHCi command line
337 -- When in -e mode, if the load fails then we want to stop
338 -- immediately rather than going on to evaluate the expression.
339 when (not (null paths)) $ do
340 ok <- ghciHandle (\e -> do showException e; return Failed) $
342 when (isJust maybe_expr && failed ok) $
343 io (exitWith (ExitFailure 1))
345 -- if verbosity is greater than 0, or we are connected to a
346 -- terminal, display the prompt in the interactive loop.
347 is_tty <- io (hIsTerminalDevice stdin)
348 dflags <- getDynFlags
349 let show_prompt = verbosity dflags > 0 || is_tty
354 #if defined(mingw32_HOST_OS)
355 -- The win32 Console API mutates the first character of
356 -- type-ahead when reading from it in a non-buffered manner. Work
357 -- around this by flushing the input buffer of type-ahead characters,
358 -- but only if stdin is available.
359 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
361 Left err | isDoesNotExistError err -> return ()
362 | otherwise -> io (ioError err)
363 Right () -> return ()
365 -- initialise the console if necessary
368 -- enter the interactive loop
369 interactiveLoop is_tty show_prompt
371 -- just evaluate the expression we were given
376 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
379 interactiveLoop is_tty show_prompt =
380 -- Ignore ^C exceptions caught here
381 ghciHandleDyn (\e -> case e of
383 #if defined(mingw32_HOST_OS)
386 interactiveLoop is_tty show_prompt
387 _other -> return ()) $
389 ghciUnblock $ do -- unblock necessary if we recursed from the
390 -- exception handler above.
392 -- read commands from stdin
396 else fileLoop stdin show_prompt
398 fileLoop stdin show_prompt
402 -- NOTE: We only read .ghci files if they are owned by the current user,
403 -- and aren't world writable. Otherwise, we could be accidentally
404 -- running code planted by a malicious third party.
406 -- Furthermore, We only read ./.ghci if . is owned by the current user
407 -- and isn't writable by anyone else. I think this is sufficient: we
408 -- don't need to check .. and ../.. etc. because "." always refers to
409 -- the same directory while a process is running.
411 checkPerms :: String -> IO Bool
413 #ifdef mingw32_HOST_OS
416 Util.handle (\_ -> return False) $ do
417 st <- getFileStatus name
419 if fileOwner st /= me then do
420 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
423 let mode = fileMode st
424 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
425 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
427 putStrLn $ "*** WARNING: " ++ name ++
428 " is writable by someone else, IGNORING!"
433 fileLoop :: Handle -> Bool -> GHCi ()
434 fileLoop hdl show_prompt = do
435 when show_prompt $ do
438 l <- io (IO.try (hGetLine hdl))
440 Left e | isEOFError e -> return ()
441 | InvalidArgument <- etype -> return ()
442 | otherwise -> io (ioError e)
443 where etype = ioeGetErrorType e
444 -- treat InvalidArgument in the same way as EOF:
445 -- this can happen if the user closed stdin, or
446 -- perhaps did getContents which closes stdin at
449 case removeSpaces l of
450 "" -> fileLoop hdl show_prompt
451 l -> do quit <- runCommands l
452 if quit then return () else fileLoop hdl show_prompt
455 session <- getSession
456 (toplevs,exports) <- io (GHC.getContext session)
457 resumes <- io $ GHC.getResumeContext session
463 let ix = GHC.resumeHistoryIx r
465 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
467 let hist = GHC.resumeHistory r !! (ix-1)
468 span <- io$ GHC.getHistorySpan session hist
469 return (brackets (ppr (negate ix) <> char ':'
470 <+> ppr span) <> space)
472 dots | r:rs <- resumes, not (null rs) = text "... "
476 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
477 hsep (map (ppr . GHC.moduleName) exports)
479 deflt_prompt = dots <> context_bit <> modules_bit
481 f ('%':'s':xs) = deflt_prompt <> f xs
482 f ('%':'%':xs) = char '%' <> f xs
483 f (x:xs) = char x <> f xs
487 return (showSDoc (f (prompt st)))
491 readlineLoop :: GHCi ()
493 session <- getSession
494 (mod,imports) <- io (GHC.getContext session)
496 saveSession -- for use by completion
498 mb_span <- getCurrentBreakSpan
500 l <- io (readline prompt `finally` setNonBlockingFD 0)
501 -- readline sometimes puts stdin into blocking mode,
502 -- so we need to put it back for the IO library
507 case removeSpaces l of
511 quit <- runCommands l
512 if quit then return () else readlineLoop
515 runCommands :: String -> GHCi Bool
517 q <- ghciHandle handler (doCommand cmd)
518 if q then return True else runNext
524 c:cs -> do setGHCiState st{ cmdqueue = cs }
527 doCommand (':' : cmd) = specialCommand cmd
528 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
531 enqueueCommands :: [String] -> GHCi ()
532 enqueueCommands cmds = do
534 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
537 -- This version is for the GHC command-line option -e. The only difference
538 -- from runCommand is that it catches the ExitException exception and
539 -- exits, rather than printing out the exception.
540 runCommandEval c = ghciHandle handleEval (doCommand c)
542 handleEval (ExitException code) = io (exitWith code)
543 handleEval e = do handler e
544 io (exitWith (ExitFailure 1))
546 doCommand (':' : command) = specialCommand command
548 = do r <- runStmt stmt GHC.RunToCompletion
550 False -> io (exitWith (ExitFailure 1))
551 -- failure to run the command causes exit(1) for ghc -e.
554 runStmt :: String -> SingleStep -> GHCi Bool
556 | null (filter (not.isSpace) stmt) = return False
557 | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
559 = do st <- getGHCiState
560 session <- getSession
561 result <- io $ withProgName (progname st) $ withArgs (args st) $
562 GHC.runStmt session stmt step
563 afterRunStmt (const True) result
566 --afterRunStmt :: GHC.RunResult -> GHCi Bool
567 -- False <=> the statement failed to compile
568 afterRunStmt _ (GHC.RunException e) = throw e
569 afterRunStmt pred run_result = do
570 session <- getSession
571 resumes <- io $ GHC.getResumeContext session
573 GHC.RunOk names -> do
574 show_types <- isOptionSet ShowType
575 when show_types $ printTypeOfNames session names
576 GHC.RunBreak _ names mb_info
577 | isNothing mb_info ||
578 pred (GHC.resumeSpan $ head resumes) -> do
579 printForUser $ ptext SLIT("Stopped at") <+>
580 ppr (GHC.resumeSpan $ head resumes)
581 printTypeOfNames session names
582 maybe (return ()) runBreakCmd mb_info
583 -- run the command set with ":set stop <cmd>"
585 enqueueCommands [stop st]
587 | otherwise -> io(GHC.resume session GHC.SingleStep) >>=
588 afterRunStmt pred >> return ()
592 io installSignalHandlers
593 b <- isOptionSet RevertCAFs
594 io (when b revertCAFs)
596 return (case run_result of GHC.RunOk _ -> True; _ -> False)
598 runBreakCmd :: GHC.BreakInfo -> GHCi ()
599 runBreakCmd info = do
600 let mod = GHC.breakInfo_module info
601 nm = GHC.breakInfo_number info
603 case [ loc | (i,loc) <- breaks st,
604 breakModule loc == mod, breakTick loc == nm ] of
606 loc:_ | null cmd -> return ()
607 | otherwise -> do enqueueCommands [cmd]; return ()
608 where cmd = onBreakCmd loc
610 printTypeOfNames :: Session -> [Name] -> GHCi ()
611 printTypeOfNames session names
612 = mapM_ (printTypeOfName session) $ sortBy compareNames names
614 compareNames :: Name -> Name -> Ordering
615 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
616 where compareWith n = (getOccString n, getSrcSpan n)
618 printTypeOfName :: Session -> Name -> GHCi ()
619 printTypeOfName session n
620 = do maybe_tything <- io (GHC.lookupName session n)
621 case maybe_tything of
623 Just thing -> printTyThing thing
625 specialCommand :: String -> GHCi Bool
626 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
627 specialCommand str = do
628 let (cmd,rest) = break isSpace str
629 maybe_cmd <- io (lookupCommand cmd)
631 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
632 ++ shortHelpText) >> return False)
633 Just (_,f,_,_) -> f (dropWhile isSpace rest)
635 lookupCommand :: String -> IO (Maybe Command)
636 lookupCommand str = do
637 cmds <- readIORef commands
638 -- look for exact match first, then the first prefix match
639 case [ c | c <- cmds, str == cmdName c ] of
640 c:_ -> return (Just c)
641 [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
643 c:_ -> return (Just c)
646 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
647 getCurrentBreakSpan = do
648 session <- getSession
649 resumes <- io $ GHC.getResumeContext session
653 let ix = GHC.resumeHistoryIx r
655 then return (Just (GHC.resumeSpan r))
657 let hist = GHC.resumeHistory r !! (ix-1)
658 span <- io $ GHC.getHistorySpan session hist
661 getCurrentBreakModule :: GHCi (Maybe Module)
662 getCurrentBreakModule = do
663 session <- getSession
664 resumes <- io $ GHC.getResumeContext session
668 let ix = GHC.resumeHistoryIx r
670 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
672 let hist = GHC.resumeHistory r !! (ix-1)
673 return $ Just $ GHC.getHistoryModule hist
675 -----------------------------------------------------------------------------
678 noArgs :: GHCi () -> String -> GHCi ()
680 noArgs m _ = io $ putStrLn "This command takes no arguments"
682 help :: String -> GHCi ()
683 help _ = io (putStr helpText)
685 info :: String -> GHCi ()
686 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
687 info s = do { let names = words s
688 ; session <- getSession
689 ; dflags <- getDynFlags
690 ; let pefas = dopt Opt_PrintExplicitForalls dflags
691 ; mapM_ (infoThing pefas session) names }
693 infoThing pefas session str = io $ do
694 names <- GHC.parseName session str
695 mb_stuffs <- mapM (GHC.getInfo session) names
696 let filtered = filterOutChildren (\(t,f,i) -> t) (catMaybes mb_stuffs)
697 unqual <- GHC.getPrintUnqual session
698 putStrLn (showSDocForUser unqual $
699 vcat (intersperse (text "") $
700 map (pprInfo pefas) filtered))
702 -- Filter out names whose parent is also there Good
703 -- example is '[]', which is both a type and data
704 -- constructor in the same type
705 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
706 filterOutChildren get_thing xs
707 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
709 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
711 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
712 pprInfo pefas (thing, fixity, insts)
713 = pprTyThingInContextLoc pefas thing
714 $$ show_fixity fixity
715 $$ vcat (map GHC.pprInstance insts)
718 | fix == GHC.defaultFixity = empty
719 | otherwise = ppr fix <+> ppr (GHC.getName thing)
721 runMain :: String -> GHCi ()
723 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
724 enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
726 addModule :: [FilePath] -> GHCi ()
728 io (revertCAFs) -- always revert CAFs on load/add.
729 files <- mapM expandPath files
730 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
731 session <- getSession
732 io (mapM_ (GHC.addTarget session) targets)
733 ok <- io (GHC.load session LoadAllTargets)
736 changeDirectory :: String -> GHCi ()
737 changeDirectory dir = do
738 session <- getSession
739 graph <- io (GHC.getModuleGraph session)
740 when (not (null graph)) $
741 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
742 io (GHC.setTargets session [])
743 io (GHC.load session LoadAllTargets)
744 setContextAfterLoad session []
745 io (GHC.workingDirectoryChanged session)
746 dir <- expandPath dir
747 io (setCurrentDirectory dir)
749 editFile :: String -> GHCi ()
751 do file <- if null str then chooseEditFile else return str
755 $ throwDyn (CmdLineError "editor not set, use :set editor")
756 io $ system (cmd ++ ' ':file)
759 -- The user didn't specify a file so we pick one for them.
760 -- Our strategy is to pick the first module that failed to load,
761 -- or otherwise the first target.
763 -- XXX: Can we figure out what happened if the depndecy analysis fails
764 -- (e.g., because the porgrammeer mistyped the name of a module)?
765 -- XXX: Can we figure out the location of an error to pass to the editor?
766 -- XXX: if we could figure out the list of errors that occured during the
767 -- last load/reaload, then we could start the editor focused on the first
769 chooseEditFile :: GHCi String
771 do session <- getSession
772 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
774 graph <- io (GHC.getModuleGraph session)
775 failed_graph <- filterM hasFailed graph
776 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
778 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
781 case pick (order failed_graph) of
782 Just file -> return file
784 do targets <- io (GHC.getTargets session)
785 case msum (map fromTarget targets) of
786 Just file -> return file
787 Nothing -> throwDyn (CmdLineError "No files to edit.")
789 where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
790 fromTarget _ = Nothing -- when would we get a module target?
792 defineMacro :: String -> GHCi ()
794 let (macro_name, definition) = break isSpace s
795 cmds <- io (readIORef commands)
797 then throwDyn (CmdLineError "invalid macro name")
799 if (macro_name `elem` map cmdName cmds)
800 then throwDyn (CmdLineError
801 ("command '" ++ macro_name ++ "' is already defined"))
804 -- give the expression a type signature, so we can be sure we're getting
805 -- something of the right type.
806 let new_expr = '(' : definition ++ ") :: String -> IO String"
808 -- compile the expression
810 maybe_hv <- io (GHC.compileExpr cms new_expr)
813 Just hv -> io (writeIORef commands --
814 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
816 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
818 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
819 enqueueCommands (lines str)
822 undefineMacro :: String -> GHCi ()
823 undefineMacro macro_name = do
824 cmds <- io (readIORef commands)
825 if (macro_name `elem` map cmdName builtin_commands)
826 then throwDyn (CmdLineError
827 ("command '" ++ macro_name ++ "' cannot be undefined"))
829 if (macro_name `notElem` map cmdName cmds)
830 then throwDyn (CmdLineError
831 ("command '" ++ macro_name ++ "' not defined"))
833 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
835 cmdCmd :: String -> GHCi ()
837 let expr = '(' : str ++ ") :: IO String"
838 session <- getSession
839 maybe_hv <- io (GHC.compileExpr session expr)
843 cmds <- io $ (unsafeCoerce# hv :: IO String)
844 enqueueCommands (lines cmds)
847 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
848 loadModule fs = timeIt (loadModule' fs)
850 loadModule_ :: [FilePath] -> GHCi ()
851 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
853 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
854 loadModule' files = do
855 session <- getSession
858 discardActiveBreakPoints
859 io (GHC.setTargets session [])
860 io (GHC.load session LoadAllTargets)
863 let (filenames, phases) = unzip files
864 exp_filenames <- mapM expandPath filenames
865 let files' = zip exp_filenames phases
866 targets <- io (mapM (uncurry GHC.guessTarget) files')
868 -- NOTE: we used to do the dependency anal first, so that if it
869 -- fails we didn't throw away the current set of modules. This would
870 -- require some re-working of the GHC interface, so we'll leave it
871 -- as a ToDo for now.
873 io (GHC.setTargets session targets)
874 doLoad session LoadAllTargets
876 checkModule :: String -> GHCi ()
878 let modl = GHC.mkModuleName m
879 session <- getSession
880 result <- io (GHC.checkModule session modl False)
882 Nothing -> io $ putStrLn "Nothing"
883 Just r -> io $ putStrLn (showSDoc (
884 case GHC.checkedModuleInfo r of
885 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
887 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
889 (text "global names: " <+> ppr global) $$
890 (text "local names: " <+> ppr local)
892 afterLoad (successIf (isJust result)) session
894 reloadModule :: String -> GHCi ()
896 session <- getSession
897 doLoad session $ if null m then LoadAllTargets
898 else LoadUpTo (GHC.mkModuleName m)
901 doLoad session howmuch = do
902 -- turn off breakpoints before we load: we can't turn them off later, because
903 -- the ModBreaks will have gone away.
904 discardActiveBreakPoints
905 ok <- io (GHC.load session howmuch)
909 afterLoad ok session = do
910 io (revertCAFs) -- always revert CAFs on load.
912 graph <- io (GHC.getModuleGraph session)
913 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
914 setContextAfterLoad session graph'
915 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
917 setContextAfterLoad session [] = do
918 prel_mod <- getPrelude
919 io (GHC.setContext session [] [prel_mod])
920 setContextAfterLoad session ms = do
921 -- load a target if one is available, otherwise load the topmost module.
922 targets <- io (GHC.getTargets session)
923 case [ m | Just m <- map (findTarget ms) targets ] of
925 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
926 load_this (last graph')
931 = case filter (`matches` t) ms of
935 summary `matches` Target (TargetModule m) _
936 = GHC.ms_mod_name summary == m
937 summary `matches` Target (TargetFile f _) _
938 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
939 summary `matches` target
942 load_this summary | m <- GHC.ms_mod summary = do
943 b <- io (GHC.moduleIsInterpreted session m)
944 if b then io (GHC.setContext session [m] [])
946 prel_mod <- getPrelude
947 io (GHC.setContext session [] [prel_mod,m])
950 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
951 modulesLoadedMsg ok mods = do
952 dflags <- getDynFlags
953 when (verbosity dflags > 0) $ do
955 | null mods = text "none."
957 punctuate comma (map ppr mods)) <> text "."
960 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
962 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
965 typeOfExpr :: String -> GHCi ()
967 = do cms <- getSession
968 maybe_ty <- io (GHC.exprType cms str)
971 Just ty -> do ty' <- cleanType ty
972 printForUser $ text str <> text " :: " <> ppr ty'
974 kindOfType :: String -> GHCi ()
976 = do cms <- getSession
977 maybe_ty <- io (GHC.typeKind cms str)
980 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
982 quit :: String -> GHCi Bool
985 shellEscape :: String -> GHCi Bool
986 shellEscape str = io (system str >> return False)
988 -----------------------------------------------------------------------------
989 -- Browsing a module's contents
991 browseCmd :: String -> GHCi ()
994 ['*':m] | looksLikeModuleName m -> browseModule m False
995 [m] | looksLikeModuleName m -> browseModule m True
996 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
998 browseModule m exports_only = do
1000 modl <- if exports_only then lookupModule m
1001 else wantInterpretedModule m
1003 -- Temporarily set the context to the module we're interested in,
1004 -- just so we can get an appropriate PrintUnqualified
1005 (as,bs) <- io (GHC.getContext s)
1006 prel_mod <- getPrelude
1007 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1008 else GHC.setContext s [modl] [])
1009 unqual <- io (GHC.getPrintUnqual s)
1010 io (GHC.setContext s as bs)
1012 mb_mod_info <- io $ GHC.getModuleInfo s modl
1014 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1017 | exports_only = GHC.modInfoExports mod_info
1018 | otherwise = GHC.modInfoTopLevelScope mod_info
1021 mb_things <- io $ mapM (GHC.lookupName s) names
1022 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1024 dflags <- getDynFlags
1025 let pefas = dopt Opt_PrintExplicitForalls dflags
1026 io (putStrLn (showSDocForUser unqual (
1027 vcat (map (pprTyThingInContext pefas) filtered_things)
1029 -- ToDo: modInfoInstances currently throws an exception for
1030 -- package modules. When it works, we can do this:
1031 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1033 -----------------------------------------------------------------------------
1034 -- Setting the module context
1037 | all sensible mods = fn mods
1038 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1040 (fn, mods) = case str of
1041 '+':stuff -> (addToContext, words stuff)
1042 '-':stuff -> (removeFromContext, words stuff)
1043 stuff -> (newContext, words stuff)
1045 sensible ('*':m) = looksLikeModuleName m
1046 sensible m = looksLikeModuleName m
1048 separate :: Session -> [String] -> [Module] -> [Module]
1049 -> GHCi ([Module],[Module])
1050 separate session [] as bs = return (as,bs)
1051 separate session (('*':str):ms) as bs = do
1052 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1053 b <- io $ GHC.moduleIsInterpreted session m
1054 if b then separate session ms (m:as) bs
1055 else throwDyn (CmdLineError ("module '"
1056 ++ GHC.moduleNameString (GHC.moduleName m)
1057 ++ "' is not interpreted"))
1058 separate session (str:ms) as bs = do
1059 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1060 separate session ms as (m:bs)
1062 newContext :: [String] -> GHCi ()
1063 newContext strs = do
1065 (as,bs) <- separate s strs [] []
1066 prel_mod <- getPrelude
1067 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1068 io $ GHC.setContext s as bs'
1071 addToContext :: [String] -> GHCi ()
1072 addToContext strs = do
1074 (as,bs) <- io $ GHC.getContext s
1076 (new_as,new_bs) <- separate s strs [] []
1078 let as_to_add = new_as \\ (as ++ bs)
1079 bs_to_add = new_bs \\ (as ++ bs)
1081 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1084 removeFromContext :: [String] -> GHCi ()
1085 removeFromContext strs = do
1087 (as,bs) <- io $ GHC.getContext s
1089 (as_to_remove,bs_to_remove) <- separate s strs [] []
1091 let as' = as \\ (as_to_remove ++ bs_to_remove)
1092 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1094 io $ GHC.setContext s as' bs'
1096 ----------------------------------------------------------------------------
1099 -- set options in the interpreter. Syntax is exactly the same as the
1100 -- ghc command line, except that certain options aren't available (-C,
1103 -- This is pretty fragile: most options won't work as expected. ToDo:
1104 -- figure out which ones & disallow them.
1106 setCmd :: String -> GHCi ()
1108 = do st <- getGHCiState
1109 let opts = options st
1110 io $ putStrLn (showSDoc (
1111 text "options currently set: " <>
1114 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1117 = case toArgs str of
1118 ("args":args) -> setArgs args
1119 ("prog":prog) -> setProg prog
1120 ("prompt":prompt) -> setPrompt (after 6)
1121 ("editor":cmd) -> setEditor (after 6)
1122 ("stop":cmd) -> setStop (after 4)
1123 wds -> setOptions wds
1124 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1128 setGHCiState st{ args = args }
1132 setGHCiState st{ progname = prog }
1134 io (hPutStrLn stderr "syntax: :set prog <progname>")
1138 setGHCiState st{ editor = cmd }
1140 setStop str@(c:_) | isDigit c
1141 = do let (nm_str,rest) = break (not.isDigit) str
1144 let old_breaks = breaks st
1145 if all ((/= nm) . fst) old_breaks
1146 then printForUser (text "Breakpoint" <+> ppr nm <+>
1147 text "does not exist")
1149 let new_breaks = map fn old_breaks
1150 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1151 | otherwise = (i,loc)
1152 setGHCiState st{ breaks = new_breaks }
1155 setGHCiState st{ stop = cmd }
1157 setPrompt value = do
1160 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1161 else setGHCiState st{ prompt = remQuotes value }
1163 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1167 do -- first, deal with the GHCi opts (+s, +t, etc.)
1168 let (plus_opts, minus_opts) = partition isPlus wds
1169 mapM_ setOpt plus_opts
1170 -- then, dynamic flags
1171 newDynFlags minus_opts
1173 newDynFlags minus_opts = do
1174 dflags <- getDynFlags
1175 let pkg_flags = packageFlags dflags
1176 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1178 if (not (null leftovers))
1179 then throwDyn (CmdLineError ("unrecognised flags: " ++
1183 new_pkgs <- setDynFlags dflags'
1185 -- if the package flags changed, we should reset the context
1186 -- and link the new packages.
1187 dflags <- getDynFlags
1188 when (packageFlags dflags /= pkg_flags) $ do
1189 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1190 session <- getSession
1191 io (GHC.setTargets session [])
1192 io (GHC.load session LoadAllTargets)
1193 io (linkPackages dflags new_pkgs)
1194 setContextAfterLoad session []
1198 unsetOptions :: String -> GHCi ()
1200 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1201 let opts = words str
1202 (minus_opts, rest1) = partition isMinus opts
1203 (plus_opts, rest2) = partition isPlus rest1
1205 if (not (null rest2))
1206 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1209 mapM_ unsetOpt plus_opts
1211 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1212 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1214 no_flags <- mapM no_flag minus_opts
1215 newDynFlags no_flags
1217 isMinus ('-':s) = True
1220 isPlus ('+':s) = True
1224 = case strToGHCiOpt str of
1225 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1226 Just o -> setOption o
1229 = case strToGHCiOpt str of
1230 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1231 Just o -> unsetOption o
1233 strToGHCiOpt :: String -> (Maybe GHCiOption)
1234 strToGHCiOpt "s" = Just ShowTiming
1235 strToGHCiOpt "t" = Just ShowType
1236 strToGHCiOpt "r" = Just RevertCAFs
1237 strToGHCiOpt _ = Nothing
1239 optToStr :: GHCiOption -> String
1240 optToStr ShowTiming = "s"
1241 optToStr ShowType = "t"
1242 optToStr RevertCAFs = "r"
1244 -- ---------------------------------------------------------------------------
1250 ["args"] -> io $ putStrLn (show (args st))
1251 ["prog"] -> io $ putStrLn (show (progname st))
1252 ["prompt"] -> io $ putStrLn (show (prompt st))
1253 ["editor"] -> io $ putStrLn (show (editor st))
1254 ["stop"] -> io $ putStrLn (show (stop st))
1255 ["modules" ] -> showModules
1256 ["bindings"] -> showBindings
1257 ["linker"] -> io showLinkerState
1258 ["breaks"] -> showBkptTable
1259 ["context"] -> showContext
1260 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1263 session <- getSession
1264 let show_one ms = do m <- io (GHC.showModule session ms)
1266 graph <- io (GHC.getModuleGraph session)
1267 mapM_ show_one graph
1271 unqual <- io (GHC.getPrintUnqual s)
1272 bindings <- io (GHC.getBindings s)
1273 mapM_ printTyThing $ sortBy compareTyThings bindings
1276 compareTyThings :: TyThing -> TyThing -> Ordering
1277 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1279 printTyThing :: TyThing -> GHCi ()
1280 printTyThing (AnId id) = do
1281 ty' <- cleanType (GHC.idType id)
1282 printForUser $ ppr id <> text " :: " <> ppr ty'
1283 printTyThing _ = return ()
1285 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1286 cleanType :: Type -> GHCi Type
1288 dflags <- getDynFlags
1289 if dopt Opt_PrintExplicitForalls dflags
1291 else return $! GHC.dropForAlls ty
1293 showBkptTable :: GHCi ()
1296 printForUser $ prettyLocations (breaks st)
1298 showContext :: GHCi ()
1300 session <- getSession
1301 resumes <- io $ GHC.getResumeContext session
1302 printForUser $ vcat (map pp_resume (reverse resumes))
1305 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1306 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1309 -- -----------------------------------------------------------------------------
1312 completeNone :: String -> IO [String]
1313 completeNone w = return []
1316 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1317 completeWord w start end = do
1318 line <- Readline.getLineBuffer
1320 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1322 | Just c <- is_cmd line -> do
1323 maybe_cmd <- lookupCommand c
1324 let (n,w') = selectWord (words' 0 line)
1326 Nothing -> return Nothing
1327 Just (_,_,False,complete) -> wrapCompleter complete w
1328 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1329 return (map (drop n) rets)
1330 in wrapCompleter complete' w'
1332 --printf "complete %s, start = %d, end = %d\n" w start end
1333 wrapCompleter completeIdentifier w
1334 where words' _ [] = []
1335 words' n str = let (w,r) = break isSpace str
1336 (s,r') = span isSpace r
1337 in (n,w):words' (n+length w+length s) r'
1338 -- In a Haskell expression we want to parse 'a-b' as three words
1339 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1340 -- only be a single word.
1341 selectWord [] = (0,w)
1342 selectWord ((offset,x):xs)
1343 | offset+length x >= start = (start-offset,take (end-offset) x)
1344 | otherwise = selectWord xs
1347 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1348 | otherwise = Nothing
1351 cmds <- readIORef commands
1352 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1354 completeMacro w = do
1355 cmds <- readIORef commands
1356 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1357 return (filter (w `isPrefixOf`) cmds')
1359 completeIdentifier w = do
1361 rdrs <- GHC.getRdrNamesInScope s
1362 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1364 completeModule w = do
1366 dflags <- GHC.getSessionDynFlags s
1367 let pkg_mods = allExposedModules dflags
1368 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1370 completeHomeModule w = do
1372 g <- GHC.getModuleGraph s
1373 let home_mods = map GHC.ms_mod_name g
1374 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1376 completeSetOptions w = do
1377 return (filter (w `isPrefixOf`) options)
1378 where options = "args":"prog":allFlags
1380 completeFilename = Readline.filenameCompletionFunction
1382 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1384 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1385 unionComplete f1 f2 w = do
1390 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1391 wrapCompleter fun w = do
1394 [] -> return Nothing
1395 [x] -> return (Just (x,[]))
1396 xs -> case getCommonPrefix xs of
1397 "" -> return (Just ("",xs))
1398 pref -> return (Just (pref,xs))
1400 getCommonPrefix :: [String] -> String
1401 getCommonPrefix [] = ""
1402 getCommonPrefix (s:ss) = foldl common s ss
1403 where common s "" = ""
1405 common (c:cs) (d:ds)
1406 | c == d = c : common cs ds
1409 allExposedModules :: DynFlags -> [ModuleName]
1410 allExposedModules dflags
1411 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1413 pkg_db = pkgIdMap (pkgState dflags)
1415 completeCmd = completeNone
1416 completeMacro = completeNone
1417 completeIdentifier = completeNone
1418 completeModule = completeNone
1419 completeHomeModule = completeNone
1420 completeSetOptions = completeNone
1421 completeFilename = completeNone
1422 completeHomeModuleOrFile=completeNone
1423 completeBkpt = completeNone
1426 -- ---------------------------------------------------------------------------
1427 -- User code exception handling
1429 -- This is the exception handler for exceptions generated by the
1430 -- user's code and exceptions coming from children sessions;
1431 -- it normally just prints out the exception. The
1432 -- handler must be recursive, in case showing the exception causes
1433 -- more exceptions to be raised.
1435 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1436 -- raising another exception. We therefore don't put the recursive
1437 -- handler arond the flushing operation, so if stderr is closed
1438 -- GHCi will just die gracefully rather than going into an infinite loop.
1439 handler :: Exception -> GHCi Bool
1441 handler exception = do
1443 io installSignalHandlers
1444 ghciHandle handler (showException exception >> return False)
1446 showException (DynException dyn) =
1447 case fromDynamic dyn of
1448 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1449 Just Interrupted -> io (putStrLn "Interrupted.")
1450 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1451 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1452 Just other_ghc_ex -> io (print other_ghc_ex)
1454 showException other_exception
1455 = io (putStrLn ("*** Exception: " ++ show other_exception))
1457 -----------------------------------------------------------------------------
1458 -- recursive exception handlers
1460 -- Don't forget to unblock async exceptions in the handler, or if we're
1461 -- in an exception loop (eg. let a = error a in a) the ^C exception
1462 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1464 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1465 ghciHandle h (GHCi m) = GHCi $ \s ->
1466 Exception.catch (m s)
1467 (\e -> unGHCi (ghciUnblock (h e)) s)
1469 ghciUnblock :: GHCi a -> GHCi a
1470 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1473 -- ----------------------------------------------------------------------------
1476 expandPath :: String -> GHCi String
1478 case dropWhile isSpace path of
1480 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1481 return (tilde ++ '/':d)
1485 wantInterpretedModule :: String -> GHCi Module
1486 wantInterpretedModule str = do
1487 session <- getSession
1488 modl <- lookupModule str
1489 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1490 when (not is_interpreted) $
1491 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1494 wantNameFromInterpretedModule noCanDo str and_then = do
1495 session <- getSession
1496 names <- io $ GHC.parseName session str
1500 let modl = GHC.nameModule n
1501 if not (GHC.isExternalName n)
1502 then noCanDo n $ ppr n <>
1503 text " is not defined in an interpreted module"
1505 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1506 if not is_interpreted
1507 then noCanDo n $ text "module " <> ppr modl <>
1508 text " is not interpreted"
1511 -- ----------------------------------------------------------------------------
1512 -- Windows console setup
1514 setUpConsole :: IO ()
1516 #ifdef mingw32_HOST_OS
1517 -- On Windows we need to set a known code page, otherwise the characters
1518 -- we read from the console will be be in some strange encoding, and
1519 -- similarly for characters we write to the console.
1521 -- At the moment, GHCi pretends all input is Latin-1. In the
1522 -- future we should support UTF-8, but for now we set the code pages
1525 -- It seems you have to set the font in the console window to
1526 -- a Unicode font in order for output to work properly,
1527 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1528 -- (see MSDN for SetConsoleOutputCP()).
1530 setConsoleCP 28591 -- ISO Latin-1
1531 setConsoleOutputCP 28591 -- ISO Latin-1
1535 -- -----------------------------------------------------------------------------
1536 -- commands for debugger
1538 sprintCmd = pprintCommand False False
1539 printCmd = pprintCommand True False
1540 forceCmd = pprintCommand False True
1542 pprintCommand bind force str = do
1543 session <- getSession
1544 io $ pprintClosureCommand session bind force str
1546 stepCmd :: String -> GHCi ()
1547 stepCmd [] = doContinue (const True) GHC.SingleStep
1548 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1551 mb_span <- getCurrentBreakSpan
1553 Nothing -> stepCmd []
1555 Just mod <- getCurrentBreakModule
1556 parent <- enclosingTickSpan mod loc
1557 allTicksRightmost <- (sortBy rightmost . map snd) `fmap`
1559 let lastTick = null allTicksRightmost ||
1560 head allTicksRightmost == loc
1562 then doContinue (`isSubspanOf` parent) GHC.SingleStep
1563 else doContinue (const True) GHC.SingleStep
1565 stepOverCmd expression = stepCmd expression
1568 So, the only tricky part in stepOver is detecting that we have
1569 arrived to the last tick in an expression, in which case we must
1570 step normally to the next tick.
1572 1. Retrieve the enclosing expression block (with a tick)
1573 2. Retrieve all the ticks there and sort them out by 'rightness'
1574 3. See if the current tick turned out the first one in the list
1577 --ticksIn :: Module -> SrcSpan -> GHCi [Tick]
1578 ticksIn mod src = do
1579 ticks <- getTickArray mod
1580 let lines = [srcSpanStartLine src .. srcSpanEndLine src]
1581 return [ t | line <- lines
1582 , t@(_,span) <- ticks ! line
1583 , srcSpanStart src <= srcSpanStart span
1584 , srcSpanEnd src >= srcSpanEnd span
1587 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1588 enclosingTickSpan mod src = do
1589 ticks <- getTickArray mod
1590 let line = srcSpanStartLine src
1591 ASSERT (inRange (bounds ticks) line) do
1592 let enclosing_spans = [ span | (_,span) <- ticks ! line
1593 , srcSpanEnd span >= srcSpanEnd src]
1594 return . head . sortBy leftmost_largest $ enclosing_spans
1596 traceCmd :: String -> GHCi ()
1597 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1598 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1600 continueCmd :: String -> GHCi ()
1601 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1603 -- doContinue :: SingleStep -> GHCi ()
1604 doContinue pred step = do
1605 session <- getSession
1606 runResult <- io $ GHC.resume session step
1607 afterRunStmt pred runResult
1610 abandonCmd :: String -> GHCi ()
1611 abandonCmd = noArgs $ do
1613 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1614 when (not b) $ io $ putStrLn "There is no computation running."
1617 deleteCmd :: String -> GHCi ()
1618 deleteCmd argLine = do
1619 deleteSwitch $ words argLine
1621 deleteSwitch :: [String] -> GHCi ()
1623 io $ putStrLn "The delete command requires at least one argument."
1624 -- delete all break points
1625 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1626 deleteSwitch idents = do
1627 mapM_ deleteOneBreak idents
1629 deleteOneBreak :: String -> GHCi ()
1631 | all isDigit str = deleteBreak (read str)
1632 | otherwise = return ()
1634 historyCmd :: String -> GHCi ()
1636 | null arg = history 20
1637 | all isDigit arg = history (read arg)
1638 | otherwise = io $ putStrLn "Syntax: :history [num]"
1642 resumes <- io $ GHC.getResumeContext s
1644 [] -> io $ putStrLn "Not stopped at a breakpoint"
1646 let hist = GHC.resumeHistory r
1647 (took,rest) = splitAt num hist
1648 spans <- mapM (io . GHC.getHistorySpan s) took
1649 let nums = map (printf "-%-3d:") [(1::Int)..]
1650 let names = map GHC.historyEnclosingDecl took
1651 printForUser (vcat(zipWith3
1652 (\x y z -> x <+> y <+> z)
1654 (map (bold . ppr) names)
1655 (map (parens . ppr) spans)))
1656 io $ putStrLn $ if null rest then "<end of history>" else "..."
1658 bold c | do_bold = text start_bold <> c <> text end_bold
1661 backCmd :: String -> GHCi ()
1662 backCmd = noArgs $ do
1664 (names, ix, span) <- io $ GHC.back s
1665 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1666 printTypeOfNames s names
1667 -- run the command set with ":set stop <cmd>"
1669 enqueueCommands [stop st]
1671 forwardCmd :: String -> GHCi ()
1672 forwardCmd = noArgs $ do
1674 (names, ix, span) <- io $ GHC.forward s
1675 printForUser $ (if (ix == 0)
1676 then ptext SLIT("Stopped at")
1677 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1678 printTypeOfNames s names
1679 -- run the command set with ":set stop <cmd>"
1681 enqueueCommands [stop st]
1683 -- handle the "break" command
1684 breakCmd :: String -> GHCi ()
1685 breakCmd argLine = do
1686 session <- getSession
1687 breakSwitch session $ words argLine
1689 breakSwitch :: Session -> [String] -> GHCi ()
1690 breakSwitch _session [] = do
1691 io $ putStrLn "The break command requires at least one argument."
1692 breakSwitch session args@(arg1:rest)
1693 | looksLikeModuleName arg1 = do
1694 mod <- wantInterpretedModule arg1
1695 breakByModule session mod rest
1696 | all isDigit arg1 = do
1697 (toplevel, _) <- io $ GHC.getContext session
1699 (mod : _) -> breakByModuleLine mod (read arg1) rest
1701 io $ putStrLn "Cannot find default module for breakpoint."
1702 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1703 | otherwise = do -- try parsing it as an identifier
1704 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1705 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1706 if GHC.isGoodSrcLoc loc
1707 then findBreakAndSet (GHC.nameModule name) $
1708 findBreakByCoord (Just (GHC.srcLocFile loc))
1709 (GHC.srcLocLine loc,
1711 else noCanDo name $ text "can't find its location: " <> ppr loc
1713 noCanDo n why = printForUser $
1714 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1716 breakByModule :: Session -> Module -> [String] -> GHCi ()
1717 breakByModule session mod args@(arg1:rest)
1718 | all isDigit arg1 = do -- looks like a line number
1719 breakByModuleLine mod (read arg1) rest
1720 breakByModule session mod _
1723 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1724 breakByModuleLine mod line args
1725 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1726 | [col] <- args, all isDigit col =
1727 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1728 | otherwise = breakSyntax
1730 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1732 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1733 findBreakAndSet mod lookupTickTree = do
1734 tickArray <- getTickArray mod
1735 (breakArray, _) <- getModBreak mod
1736 case lookupTickTree tickArray of
1737 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1738 Just (tick, span) -> do
1739 success <- io $ setBreakFlag True breakArray tick
1740 session <- getSession
1744 recordBreak $ BreakLocation
1751 text "Breakpoint " <> ppr nm <>
1753 then text " was already set at " <> ppr span
1754 else text " activated at " <> ppr span
1756 printForUser $ text "Breakpoint could not be activated at"
1759 -- When a line number is specified, the current policy for choosing
1760 -- the best breakpoint is this:
1761 -- - the leftmost complete subexpression on the specified line, or
1762 -- - the leftmost subexpression starting on the specified line, or
1763 -- - the rightmost subexpression enclosing the specified line
1765 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1766 findBreakByLine line arr
1767 | not (inRange (bounds arr) line) = Nothing
1769 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
1770 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
1771 listToMaybe (sortBy (rightmost `on` snd) ticks)
1775 starts_here = [ tick | tick@(nm,span) <- ticks,
1776 GHC.srcSpanStartLine span == line ]
1778 (complete,incomplete) = partition ends_here starts_here
1779 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1781 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1782 -> Maybe (BreakIndex,SrcSpan)
1783 findBreakByCoord mb_file (line, col) arr
1784 | not (inRange (bounds arr) line) = Nothing
1786 listToMaybe (sortBy (rightmost `on` snd) contains ++
1787 sortBy (leftmost_smallest `on` snd) after_here)
1791 -- the ticks that span this coordinate
1792 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1793 is_correct_file span ]
1795 is_correct_file span
1796 | Just f <- mb_file = GHC.srcSpanFile span == f
1799 after_here = [ tick | tick@(nm,span) <- ticks,
1800 GHC.srcSpanStartLine span == line,
1801 GHC.srcSpanStartCol span >= col ]
1803 -- for now, use ANSI bold on Unixy systems. On Windows, we add a line
1804 -- of carets under the active expression instead. The Windows console
1805 -- doesn't support ANSI escape sequences, and most Unix terminals
1806 -- (including xterm) do, so this is a reasonable guess until we have a
1807 -- proper termcap/terminfo library.
1808 #if !defined(mingw32_TARGET_OS)
1814 start_bold = "\ESC[1m"
1815 end_bold = "\ESC[0m"
1817 listCmd :: String -> GHCi ()
1819 mb_span <- getCurrentBreakSpan
1821 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1822 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1823 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
1824 listCmd str = list2 (words str)
1826 list2 [arg] | all isDigit arg = do
1827 session <- getSession
1828 (toplevel, _) <- io $ GHC.getContext session
1830 [] -> io $ putStrLn "No module to list"
1831 (mod : _) -> listModuleLine mod (read arg)
1832 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1833 mod <- wantInterpretedModule arg1
1834 listModuleLine mod (read arg2)
1836 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1837 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1838 if GHC.isGoodSrcLoc loc
1840 tickArray <- getTickArray (GHC.nameModule name)
1841 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1842 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1845 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1846 Just (_,span) -> io $ listAround span False
1848 noCanDo name $ text "can't find its location: " <>
1851 noCanDo n why = printForUser $
1852 text "cannot list source code for " <> ppr n <> text ": " <> why
1854 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1856 listModuleLine :: Module -> Int -> GHCi ()
1857 listModuleLine modl line = do
1858 session <- getSession
1859 graph <- io (GHC.getModuleGraph session)
1860 let this = filter ((== modl) . GHC.ms_mod) graph
1862 [] -> panic "listModuleLine"
1864 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1865 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1866 io $ listAround (GHC.srcLocSpan loc) False
1868 -- | list a section of a source file around a particular SrcSpan.
1869 -- If the highlight flag is True, also highlight the span using
1870 -- start_bold/end_bold.
1871 listAround span do_highlight = do
1872 contents <- BS.readFile (unpackFS file)
1874 lines = BS.split '\n' contents
1875 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1876 drop (line1 - 1 - pad_before) $ lines
1877 fst_line = max 1 (line1 - pad_before)
1878 line_nos = [ fst_line .. ]
1880 highlighted | do_highlight = zipWith highlight line_nos these_lines
1881 | otherwise = these_lines
1883 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1884 prefixed = zipWith BS.append bs_line_nos highlighted
1886 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1888 file = GHC.srcSpanFile span
1889 line1 = GHC.srcSpanStartLine span
1890 col1 = GHC.srcSpanStartCol span
1891 line2 = GHC.srcSpanEndLine span
1892 col2 = GHC.srcSpanEndCol span
1894 pad_before | line1 == 1 = 0
1898 highlight | do_bold = highlight_bold
1899 | otherwise = highlight_carets
1901 highlight_bold no line
1902 | no == line1 && no == line2
1903 = let (a,r) = BS.splitAt col1 line
1904 (b,c) = BS.splitAt (col2-col1) r
1906 BS.concat [a,BS.pack start_bold,b,BS.pack end_bold,c]
1908 = let (a,b) = BS.splitAt col1 line in
1909 BS.concat [a, BS.pack start_bold, b]
1911 = let (a,b) = BS.splitAt col2 line in
1912 BS.concat [a, BS.pack end_bold, b]
1915 highlight_carets no line
1916 | no == line1 && no == line2
1917 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1918 BS.replicate (col2-col1) '^']
1920 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1921 BS.replicate (BS.length line-col1) '^']
1923 = BS.concat [line, nl, indent, BS.replicate col2 '^']
1926 indent = BS.pack " "
1927 nl = BS.singleton '\n'
1929 -- --------------------------------------------------------------------------
1932 getTickArray :: Module -> GHCi TickArray
1933 getTickArray modl = do
1935 let arrmap = tickarrays st
1936 case lookupModuleEnv arrmap modl of
1937 Just arr -> return arr
1939 (breakArray, ticks) <- getModBreak modl
1940 let arr = mkTickArray (assocs ticks)
1941 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1944 discardTickArrays :: GHCi ()
1945 discardTickArrays = do
1947 setGHCiState st{tickarrays = emptyModuleEnv}
1949 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1951 = accumArray (flip (:)) [] (1, max_line)
1952 [ (line, (nm,span)) | (nm,span) <- ticks,
1953 line <- srcSpanLines span ]
1955 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1956 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1957 GHC.srcSpanEndLine span ]
1959 lookupModule :: String -> GHCi Module
1960 lookupModule modName
1961 = do session <- getSession
1962 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1964 -- don't reset the counter back to zero?
1965 discardActiveBreakPoints :: GHCi ()
1966 discardActiveBreakPoints = do
1968 mapM (turnOffBreak.snd) (breaks st)
1969 setGHCiState $ st { breaks = [] }
1971 deleteBreak :: Int -> GHCi ()
1972 deleteBreak identity = do
1974 let oldLocations = breaks st
1975 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
1977 then printForUser (text "Breakpoint" <+> ppr identity <+>
1978 text "does not exist")
1980 mapM (turnOffBreak.snd) this
1981 setGHCiState $ st { breaks = rest }
1983 turnOffBreak loc = do
1984 (arr, _) <- getModBreak (breakModule loc)
1985 io $ setBreakFlag False arr (breakTick loc)
1987 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1988 getModBreak mod = do
1989 session <- getSession
1990 Just mod_info <- io $ GHC.getModuleInfo session mod
1991 let modBreaks = GHC.modInfoModBreaks mod_info
1992 let array = GHC.modBreaks_flags modBreaks
1993 let ticks = GHC.modBreaks_locs modBreaks
1994 return (array, ticks)
1996 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1997 setBreakFlag toggle array index
1998 | toggle = GHC.setBreakOn array index
1999 | otherwise = GHC.setBreakOff array index