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 `fmap` 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 io (revertCAFs) -- always revert CAFs on reload.
897 discardActiveBreakPoints
898 session <- getSession
899 doLoad session $ if null m then LoadAllTargets
900 else LoadUpTo (GHC.mkModuleName m)
903 doLoad session howmuch = do
904 -- turn off breakpoints before we load: we can't turn them off later, because
905 -- the ModBreaks will have gone away.
906 discardActiveBreakPoints
907 ok <- io (GHC.load session howmuch)
911 afterLoad ok session = do
912 io (revertCAFs) -- always revert CAFs on load.
914 graph <- io (GHC.getModuleGraph session)
915 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
916 setContextAfterLoad session graph'
917 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
919 setContextAfterLoad session [] = do
920 prel_mod <- getPrelude
921 io (GHC.setContext session [] [prel_mod])
922 setContextAfterLoad session ms = do
923 -- load a target if one is available, otherwise load the topmost module.
924 targets <- io (GHC.getTargets session)
925 case [ m | Just m <- map (findTarget ms) targets ] of
927 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
928 load_this (last graph')
933 = case filter (`matches` t) ms of
937 summary `matches` Target (TargetModule m) _
938 = GHC.ms_mod_name summary == m
939 summary `matches` Target (TargetFile f _) _
940 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
941 summary `matches` target
944 load_this summary | m <- GHC.ms_mod summary = do
945 b <- io (GHC.moduleIsInterpreted session m)
946 if b then io (GHC.setContext session [m] [])
948 prel_mod <- getPrelude
949 io (GHC.setContext session [] [prel_mod,m])
952 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
953 modulesLoadedMsg ok mods = do
954 dflags <- getDynFlags
955 when (verbosity dflags > 0) $ do
957 | null mods = text "none."
959 punctuate comma (map ppr mods)) <> text "."
962 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
964 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
967 typeOfExpr :: String -> GHCi ()
969 = do cms <- getSession
970 maybe_ty <- io (GHC.exprType cms str)
973 Just ty -> do ty' <- cleanType ty
974 printForUser $ text str <> text " :: " <> ppr ty'
976 kindOfType :: String -> GHCi ()
978 = do cms <- getSession
979 maybe_ty <- io (GHC.typeKind cms str)
982 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
984 quit :: String -> GHCi Bool
987 shellEscape :: String -> GHCi Bool
988 shellEscape str = io (system str >> return False)
990 -----------------------------------------------------------------------------
991 -- Browsing a module's contents
993 browseCmd :: String -> GHCi ()
996 ['*':m] | looksLikeModuleName m -> browseModule m False
997 [m] | looksLikeModuleName m -> browseModule m True
998 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1000 browseModule m exports_only = do
1002 modl <- if exports_only then lookupModule m
1003 else wantInterpretedModule m
1005 -- Temporarily set the context to the module we're interested in,
1006 -- just so we can get an appropriate PrintUnqualified
1007 (as,bs) <- io (GHC.getContext s)
1008 prel_mod <- getPrelude
1009 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1010 else GHC.setContext s [modl] [])
1011 unqual <- io (GHC.getPrintUnqual s)
1012 io (GHC.setContext s as bs)
1014 mb_mod_info <- io $ GHC.getModuleInfo s modl
1016 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1019 | exports_only = GHC.modInfoExports mod_info
1020 | otherwise = GHC.modInfoTopLevelScope mod_info
1023 mb_things <- io $ mapM (GHC.lookupName s) names
1024 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1026 dflags <- getDynFlags
1027 let pefas = dopt Opt_PrintExplicitForalls dflags
1028 io (putStrLn (showSDocForUser unqual (
1029 vcat (map (pprTyThingInContext pefas) filtered_things)
1031 -- ToDo: modInfoInstances currently throws an exception for
1032 -- package modules. When it works, we can do this:
1033 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1035 -----------------------------------------------------------------------------
1036 -- Setting the module context
1039 | all sensible mods = fn mods
1040 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1042 (fn, mods) = case str of
1043 '+':stuff -> (addToContext, words stuff)
1044 '-':stuff -> (removeFromContext, words stuff)
1045 stuff -> (newContext, words stuff)
1047 sensible ('*':m) = looksLikeModuleName m
1048 sensible m = looksLikeModuleName m
1050 separate :: Session -> [String] -> [Module] -> [Module]
1051 -> GHCi ([Module],[Module])
1052 separate session [] as bs = return (as,bs)
1053 separate session (('*':str):ms) as bs = do
1054 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1055 b <- io $ GHC.moduleIsInterpreted session m
1056 if b then separate session ms (m:as) bs
1057 else throwDyn (CmdLineError ("module '"
1058 ++ GHC.moduleNameString (GHC.moduleName m)
1059 ++ "' is not interpreted"))
1060 separate session (str:ms) as bs = do
1061 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1062 separate session ms as (m:bs)
1064 newContext :: [String] -> GHCi ()
1065 newContext strs = do
1067 (as,bs) <- separate s strs [] []
1068 prel_mod <- getPrelude
1069 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1070 io $ GHC.setContext s as bs'
1073 addToContext :: [String] -> GHCi ()
1074 addToContext strs = do
1076 (as,bs) <- io $ GHC.getContext s
1078 (new_as,new_bs) <- separate s strs [] []
1080 let as_to_add = new_as \\ (as ++ bs)
1081 bs_to_add = new_bs \\ (as ++ bs)
1083 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1086 removeFromContext :: [String] -> GHCi ()
1087 removeFromContext strs = do
1089 (as,bs) <- io $ GHC.getContext s
1091 (as_to_remove,bs_to_remove) <- separate s strs [] []
1093 let as' = as \\ (as_to_remove ++ bs_to_remove)
1094 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1096 io $ GHC.setContext s as' bs'
1098 ----------------------------------------------------------------------------
1101 -- set options in the interpreter. Syntax is exactly the same as the
1102 -- ghc command line, except that certain options aren't available (-C,
1105 -- This is pretty fragile: most options won't work as expected. ToDo:
1106 -- figure out which ones & disallow them.
1108 setCmd :: String -> GHCi ()
1110 = do st <- getGHCiState
1111 let opts = options st
1112 io $ putStrLn (showSDoc (
1113 text "options currently set: " <>
1116 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1119 = case toArgs str of
1120 ("args":args) -> setArgs args
1121 ("prog":prog) -> setProg prog
1122 ("prompt":prompt) -> setPrompt (after 6)
1123 ("editor":cmd) -> setEditor (after 6)
1124 ("stop":cmd) -> setStop (after 4)
1125 wds -> setOptions wds
1126 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1130 setGHCiState st{ args = args }
1134 setGHCiState st{ progname = prog }
1136 io (hPutStrLn stderr "syntax: :set prog <progname>")
1140 setGHCiState st{ editor = cmd }
1142 setStop str@(c:_) | isDigit c
1143 = do let (nm_str,rest) = break (not.isDigit) str
1146 let old_breaks = breaks st
1147 if all ((/= nm) . fst) old_breaks
1148 then printForUser (text "Breakpoint" <+> ppr nm <+>
1149 text "does not exist")
1151 let new_breaks = map fn old_breaks
1152 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1153 | otherwise = (i,loc)
1154 setGHCiState st{ breaks = new_breaks }
1157 setGHCiState st{ stop = cmd }
1159 setPrompt value = do
1162 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1163 else setGHCiState st{ prompt = remQuotes value }
1165 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1169 do -- first, deal with the GHCi opts (+s, +t, etc.)
1170 let (plus_opts, minus_opts) = partition isPlus wds
1171 mapM_ setOpt plus_opts
1172 -- then, dynamic flags
1173 newDynFlags minus_opts
1175 newDynFlags minus_opts = do
1176 dflags <- getDynFlags
1177 let pkg_flags = packageFlags dflags
1178 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1180 if (not (null leftovers))
1181 then throwDyn (CmdLineError ("unrecognised flags: " ++
1185 new_pkgs <- setDynFlags dflags'
1187 -- if the package flags changed, we should reset the context
1188 -- and link the new packages.
1189 dflags <- getDynFlags
1190 when (packageFlags dflags /= pkg_flags) $ do
1191 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1192 session <- getSession
1193 io (GHC.setTargets session [])
1194 io (GHC.load session LoadAllTargets)
1195 io (linkPackages dflags new_pkgs)
1196 setContextAfterLoad session []
1200 unsetOptions :: String -> GHCi ()
1202 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1203 let opts = words str
1204 (minus_opts, rest1) = partition isMinus opts
1205 (plus_opts, rest2) = partition isPlus rest1
1207 if (not (null rest2))
1208 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1211 mapM_ unsetOpt plus_opts
1213 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1214 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1216 no_flags <- mapM no_flag minus_opts
1217 newDynFlags no_flags
1219 isMinus ('-':s) = True
1222 isPlus ('+':s) = True
1226 = case strToGHCiOpt str of
1227 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1228 Just o -> setOption o
1231 = case strToGHCiOpt str of
1232 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1233 Just o -> unsetOption o
1235 strToGHCiOpt :: String -> (Maybe GHCiOption)
1236 strToGHCiOpt "s" = Just ShowTiming
1237 strToGHCiOpt "t" = Just ShowType
1238 strToGHCiOpt "r" = Just RevertCAFs
1239 strToGHCiOpt _ = Nothing
1241 optToStr :: GHCiOption -> String
1242 optToStr ShowTiming = "s"
1243 optToStr ShowType = "t"
1244 optToStr RevertCAFs = "r"
1246 -- ---------------------------------------------------------------------------
1252 ["args"] -> io $ putStrLn (show (args st))
1253 ["prog"] -> io $ putStrLn (show (progname st))
1254 ["prompt"] -> io $ putStrLn (show (prompt st))
1255 ["editor"] -> io $ putStrLn (show (editor st))
1256 ["stop"] -> io $ putStrLn (show (stop st))
1257 ["modules" ] -> showModules
1258 ["bindings"] -> showBindings
1259 ["linker"] -> io showLinkerState
1260 ["breaks"] -> showBkptTable
1261 ["context"] -> showContext
1262 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1265 session <- getSession
1266 let show_one ms = do m <- io (GHC.showModule session ms)
1268 graph <- io (GHC.getModuleGraph session)
1269 mapM_ show_one graph
1273 unqual <- io (GHC.getPrintUnqual s)
1274 bindings <- io (GHC.getBindings s)
1275 mapM_ printTyThing $ sortBy compareTyThings bindings
1278 compareTyThings :: TyThing -> TyThing -> Ordering
1279 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1281 printTyThing :: TyThing -> GHCi ()
1282 printTyThing (AnId id) = do
1283 ty' <- cleanType (GHC.idType id)
1284 printForUser $ ppr id <> text " :: " <> ppr ty'
1285 printTyThing _ = return ()
1287 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1288 cleanType :: Type -> GHCi Type
1290 dflags <- getDynFlags
1291 if dopt Opt_PrintExplicitForalls dflags
1293 else return $! GHC.dropForAlls ty
1295 showBkptTable :: GHCi ()
1298 printForUser $ prettyLocations (breaks st)
1300 showContext :: GHCi ()
1302 session <- getSession
1303 resumes <- io $ GHC.getResumeContext session
1304 printForUser $ vcat (map pp_resume (reverse resumes))
1307 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1308 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1311 -- -----------------------------------------------------------------------------
1314 completeNone :: String -> IO [String]
1315 completeNone w = return []
1318 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1319 completeWord w start end = do
1320 line <- Readline.getLineBuffer
1322 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1324 | Just c <- is_cmd line -> do
1325 maybe_cmd <- lookupCommand c
1326 let (n,w') = selectWord (words' 0 line)
1328 Nothing -> return Nothing
1329 Just (_,_,False,complete) -> wrapCompleter complete w
1330 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1331 return (map (drop n) rets)
1332 in wrapCompleter complete' w'
1334 --printf "complete %s, start = %d, end = %d\n" w start end
1335 wrapCompleter completeIdentifier w
1336 where words' _ [] = []
1337 words' n str = let (w,r) = break isSpace str
1338 (s,r') = span isSpace r
1339 in (n,w):words' (n+length w+length s) r'
1340 -- In a Haskell expression we want to parse 'a-b' as three words
1341 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1342 -- only be a single word.
1343 selectWord [] = (0,w)
1344 selectWord ((offset,x):xs)
1345 | offset+length x >= start = (start-offset,take (end-offset) x)
1346 | otherwise = selectWord xs
1349 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1350 | otherwise = Nothing
1353 cmds <- readIORef commands
1354 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1356 completeMacro w = do
1357 cmds <- readIORef commands
1358 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1359 return (filter (w `isPrefixOf`) cmds')
1361 completeIdentifier w = do
1363 rdrs <- GHC.getRdrNamesInScope s
1364 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1366 completeModule w = do
1368 dflags <- GHC.getSessionDynFlags s
1369 let pkg_mods = allExposedModules dflags
1370 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1372 completeHomeModule w = do
1374 g <- GHC.getModuleGraph s
1375 let home_mods = map GHC.ms_mod_name g
1376 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1378 completeSetOptions w = do
1379 return (filter (w `isPrefixOf`) options)
1380 where options = "args":"prog":allFlags
1382 completeFilename = Readline.filenameCompletionFunction
1384 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1386 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1387 unionComplete f1 f2 w = do
1392 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1393 wrapCompleter fun w = do
1396 [] -> return Nothing
1397 [x] -> return (Just (x,[]))
1398 xs -> case getCommonPrefix xs of
1399 "" -> return (Just ("",xs))
1400 pref -> return (Just (pref,xs))
1402 getCommonPrefix :: [String] -> String
1403 getCommonPrefix [] = ""
1404 getCommonPrefix (s:ss) = foldl common s ss
1405 where common s "" = ""
1407 common (c:cs) (d:ds)
1408 | c == d = c : common cs ds
1411 allExposedModules :: DynFlags -> [ModuleName]
1412 allExposedModules dflags
1413 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1415 pkg_db = pkgIdMap (pkgState dflags)
1417 completeCmd = completeNone
1418 completeMacro = completeNone
1419 completeIdentifier = completeNone
1420 completeModule = completeNone
1421 completeHomeModule = completeNone
1422 completeSetOptions = completeNone
1423 completeFilename = completeNone
1424 completeHomeModuleOrFile=completeNone
1425 completeBkpt = completeNone
1428 -- ---------------------------------------------------------------------------
1429 -- User code exception handling
1431 -- This is the exception handler for exceptions generated by the
1432 -- user's code and exceptions coming from children sessions;
1433 -- it normally just prints out the exception. The
1434 -- handler must be recursive, in case showing the exception causes
1435 -- more exceptions to be raised.
1437 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1438 -- raising another exception. We therefore don't put the recursive
1439 -- handler arond the flushing operation, so if stderr is closed
1440 -- GHCi will just die gracefully rather than going into an infinite loop.
1441 handler :: Exception -> GHCi Bool
1443 handler exception = do
1445 io installSignalHandlers
1446 ghciHandle handler (showException exception >> return False)
1448 showException (DynException dyn) =
1449 case fromDynamic dyn of
1450 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1451 Just Interrupted -> io (putStrLn "Interrupted.")
1452 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1453 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1454 Just other_ghc_ex -> io (print other_ghc_ex)
1456 showException other_exception
1457 = io (putStrLn ("*** Exception: " ++ show other_exception))
1459 -----------------------------------------------------------------------------
1460 -- recursive exception handlers
1462 -- Don't forget to unblock async exceptions in the handler, or if we're
1463 -- in an exception loop (eg. let a = error a in a) the ^C exception
1464 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1466 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1467 ghciHandle h (GHCi m) = GHCi $ \s ->
1468 Exception.catch (m s)
1469 (\e -> unGHCi (ghciUnblock (h e)) s)
1471 ghciUnblock :: GHCi a -> GHCi a
1472 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1475 -- ----------------------------------------------------------------------------
1478 expandPath :: String -> GHCi String
1480 case dropWhile isSpace path of
1482 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1483 return (tilde ++ '/':d)
1487 wantInterpretedModule :: String -> GHCi Module
1488 wantInterpretedModule str = do
1489 session <- getSession
1490 modl <- lookupModule str
1491 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1492 when (not is_interpreted) $
1493 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1496 wantNameFromInterpretedModule noCanDo str and_then = do
1497 session <- getSession
1498 names <- io $ GHC.parseName session str
1502 let modl = GHC.nameModule n
1503 if not (GHC.isExternalName n)
1504 then noCanDo n $ ppr n <>
1505 text " is not defined in an interpreted module"
1507 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1508 if not is_interpreted
1509 then noCanDo n $ text "module " <> ppr modl <>
1510 text " is not interpreted"
1513 -- ----------------------------------------------------------------------------
1514 -- Windows console setup
1516 setUpConsole :: IO ()
1518 #ifdef mingw32_HOST_OS
1519 -- On Windows we need to set a known code page, otherwise the characters
1520 -- we read from the console will be be in some strange encoding, and
1521 -- similarly for characters we write to the console.
1523 -- At the moment, GHCi pretends all input is Latin-1. In the
1524 -- future we should support UTF-8, but for now we set the code pages
1527 -- It seems you have to set the font in the console window to
1528 -- a Unicode font in order for output to work properly,
1529 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1530 -- (see MSDN for SetConsoleOutputCP()).
1532 setConsoleCP 28591 -- ISO Latin-1
1533 setConsoleOutputCP 28591 -- ISO Latin-1
1537 -- -----------------------------------------------------------------------------
1538 -- commands for debugger
1540 sprintCmd = pprintCommand False False
1541 printCmd = pprintCommand True False
1542 forceCmd = pprintCommand False True
1544 pprintCommand bind force str = do
1545 session <- getSession
1546 io $ pprintClosureCommand session bind force str
1548 stepCmd :: String -> GHCi ()
1549 stepCmd [] = doContinue (const True) GHC.SingleStep
1550 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1553 mb_span <- getCurrentBreakSpan
1555 Nothing -> stepCmd []
1557 Just mod <- getCurrentBreakModule
1558 parent <- enclosingTickSpan mod loc
1559 allTicksRightmost <- (sortBy rightmost . map snd) `fmap`
1561 let lastTick = null allTicksRightmost ||
1562 head allTicksRightmost == loc
1564 then doContinue (`isSubspanOf` parent) GHC.SingleStep
1565 else doContinue (const True) GHC.SingleStep
1570 So, the only tricky part in stepOver is detecting that we have
1571 arrived to the last tick in an expression, in which case we must
1572 step normally to the next tick.
1574 1. Retrieve the enclosing expression block (with a tick)
1575 2. Retrieve all the ticks there and sort them out by 'rightness'
1576 3. See if the current tick turned out the first one in the list
1579 --ticksIn :: Module -> SrcSpan -> GHCi [Tick]
1580 ticksIn mod src = do
1581 ticks <- getTickArray mod
1582 let lines = [srcSpanStartLine src .. srcSpanEndLine src]
1583 return [ t | line <- lines
1584 , t@(_,span) <- ticks ! line
1585 , srcSpanStart src <= srcSpanStart span
1586 , srcSpanEnd src >= srcSpanEnd span
1589 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1590 enclosingTickSpan mod src = do
1591 ticks <- getTickArray mod
1592 let line = srcSpanStartLine src
1593 ASSERT (inRange (bounds ticks) line) do
1594 let enclosing_spans = [ span | (_,span) <- ticks ! line
1595 , srcSpanEnd span >= srcSpanEnd src]
1596 return . head . sortBy leftmost_largest $ enclosing_spans
1598 traceCmd :: String -> GHCi ()
1599 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1600 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1602 continueCmd :: String -> GHCi ()
1603 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1605 -- doContinue :: SingleStep -> GHCi ()
1606 doContinue pred step = do
1607 session <- getSession
1608 runResult <- io $ GHC.resume session step
1609 afterRunStmt pred runResult
1612 abandonCmd :: String -> GHCi ()
1613 abandonCmd = noArgs $ do
1615 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1616 when (not b) $ io $ putStrLn "There is no computation running."
1619 deleteCmd :: String -> GHCi ()
1620 deleteCmd argLine = do
1621 deleteSwitch $ words argLine
1623 deleteSwitch :: [String] -> GHCi ()
1625 io $ putStrLn "The delete command requires at least one argument."
1626 -- delete all break points
1627 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1628 deleteSwitch idents = do
1629 mapM_ deleteOneBreak idents
1631 deleteOneBreak :: String -> GHCi ()
1633 | all isDigit str = deleteBreak (read str)
1634 | otherwise = return ()
1636 historyCmd :: String -> GHCi ()
1638 | null arg = history 20
1639 | all isDigit arg = history (read arg)
1640 | otherwise = io $ putStrLn "Syntax: :history [num]"
1644 resumes <- io $ GHC.getResumeContext s
1646 [] -> io $ putStrLn "Not stopped at a breakpoint"
1648 let hist = GHC.resumeHistory r
1649 (took,rest) = splitAt num hist
1650 spans <- mapM (io . GHC.getHistorySpan s) took
1651 let nums = map (printf "-%-3d:") [(1::Int)..]
1652 let names = map GHC.historyEnclosingDecl took
1653 printForUser (vcat(zipWith3
1654 (\x y z -> x <+> y <+> z)
1656 (map (bold . ppr) names)
1657 (map (parens . ppr) spans)))
1658 io $ putStrLn $ if null rest then "<end of history>" else "..."
1660 bold c | do_bold = text start_bold <> c <> text end_bold
1663 backCmd :: String -> GHCi ()
1664 backCmd = noArgs $ do
1666 (names, ix, span) <- io $ GHC.back s
1667 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1668 printTypeOfNames s names
1669 -- run the command set with ":set stop <cmd>"
1671 enqueueCommands [stop st]
1673 forwardCmd :: String -> GHCi ()
1674 forwardCmd = noArgs $ do
1676 (names, ix, span) <- io $ GHC.forward s
1677 printForUser $ (if (ix == 0)
1678 then ptext SLIT("Stopped at")
1679 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1680 printTypeOfNames s names
1681 -- run the command set with ":set stop <cmd>"
1683 enqueueCommands [stop st]
1685 -- handle the "break" command
1686 breakCmd :: String -> GHCi ()
1687 breakCmd argLine = do
1688 session <- getSession
1689 breakSwitch session $ words argLine
1691 breakSwitch :: Session -> [String] -> GHCi ()
1692 breakSwitch _session [] = do
1693 io $ putStrLn "The break command requires at least one argument."
1694 breakSwitch session args@(arg1:rest)
1695 | looksLikeModuleName arg1 = do
1696 mod <- wantInterpretedModule arg1
1697 breakByModule session mod rest
1698 | all isDigit arg1 = do
1699 (toplevel, _) <- io $ GHC.getContext session
1701 (mod : _) -> breakByModuleLine mod (read arg1) rest
1703 io $ putStrLn "Cannot find default module for breakpoint."
1704 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1705 | otherwise = do -- try parsing it as an identifier
1706 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1707 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1708 if GHC.isGoodSrcLoc loc
1709 then findBreakAndSet (GHC.nameModule name) $
1710 findBreakByCoord (Just (GHC.srcLocFile loc))
1711 (GHC.srcLocLine loc,
1713 else noCanDo name $ text "can't find its location: " <> ppr loc
1715 noCanDo n why = printForUser $
1716 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1718 breakByModule :: Session -> Module -> [String] -> GHCi ()
1719 breakByModule session mod args@(arg1:rest)
1720 | all isDigit arg1 = do -- looks like a line number
1721 breakByModuleLine mod (read arg1) rest
1722 breakByModule session mod _
1725 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1726 breakByModuleLine mod line args
1727 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1728 | [col] <- args, all isDigit col =
1729 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1730 | otherwise = breakSyntax
1732 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1734 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1735 findBreakAndSet mod lookupTickTree = do
1736 tickArray <- getTickArray mod
1737 (breakArray, _) <- getModBreak mod
1738 case lookupTickTree tickArray of
1739 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1740 Just (tick, span) -> do
1741 success <- io $ setBreakFlag True breakArray tick
1742 session <- getSession
1746 recordBreak $ BreakLocation
1753 text "Breakpoint " <> ppr nm <>
1755 then text " was already set at " <> ppr span
1756 else text " activated at " <> ppr span
1758 printForUser $ text "Breakpoint could not be activated at"
1761 -- When a line number is specified, the current policy for choosing
1762 -- the best breakpoint is this:
1763 -- - the leftmost complete subexpression on the specified line, or
1764 -- - the leftmost subexpression starting on the specified line, or
1765 -- - the rightmost subexpression enclosing the specified line
1767 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1768 findBreakByLine line arr
1769 | not (inRange (bounds arr) line) = Nothing
1771 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
1772 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
1773 listToMaybe (sortBy (rightmost `on` snd) ticks)
1777 starts_here = [ tick | tick@(nm,span) <- ticks,
1778 GHC.srcSpanStartLine span == line ]
1780 (complete,incomplete) = partition ends_here starts_here
1781 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1783 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1784 -> Maybe (BreakIndex,SrcSpan)
1785 findBreakByCoord mb_file (line, col) arr
1786 | not (inRange (bounds arr) line) = Nothing
1788 listToMaybe (sortBy (rightmost `on` snd) contains ++
1789 sortBy (leftmost_smallest `on` snd) after_here)
1793 -- the ticks that span this coordinate
1794 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1795 is_correct_file span ]
1797 is_correct_file span
1798 | Just f <- mb_file = GHC.srcSpanFile span == f
1801 after_here = [ tick | tick@(nm,span) <- ticks,
1802 GHC.srcSpanStartLine span == line,
1803 GHC.srcSpanStartCol span >= col ]
1805 -- for now, use ANSI bold on Unixy systems. On Windows, we add a line
1806 -- of carets under the active expression instead. The Windows console
1807 -- doesn't support ANSI escape sequences, and most Unix terminals
1808 -- (including xterm) do, so this is a reasonable guess until we have a
1809 -- proper termcap/terminfo library.
1810 #if !defined(mingw32_TARGET_OS)
1816 start_bold = "\ESC[1m"
1817 end_bold = "\ESC[0m"
1819 listCmd :: String -> GHCi ()
1821 mb_span <- getCurrentBreakSpan
1823 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1824 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1825 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
1826 listCmd str = list2 (words str)
1828 list2 [arg] | all isDigit arg = do
1829 session <- getSession
1830 (toplevel, _) <- io $ GHC.getContext session
1832 [] -> io $ putStrLn "No module to list"
1833 (mod : _) -> listModuleLine mod (read arg)
1834 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1835 mod <- wantInterpretedModule arg1
1836 listModuleLine mod (read arg2)
1838 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1839 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1840 if GHC.isGoodSrcLoc loc
1842 tickArray <- getTickArray (GHC.nameModule name)
1843 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1844 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1847 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1848 Just (_,span) -> io $ listAround span False
1850 noCanDo name $ text "can't find its location: " <>
1853 noCanDo n why = printForUser $
1854 text "cannot list source code for " <> ppr n <> text ": " <> why
1856 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1858 listModuleLine :: Module -> Int -> GHCi ()
1859 listModuleLine modl line = do
1860 session <- getSession
1861 graph <- io (GHC.getModuleGraph session)
1862 let this = filter ((== modl) . GHC.ms_mod) graph
1864 [] -> panic "listModuleLine"
1866 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1867 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1868 io $ listAround (GHC.srcLocSpan loc) False
1870 -- | list a section of a source file around a particular SrcSpan.
1871 -- If the highlight flag is True, also highlight the span using
1872 -- start_bold/end_bold.
1873 listAround span do_highlight = do
1874 contents <- BS.readFile (unpackFS file)
1876 lines = BS.split '\n' contents
1877 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1878 drop (line1 - 1 - pad_before) $ lines
1879 fst_line = max 1 (line1 - pad_before)
1880 line_nos = [ fst_line .. ]
1882 highlighted | do_highlight = zipWith highlight line_nos these_lines
1883 | otherwise = these_lines
1885 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1886 prefixed = zipWith BS.append bs_line_nos highlighted
1888 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1890 file = GHC.srcSpanFile span
1891 line1 = GHC.srcSpanStartLine span
1892 col1 = GHC.srcSpanStartCol span
1893 line2 = GHC.srcSpanEndLine span
1894 col2 = GHC.srcSpanEndCol span
1896 pad_before | line1 == 1 = 0
1900 highlight | do_bold = highlight_bold
1901 | otherwise = highlight_carets
1903 highlight_bold no line
1904 | no == line1 && no == line2
1905 = let (a,r) = BS.splitAt col1 line
1906 (b,c) = BS.splitAt (col2-col1) r
1908 BS.concat [a,BS.pack start_bold,b,BS.pack end_bold,c]
1910 = let (a,b) = BS.splitAt col1 line in
1911 BS.concat [a, BS.pack start_bold, b]
1913 = let (a,b) = BS.splitAt col2 line in
1914 BS.concat [a, BS.pack end_bold, b]
1917 highlight_carets no line
1918 | no == line1 && no == line2
1919 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1920 BS.replicate (col2-col1) '^']
1922 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1923 BS.replicate (BS.length line-col1) '^']
1925 = BS.concat [line, nl, indent, BS.replicate col2 '^']
1928 indent = BS.pack " "
1929 nl = BS.singleton '\n'
1931 -- --------------------------------------------------------------------------
1934 getTickArray :: Module -> GHCi TickArray
1935 getTickArray modl = do
1937 let arrmap = tickarrays st
1938 case lookupModuleEnv arrmap modl of
1939 Just arr -> return arr
1941 (breakArray, ticks) <- getModBreak modl
1942 let arr = mkTickArray (assocs ticks)
1943 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1946 discardTickArrays :: GHCi ()
1947 discardTickArrays = do
1949 setGHCiState st{tickarrays = emptyModuleEnv}
1951 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1953 = accumArray (flip (:)) [] (1, max_line)
1954 [ (line, (nm,span)) | (nm,span) <- ticks,
1955 line <- srcSpanLines span ]
1957 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1958 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1959 GHC.srcSpanEndLine span ]
1961 lookupModule :: String -> GHCi Module
1962 lookupModule modName
1963 = do session <- getSession
1964 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1966 -- don't reset the counter back to zero?
1967 discardActiveBreakPoints :: GHCi ()
1968 discardActiveBreakPoints = do
1970 mapM (turnOffBreak.snd) (breaks st)
1971 setGHCiState $ st { breaks = [] }
1973 deleteBreak :: Int -> GHCi ()
1974 deleteBreak identity = do
1976 let oldLocations = breaks st
1977 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
1979 then printForUser (text "Breakpoint" <+> ppr identity <+>
1980 text "does not exist")
1982 mapM (turnOffBreak.snd) this
1983 setGHCiState $ st { breaks = rest }
1985 turnOffBreak loc = do
1986 (arr, _) <- getModBreak (breakModule loc)
1987 io $ setBreakFlag False arr (breakTick loc)
1989 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1990 getModBreak mod = do
1991 session <- getSession
1992 Just mod_info <- io $ GHC.getModuleInfo session mod
1993 let modBreaks = GHC.modInfoModBreaks mod_info
1994 let array = GHC.modBreaks_flags modBreaks
1995 let ticks = GHC.modBreaks_locs modBreaks
1996 return (array, ticks)
1998 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1999 setBreakFlag toggle array index
2000 | toggle = GHC.setBreakOn array index
2001 | otherwise = GHC.setBreakOff array index