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 (locally) single-step over function applications"++
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 getCurrentBreakTick :: GHCi (Maybe BreakIndex)
647 getCurrentBreakTick = do
648 session <- getSession
649 resumes <- io $ GHC.getResumeContext session
653 let ix = GHC.resumeHistoryIx r
655 then return (GHC.breakInfo_number `fmap` GHC.resumeBreakInfo r)
657 let hist = GHC.resumeHistory r !! (ix-1)
658 let tick = GHC.getHistoryTick hist
661 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
662 getCurrentBreakSpan = do
663 session <- getSession
664 resumes <- io $ GHC.getResumeContext session
668 let ix = GHC.resumeHistoryIx r
670 then return (Just (GHC.resumeSpan r))
672 let hist = GHC.resumeHistory r !! (ix-1)
673 span <- io $ GHC.getHistorySpan session hist
676 getCurrentBreakModule :: GHCi (Maybe Module)
677 getCurrentBreakModule = do
678 session <- getSession
679 resumes <- io $ GHC.getResumeContext session
683 let ix = GHC.resumeHistoryIx r
685 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
687 let hist = GHC.resumeHistory r !! (ix-1)
688 return $ Just $ GHC.getHistoryModule hist
690 -----------------------------------------------------------------------------
693 noArgs :: GHCi () -> String -> GHCi ()
695 noArgs m _ = io $ putStrLn "This command takes no arguments"
697 help :: String -> GHCi ()
698 help _ = io (putStr helpText)
700 info :: String -> GHCi ()
701 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
702 info s = do { let names = words s
703 ; session <- getSession
704 ; dflags <- getDynFlags
705 ; let pefas = dopt Opt_PrintExplicitForalls dflags
706 ; mapM_ (infoThing pefas session) names }
708 infoThing pefas session str = io $ do
709 names <- GHC.parseName session str
710 mb_stuffs <- mapM (GHC.getInfo session) names
711 let filtered = filterOutChildren (\(t,f,i) -> t) (catMaybes mb_stuffs)
712 unqual <- GHC.getPrintUnqual session
713 putStrLn (showSDocForUser unqual $
714 vcat (intersperse (text "") $
715 map (pprInfo pefas) filtered))
717 -- Filter out names whose parent is also there Good
718 -- example is '[]', which is both a type and data
719 -- constructor in the same type
720 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
721 filterOutChildren get_thing xs
722 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
724 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
726 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
727 pprInfo pefas (thing, fixity, insts)
728 = pprTyThingInContextLoc pefas thing
729 $$ show_fixity fixity
730 $$ vcat (map GHC.pprInstance insts)
733 | fix == GHC.defaultFixity = empty
734 | otherwise = ppr fix <+> ppr (GHC.getName thing)
736 runMain :: String -> GHCi ()
738 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
739 enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
741 addModule :: [FilePath] -> GHCi ()
743 io (revertCAFs) -- always revert CAFs on load/add.
744 files <- mapM expandPath files
745 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
746 session <- getSession
747 io (mapM_ (GHC.addTarget session) targets)
748 ok <- io (GHC.load session LoadAllTargets)
751 changeDirectory :: String -> GHCi ()
752 changeDirectory dir = do
753 session <- getSession
754 graph <- io (GHC.getModuleGraph session)
755 when (not (null graph)) $
756 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
757 io (GHC.setTargets session [])
758 io (GHC.load session LoadAllTargets)
759 setContextAfterLoad session []
760 io (GHC.workingDirectoryChanged session)
761 dir <- expandPath dir
762 io (setCurrentDirectory dir)
764 editFile :: String -> GHCi ()
766 do file <- if null str then chooseEditFile else return str
770 $ throwDyn (CmdLineError "editor not set, use :set editor")
771 io $ system (cmd ++ ' ':file)
774 -- The user didn't specify a file so we pick one for them.
775 -- Our strategy is to pick the first module that failed to load,
776 -- or otherwise the first target.
778 -- XXX: Can we figure out what happened if the depndecy analysis fails
779 -- (e.g., because the porgrammeer mistyped the name of a module)?
780 -- XXX: Can we figure out the location of an error to pass to the editor?
781 -- XXX: if we could figure out the list of errors that occured during the
782 -- last load/reaload, then we could start the editor focused on the first
784 chooseEditFile :: GHCi String
786 do session <- getSession
787 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
789 graph <- io (GHC.getModuleGraph session)
790 failed_graph <- filterM hasFailed graph
791 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
793 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
796 case pick (order failed_graph) of
797 Just file -> return file
799 do targets <- io (GHC.getTargets session)
800 case msum (map fromTarget targets) of
801 Just file -> return file
802 Nothing -> throwDyn (CmdLineError "No files to edit.")
804 where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
805 fromTarget _ = Nothing -- when would we get a module target?
807 defineMacro :: String -> GHCi ()
809 let (macro_name, definition) = break isSpace s
810 cmds <- io (readIORef commands)
812 then throwDyn (CmdLineError "invalid macro name")
814 if (macro_name `elem` map cmdName cmds)
815 then throwDyn (CmdLineError
816 ("command '" ++ macro_name ++ "' is already defined"))
819 -- give the expression a type signature, so we can be sure we're getting
820 -- something of the right type.
821 let new_expr = '(' : definition ++ ") :: String -> IO String"
823 -- compile the expression
825 maybe_hv <- io (GHC.compileExpr cms new_expr)
828 Just hv -> io (writeIORef commands --
829 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
831 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
833 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
834 enqueueCommands (lines str)
837 undefineMacro :: String -> GHCi ()
838 undefineMacro macro_name = do
839 cmds <- io (readIORef commands)
840 if (macro_name `elem` map cmdName builtin_commands)
841 then throwDyn (CmdLineError
842 ("command '" ++ macro_name ++ "' cannot be undefined"))
844 if (macro_name `notElem` map cmdName cmds)
845 then throwDyn (CmdLineError
846 ("command '" ++ macro_name ++ "' not defined"))
848 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
850 cmdCmd :: String -> GHCi ()
852 let expr = '(' : str ++ ") :: IO String"
853 session <- getSession
854 maybe_hv <- io (GHC.compileExpr session expr)
858 cmds <- io $ (unsafeCoerce# hv :: IO String)
859 enqueueCommands (lines cmds)
862 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
863 loadModule fs = timeIt (loadModule' fs)
865 loadModule_ :: [FilePath] -> GHCi ()
866 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
868 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
869 loadModule' files = do
870 session <- getSession
873 discardActiveBreakPoints
874 io (GHC.setTargets session [])
875 io (GHC.load session LoadAllTargets)
878 let (filenames, phases) = unzip files
879 exp_filenames <- mapM expandPath filenames
880 let files' = zip exp_filenames phases
881 targets <- io (mapM (uncurry GHC.guessTarget) files')
883 -- NOTE: we used to do the dependency anal first, so that if it
884 -- fails we didn't throw away the current set of modules. This would
885 -- require some re-working of the GHC interface, so we'll leave it
886 -- as a ToDo for now.
888 io (GHC.setTargets session targets)
889 doLoad session LoadAllTargets
891 checkModule :: String -> GHCi ()
893 let modl = GHC.mkModuleName m
894 session <- getSession
895 result <- io (GHC.checkModule session modl False)
897 Nothing -> io $ putStrLn "Nothing"
898 Just r -> io $ putStrLn (showSDoc (
899 case GHC.checkedModuleInfo r of
900 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
902 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
904 (text "global names: " <+> ppr global) $$
905 (text "local names: " <+> ppr local)
907 afterLoad (successIf (isJust result)) session
909 reloadModule :: String -> GHCi ()
911 session <- getSession
912 doLoad session $ if null m then LoadAllTargets
913 else LoadUpTo (GHC.mkModuleName m)
916 doLoad session howmuch = do
917 -- turn off breakpoints before we load: we can't turn them off later, because
918 -- the ModBreaks will have gone away.
919 discardActiveBreakPoints
920 ok <- io (GHC.load session howmuch)
924 afterLoad ok session = do
925 io (revertCAFs) -- always revert CAFs on load.
927 graph <- io (GHC.getModuleGraph session)
928 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
929 setContextAfterLoad session graph'
930 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
932 setContextAfterLoad session [] = do
933 prel_mod <- getPrelude
934 io (GHC.setContext session [] [prel_mod])
935 setContextAfterLoad session ms = do
936 -- load a target if one is available, otherwise load the topmost module.
937 targets <- io (GHC.getTargets session)
938 case [ m | Just m <- map (findTarget ms) targets ] of
940 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
941 load_this (last graph')
946 = case filter (`matches` t) ms of
950 summary `matches` Target (TargetModule m) _
951 = GHC.ms_mod_name summary == m
952 summary `matches` Target (TargetFile f _) _
953 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
954 summary `matches` target
957 load_this summary | m <- GHC.ms_mod summary = do
958 b <- io (GHC.moduleIsInterpreted session m)
959 if b then io (GHC.setContext session [m] [])
961 prel_mod <- getPrelude
962 io (GHC.setContext session [] [prel_mod,m])
965 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
966 modulesLoadedMsg ok mods = do
967 dflags <- getDynFlags
968 when (verbosity dflags > 0) $ do
970 | null mods = text "none."
972 punctuate comma (map ppr mods)) <> text "."
975 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
977 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
980 typeOfExpr :: String -> GHCi ()
982 = do cms <- getSession
983 maybe_ty <- io (GHC.exprType cms str)
986 Just ty -> do ty' <- cleanType ty
987 printForUser $ text str <> text " :: " <> ppr ty'
989 kindOfType :: String -> GHCi ()
991 = do cms <- getSession
992 maybe_ty <- io (GHC.typeKind cms str)
995 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
997 quit :: String -> GHCi Bool
1000 shellEscape :: String -> GHCi Bool
1001 shellEscape str = io (system str >> return False)
1003 -----------------------------------------------------------------------------
1004 -- Browsing a module's contents
1006 browseCmd :: String -> GHCi ()
1009 ['*':m] | looksLikeModuleName m -> browseModule m False
1010 [m] | looksLikeModuleName m -> browseModule m True
1011 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1013 browseModule m exports_only = do
1015 modl <- if exports_only then lookupModule m
1016 else wantInterpretedModule m
1018 -- Temporarily set the context to the module we're interested in,
1019 -- just so we can get an appropriate PrintUnqualified
1020 (as,bs) <- io (GHC.getContext s)
1021 prel_mod <- getPrelude
1022 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1023 else GHC.setContext s [modl] [])
1024 unqual <- io (GHC.getPrintUnqual s)
1025 io (GHC.setContext s as bs)
1027 mb_mod_info <- io $ GHC.getModuleInfo s modl
1029 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1032 | exports_only = GHC.modInfoExports mod_info
1033 | otherwise = GHC.modInfoTopLevelScope mod_info
1036 mb_things <- io $ mapM (GHC.lookupName s) names
1037 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1039 dflags <- getDynFlags
1040 let pefas = dopt Opt_PrintExplicitForalls dflags
1041 io (putStrLn (showSDocForUser unqual (
1042 vcat (map (pprTyThingInContext pefas) filtered_things)
1044 -- ToDo: modInfoInstances currently throws an exception for
1045 -- package modules. When it works, we can do this:
1046 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1048 -----------------------------------------------------------------------------
1049 -- Setting the module context
1052 | all sensible mods = fn mods
1053 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1055 (fn, mods) = case str of
1056 '+':stuff -> (addToContext, words stuff)
1057 '-':stuff -> (removeFromContext, words stuff)
1058 stuff -> (newContext, words stuff)
1060 sensible ('*':m) = looksLikeModuleName m
1061 sensible m = looksLikeModuleName m
1063 separate :: Session -> [String] -> [Module] -> [Module]
1064 -> GHCi ([Module],[Module])
1065 separate session [] as bs = return (as,bs)
1066 separate session (('*':str):ms) as bs = do
1067 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1068 b <- io $ GHC.moduleIsInterpreted session m
1069 if b then separate session ms (m:as) bs
1070 else throwDyn (CmdLineError ("module '"
1071 ++ GHC.moduleNameString (GHC.moduleName m)
1072 ++ "' is not interpreted"))
1073 separate session (str:ms) as bs = do
1074 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1075 separate session ms as (m:bs)
1077 newContext :: [String] -> GHCi ()
1078 newContext strs = do
1080 (as,bs) <- separate s strs [] []
1081 prel_mod <- getPrelude
1082 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1083 io $ GHC.setContext s as bs'
1086 addToContext :: [String] -> GHCi ()
1087 addToContext strs = do
1089 (as,bs) <- io $ GHC.getContext s
1091 (new_as,new_bs) <- separate s strs [] []
1093 let as_to_add = new_as \\ (as ++ bs)
1094 bs_to_add = new_bs \\ (as ++ bs)
1096 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1099 removeFromContext :: [String] -> GHCi ()
1100 removeFromContext strs = do
1102 (as,bs) <- io $ GHC.getContext s
1104 (as_to_remove,bs_to_remove) <- separate s strs [] []
1106 let as' = as \\ (as_to_remove ++ bs_to_remove)
1107 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1109 io $ GHC.setContext s as' bs'
1111 ----------------------------------------------------------------------------
1114 -- set options in the interpreter. Syntax is exactly the same as the
1115 -- ghc command line, except that certain options aren't available (-C,
1118 -- This is pretty fragile: most options won't work as expected. ToDo:
1119 -- figure out which ones & disallow them.
1121 setCmd :: String -> GHCi ()
1123 = do st <- getGHCiState
1124 let opts = options st
1125 io $ putStrLn (showSDoc (
1126 text "options currently set: " <>
1129 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1132 = case toArgs str of
1133 ("args":args) -> setArgs args
1134 ("prog":prog) -> setProg prog
1135 ("prompt":prompt) -> setPrompt (after 6)
1136 ("editor":cmd) -> setEditor (after 6)
1137 ("stop":cmd) -> setStop (after 4)
1138 wds -> setOptions wds
1139 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1143 setGHCiState st{ args = args }
1147 setGHCiState st{ progname = prog }
1149 io (hPutStrLn stderr "syntax: :set prog <progname>")
1153 setGHCiState st{ editor = cmd }
1155 setStop str@(c:_) | isDigit c
1156 = do let (nm_str,rest) = break (not.isDigit) str
1159 let old_breaks = breaks st
1160 if all ((/= nm) . fst) old_breaks
1161 then printForUser (text "Breakpoint" <+> ppr nm <+>
1162 text "does not exist")
1164 let new_breaks = map fn old_breaks
1165 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1166 | otherwise = (i,loc)
1167 setGHCiState st{ breaks = new_breaks }
1170 setGHCiState st{ stop = cmd }
1172 setPrompt value = do
1175 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1176 else setGHCiState st{ prompt = remQuotes value }
1178 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1182 do -- first, deal with the GHCi opts (+s, +t, etc.)
1183 let (plus_opts, minus_opts) = partition isPlus wds
1184 mapM_ setOpt plus_opts
1185 -- then, dynamic flags
1186 newDynFlags minus_opts
1188 newDynFlags minus_opts = do
1189 dflags <- getDynFlags
1190 let pkg_flags = packageFlags dflags
1191 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1193 if (not (null leftovers))
1194 then throwDyn (CmdLineError ("unrecognised flags: " ++
1198 new_pkgs <- setDynFlags dflags'
1200 -- if the package flags changed, we should reset the context
1201 -- and link the new packages.
1202 dflags <- getDynFlags
1203 when (packageFlags dflags /= pkg_flags) $ do
1204 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1205 session <- getSession
1206 io (GHC.setTargets session [])
1207 io (GHC.load session LoadAllTargets)
1208 io (linkPackages dflags new_pkgs)
1209 setContextAfterLoad session []
1213 unsetOptions :: String -> GHCi ()
1215 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1216 let opts = words str
1217 (minus_opts, rest1) = partition isMinus opts
1218 (plus_opts, rest2) = partition isPlus rest1
1220 if (not (null rest2))
1221 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1224 mapM_ unsetOpt plus_opts
1226 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1227 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1229 no_flags <- mapM no_flag minus_opts
1230 newDynFlags no_flags
1232 isMinus ('-':s) = True
1235 isPlus ('+':s) = True
1239 = case strToGHCiOpt str of
1240 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1241 Just o -> setOption o
1244 = case strToGHCiOpt str of
1245 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1246 Just o -> unsetOption o
1248 strToGHCiOpt :: String -> (Maybe GHCiOption)
1249 strToGHCiOpt "s" = Just ShowTiming
1250 strToGHCiOpt "t" = Just ShowType
1251 strToGHCiOpt "r" = Just RevertCAFs
1252 strToGHCiOpt _ = Nothing
1254 optToStr :: GHCiOption -> String
1255 optToStr ShowTiming = "s"
1256 optToStr ShowType = "t"
1257 optToStr RevertCAFs = "r"
1259 -- ---------------------------------------------------------------------------
1265 ["args"] -> io $ putStrLn (show (args st))
1266 ["prog"] -> io $ putStrLn (show (progname st))
1267 ["prompt"] -> io $ putStrLn (show (prompt st))
1268 ["editor"] -> io $ putStrLn (show (editor st))
1269 ["stop"] -> io $ putStrLn (show (stop st))
1270 ["modules" ] -> showModules
1271 ["bindings"] -> showBindings
1272 ["linker"] -> io showLinkerState
1273 ["breaks"] -> showBkptTable
1274 ["context"] -> showContext
1275 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1278 session <- getSession
1279 let show_one ms = do m <- io (GHC.showModule session ms)
1281 graph <- io (GHC.getModuleGraph session)
1282 mapM_ show_one graph
1286 unqual <- io (GHC.getPrintUnqual s)
1287 bindings <- io (GHC.getBindings s)
1288 mapM_ printTyThing $ sortBy compareTyThings bindings
1291 compareTyThings :: TyThing -> TyThing -> Ordering
1292 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1294 printTyThing :: TyThing -> GHCi ()
1295 printTyThing (AnId id) = do
1296 ty' <- cleanType (GHC.idType id)
1297 printForUser $ ppr id <> text " :: " <> ppr ty'
1298 printTyThing _ = return ()
1300 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1301 cleanType :: Type -> GHCi Type
1303 dflags <- getDynFlags
1304 if dopt Opt_PrintExplicitForalls dflags
1306 else return $! GHC.dropForAlls ty
1308 showBkptTable :: GHCi ()
1311 printForUser $ prettyLocations (breaks st)
1313 showContext :: GHCi ()
1315 session <- getSession
1316 resumes <- io $ GHC.getResumeContext session
1317 printForUser $ vcat (map pp_resume (reverse resumes))
1320 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1321 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1324 -- -----------------------------------------------------------------------------
1327 completeNone :: String -> IO [String]
1328 completeNone w = return []
1331 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1332 completeWord w start end = do
1333 line <- Readline.getLineBuffer
1335 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1337 | Just c <- is_cmd line -> do
1338 maybe_cmd <- lookupCommand c
1339 let (n,w') = selectWord (words' 0 line)
1341 Nothing -> return Nothing
1342 Just (_,_,False,complete) -> wrapCompleter complete w
1343 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1344 return (map (drop n) rets)
1345 in wrapCompleter complete' w'
1347 --printf "complete %s, start = %d, end = %d\n" w start end
1348 wrapCompleter completeIdentifier w
1349 where words' _ [] = []
1350 words' n str = let (w,r) = break isSpace str
1351 (s,r') = span isSpace r
1352 in (n,w):words' (n+length w+length s) r'
1353 -- In a Haskell expression we want to parse 'a-b' as three words
1354 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1355 -- only be a single word.
1356 selectWord [] = (0,w)
1357 selectWord ((offset,x):xs)
1358 | offset+length x >= start = (start-offset,take (end-offset) x)
1359 | otherwise = selectWord xs
1362 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1363 | otherwise = Nothing
1366 cmds <- readIORef commands
1367 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1369 completeMacro w = do
1370 cmds <- readIORef commands
1371 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1372 return (filter (w `isPrefixOf`) cmds')
1374 completeIdentifier w = do
1376 rdrs <- GHC.getRdrNamesInScope s
1377 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1379 completeModule w = do
1381 dflags <- GHC.getSessionDynFlags s
1382 let pkg_mods = allExposedModules dflags
1383 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1385 completeHomeModule w = do
1387 g <- GHC.getModuleGraph s
1388 let home_mods = map GHC.ms_mod_name g
1389 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1391 completeSetOptions w = do
1392 return (filter (w `isPrefixOf`) options)
1393 where options = "args":"prog":allFlags
1395 completeFilename = Readline.filenameCompletionFunction
1397 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1399 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1400 unionComplete f1 f2 w = do
1405 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1406 wrapCompleter fun w = do
1409 [] -> return Nothing
1410 [x] -> return (Just (x,[]))
1411 xs -> case getCommonPrefix xs of
1412 "" -> return (Just ("",xs))
1413 pref -> return (Just (pref,xs))
1415 getCommonPrefix :: [String] -> String
1416 getCommonPrefix [] = ""
1417 getCommonPrefix (s:ss) = foldl common s ss
1418 where common s "" = ""
1420 common (c:cs) (d:ds)
1421 | c == d = c : common cs ds
1424 allExposedModules :: DynFlags -> [ModuleName]
1425 allExposedModules dflags
1426 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1428 pkg_db = pkgIdMap (pkgState dflags)
1430 completeCmd = completeNone
1431 completeMacro = completeNone
1432 completeIdentifier = completeNone
1433 completeModule = completeNone
1434 completeHomeModule = completeNone
1435 completeSetOptions = completeNone
1436 completeFilename = completeNone
1437 completeHomeModuleOrFile=completeNone
1438 completeBkpt = completeNone
1441 -- ---------------------------------------------------------------------------
1442 -- User code exception handling
1444 -- This is the exception handler for exceptions generated by the
1445 -- user's code and exceptions coming from children sessions;
1446 -- it normally just prints out the exception. The
1447 -- handler must be recursive, in case showing the exception causes
1448 -- more exceptions to be raised.
1450 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1451 -- raising another exception. We therefore don't put the recursive
1452 -- handler arond the flushing operation, so if stderr is closed
1453 -- GHCi will just die gracefully rather than going into an infinite loop.
1454 handler :: Exception -> GHCi Bool
1456 handler exception = do
1458 io installSignalHandlers
1459 ghciHandle handler (showException exception >> return False)
1461 showException (DynException dyn) =
1462 case fromDynamic dyn of
1463 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1464 Just Interrupted -> io (putStrLn "Interrupted.")
1465 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1466 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1467 Just other_ghc_ex -> io (print other_ghc_ex)
1469 showException other_exception
1470 = io (putStrLn ("*** Exception: " ++ show other_exception))
1472 -----------------------------------------------------------------------------
1473 -- recursive exception handlers
1475 -- Don't forget to unblock async exceptions in the handler, or if we're
1476 -- in an exception loop (eg. let a = error a in a) the ^C exception
1477 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1479 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1480 ghciHandle h (GHCi m) = GHCi $ \s ->
1481 Exception.catch (m s)
1482 (\e -> unGHCi (ghciUnblock (h e)) s)
1484 ghciUnblock :: GHCi a -> GHCi a
1485 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1488 -- ----------------------------------------------------------------------------
1491 expandPath :: String -> GHCi String
1493 case dropWhile isSpace path of
1495 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1496 return (tilde ++ '/':d)
1500 wantInterpretedModule :: String -> GHCi Module
1501 wantInterpretedModule str = do
1502 session <- getSession
1503 modl <- lookupModule str
1504 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1505 when (not is_interpreted) $
1506 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1509 wantNameFromInterpretedModule noCanDo str and_then = do
1510 session <- getSession
1511 names <- io $ GHC.parseName session str
1515 let modl = GHC.nameModule n
1516 if not (GHC.isExternalName n)
1517 then noCanDo n $ ppr n <>
1518 text " is not defined in an interpreted module"
1520 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1521 if not is_interpreted
1522 then noCanDo n $ text "module " <> ppr modl <>
1523 text " is not interpreted"
1526 -- ----------------------------------------------------------------------------
1527 -- Windows console setup
1529 setUpConsole :: IO ()
1531 #ifdef mingw32_HOST_OS
1532 -- On Windows we need to set a known code page, otherwise the characters
1533 -- we read from the console will be be in some strange encoding, and
1534 -- similarly for characters we write to the console.
1536 -- At the moment, GHCi pretends all input is Latin-1. In the
1537 -- future we should support UTF-8, but for now we set the code pages
1540 -- It seems you have to set the font in the console window to
1541 -- a Unicode font in order for output to work properly,
1542 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1543 -- (see MSDN for SetConsoleOutputCP()).
1545 setConsoleCP 28591 -- ISO Latin-1
1546 setConsoleOutputCP 28591 -- ISO Latin-1
1550 -- -----------------------------------------------------------------------------
1551 -- commands for debugger
1553 sprintCmd = pprintCommand False False
1554 printCmd = pprintCommand True False
1555 forceCmd = pprintCommand False True
1557 pprintCommand bind force str = do
1558 session <- getSession
1559 io $ pprintClosureCommand session bind force str
1561 stepCmd :: String -> GHCi ()
1562 stepCmd [] = doContinue (const True) GHC.SingleStep
1563 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1566 mb_span <- getCurrentBreakSpan
1567 session <- getSession
1569 Nothing -> stepCmd []
1571 Just tick <- getCurrentBreakTick
1572 Just mod <- getCurrentBreakModule
1573 parent <- io$ GHC.findEnclosingDeclSpanByTick session mod tick
1574 allTicksRightmost <- (sortBy rightmost . map snd) `fmap`
1576 let lastTick = null allTicksRightmost ||
1577 head allTicksRightmost == curr_loc
1579 then let f t = t `isSubspanOf` parent &&
1580 (curr_loc `leftmost_largest` t == LT)
1581 in doContinue f GHC.SingleStep
1582 else printForUser (text "Warning: no more breakpoints in this function body, switching to :step") >>
1583 doContinue (const True) GHC.SingleStep
1585 stepOverCmd expression = stepCmd expression
1588 The first tricky bit in stepOver is detecting that we have
1589 arrived to the last tick in an expression, in which case we must
1590 step normally to the next tick.
1592 1. Retrieve the enclosing expression block (with a tick)
1593 2. Retrieve all the ticks there and sort them out by 'rightness'
1594 3. See if the current tick turned out the first one in the list
1596 The second tricky bit is how to step over recursive calls.
1600 --ticksIn :: Module -> SrcSpan -> GHCi [Tick]
1601 ticksIn mod src = do
1602 ticks <- getTickArray mod
1603 let lines = [srcSpanStartLine src .. srcSpanEndLine src]
1604 return [ t | line <- lines
1605 , t@(_,span) <- ticks ! line
1606 , srcSpanStart src <= srcSpanStart span
1607 , srcSpanEnd src >= srcSpanEnd span
1610 traceCmd :: String -> GHCi ()
1611 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1612 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1614 continueCmd :: String -> GHCi ()
1615 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1617 -- doContinue :: SingleStep -> GHCi ()
1618 doContinue pred step = do
1619 session <- getSession
1620 runResult <- io $ GHC.resume session step
1621 afterRunStmt pred runResult
1624 abandonCmd :: String -> GHCi ()
1625 abandonCmd = noArgs $ do
1627 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1628 when (not b) $ io $ putStrLn "There is no computation running."
1631 deleteCmd :: String -> GHCi ()
1632 deleteCmd argLine = do
1633 deleteSwitch $ words argLine
1635 deleteSwitch :: [String] -> GHCi ()
1637 io $ putStrLn "The delete command requires at least one argument."
1638 -- delete all break points
1639 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1640 deleteSwitch idents = do
1641 mapM_ deleteOneBreak idents
1643 deleteOneBreak :: String -> GHCi ()
1645 | all isDigit str = deleteBreak (read str)
1646 | otherwise = return ()
1648 historyCmd :: String -> GHCi ()
1650 | null arg = history 20
1651 | all isDigit arg = history (read arg)
1652 | otherwise = io $ putStrLn "Syntax: :history [num]"
1656 resumes <- io $ GHC.getResumeContext s
1658 [] -> io $ putStrLn "Not stopped at a breakpoint"
1660 let hist = GHC.resumeHistory r
1661 (took,rest) = splitAt num hist
1662 spans <- mapM (io . GHC.getHistorySpan s) took
1663 let nums = map (printf "-%-3d:") [(1::Int)..]
1664 let names = map GHC.historyEnclosingDecl took
1665 printForUser (vcat(zipWith3
1666 (\x y z -> x <+> y <+> z)
1668 (map (bold . ppr) names)
1669 (map (parens . ppr) spans)))
1670 io $ putStrLn $ if null rest then "<end of history>" else "..."
1672 bold c | do_bold = text start_bold <> c <> text end_bold
1675 backCmd :: String -> GHCi ()
1676 backCmd = noArgs $ do
1678 (names, ix, span) <- io $ GHC.back s
1679 printForUser $ 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 forwardCmd :: String -> GHCi ()
1686 forwardCmd = noArgs $ do
1688 (names, ix, span) <- io $ GHC.forward s
1689 printForUser $ (if (ix == 0)
1690 then ptext SLIT("Stopped at")
1691 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1692 printTypeOfNames s names
1693 -- run the command set with ":set stop <cmd>"
1695 enqueueCommands [stop st]
1697 -- handle the "break" command
1698 breakCmd :: String -> GHCi ()
1699 breakCmd argLine = do
1700 session <- getSession
1701 breakSwitch session $ words argLine
1703 breakSwitch :: Session -> [String] -> GHCi ()
1704 breakSwitch _session [] = do
1705 io $ putStrLn "The break command requires at least one argument."
1706 breakSwitch session args@(arg1:rest)
1707 | looksLikeModuleName arg1 = do
1708 mod <- wantInterpretedModule arg1
1709 breakByModule session mod rest
1710 | all isDigit arg1 = do
1711 (toplevel, _) <- io $ GHC.getContext session
1713 (mod : _) -> breakByModuleLine mod (read arg1) rest
1715 io $ putStrLn "Cannot find default module for breakpoint."
1716 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1717 | otherwise = do -- try parsing it as an identifier
1718 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1719 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1720 if GHC.isGoodSrcLoc loc
1721 then findBreakAndSet (GHC.nameModule name) $
1722 findBreakByCoord (Just (GHC.srcLocFile loc))
1723 (GHC.srcLocLine loc,
1725 else noCanDo name $ text "can't find its location: " <> ppr loc
1727 noCanDo n why = printForUser $
1728 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1730 breakByModule :: Session -> Module -> [String] -> GHCi ()
1731 breakByModule session mod args@(arg1:rest)
1732 | all isDigit arg1 = do -- looks like a line number
1733 breakByModuleLine mod (read arg1) rest
1734 breakByModule session mod _
1737 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1738 breakByModuleLine mod line args
1739 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1740 | [col] <- args, all isDigit col =
1741 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1742 | otherwise = breakSyntax
1744 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1746 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1747 findBreakAndSet mod lookupTickTree = do
1748 tickArray <- getTickArray mod
1749 (breakArray, _) <- getModBreak mod
1750 case lookupTickTree tickArray of
1751 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1752 Just (tick, span) -> do
1753 success <- io $ setBreakFlag True breakArray tick
1754 session <- getSession
1758 recordBreak $ BreakLocation
1765 text "Breakpoint " <> ppr nm <>
1767 then text " was already set at " <> ppr span
1768 else text " activated at " <> ppr span
1770 printForUser $ text "Breakpoint could not be activated at"
1773 -- When a line number is specified, the current policy for choosing
1774 -- the best breakpoint is this:
1775 -- - the leftmost complete subexpression on the specified line, or
1776 -- - the leftmost subexpression starting on the specified line, or
1777 -- - the rightmost subexpression enclosing the specified line
1779 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1780 findBreakByLine line arr
1781 | not (inRange (bounds arr) line) = Nothing
1783 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
1784 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
1785 listToMaybe (sortBy (rightmost `on` snd) ticks)
1789 starts_here = [ tick | tick@(nm,span) <- ticks,
1790 GHC.srcSpanStartLine span == line ]
1792 (complete,incomplete) = partition ends_here starts_here
1793 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1795 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1796 -> Maybe (BreakIndex,SrcSpan)
1797 findBreakByCoord mb_file (line, col) arr
1798 | not (inRange (bounds arr) line) = Nothing
1800 listToMaybe (sortBy (rightmost `on` snd) contains ++
1801 sortBy (leftmost_smallest `on` snd) after_here)
1805 -- the ticks that span this coordinate
1806 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1807 is_correct_file span ]
1809 is_correct_file span
1810 | Just f <- mb_file = GHC.srcSpanFile span == f
1813 after_here = [ tick | tick@(nm,span) <- ticks,
1814 GHC.srcSpanStartLine span == line,
1815 GHC.srcSpanStartCol span >= col ]
1817 -- for now, use ANSI bold on Unixy systems. On Windows, we add a line
1818 -- of carets under the active expression instead. The Windows console
1819 -- doesn't support ANSI escape sequences, and most Unix terminals
1820 -- (including xterm) do, so this is a reasonable guess until we have a
1821 -- proper termcap/terminfo library.
1822 #if !defined(mingw32_TARGET_OS)
1828 start_bold = "\ESC[1m"
1829 end_bold = "\ESC[0m"
1831 listCmd :: String -> GHCi ()
1833 mb_span <- getCurrentBreakSpan
1835 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1836 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1837 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
1838 listCmd str = list2 (words str)
1840 list2 [arg] | all isDigit arg = do
1841 session <- getSession
1842 (toplevel, _) <- io $ GHC.getContext session
1844 [] -> io $ putStrLn "No module to list"
1845 (mod : _) -> listModuleLine mod (read arg)
1846 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1847 mod <- wantInterpretedModule arg1
1848 listModuleLine mod (read arg2)
1850 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1851 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1852 if GHC.isGoodSrcLoc loc
1854 tickArray <- getTickArray (GHC.nameModule name)
1855 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1856 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1859 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1860 Just (_,span) -> io $ listAround span False
1862 noCanDo name $ text "can't find its location: " <>
1865 noCanDo n why = printForUser $
1866 text "cannot list source code for " <> ppr n <> text ": " <> why
1868 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1870 listModuleLine :: Module -> Int -> GHCi ()
1871 listModuleLine modl line = do
1872 session <- getSession
1873 graph <- io (GHC.getModuleGraph session)
1874 let this = filter ((== modl) . GHC.ms_mod) graph
1876 [] -> panic "listModuleLine"
1878 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1879 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1880 io $ listAround (GHC.srcLocSpan loc) False
1882 -- | list a section of a source file around a particular SrcSpan.
1883 -- If the highlight flag is True, also highlight the span using
1884 -- start_bold/end_bold.
1885 listAround span do_highlight = do
1886 contents <- BS.readFile (unpackFS file)
1888 lines = BS.split '\n' contents
1889 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1890 drop (line1 - 1 - pad_before) $ lines
1891 fst_line = max 1 (line1 - pad_before)
1892 line_nos = [ fst_line .. ]
1894 highlighted | do_highlight = zipWith highlight line_nos these_lines
1895 | otherwise = these_lines
1897 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1898 prefixed = zipWith BS.append bs_line_nos highlighted
1900 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1902 file = GHC.srcSpanFile span
1903 line1 = GHC.srcSpanStartLine span
1904 col1 = GHC.srcSpanStartCol span
1905 line2 = GHC.srcSpanEndLine span
1906 col2 = GHC.srcSpanEndCol span
1908 pad_before | line1 == 1 = 0
1912 highlight | do_bold = highlight_bold
1913 | otherwise = highlight_carets
1915 highlight_bold no line
1916 | no == line1 && no == line2
1917 = let (a,r) = BS.splitAt col1 line
1918 (b,c) = BS.splitAt (col2-col1) r
1920 BS.concat [a,BS.pack start_bold,b,BS.pack end_bold,c]
1922 = let (a,b) = BS.splitAt col1 line in
1923 BS.concat [a, BS.pack start_bold, b]
1925 = let (a,b) = BS.splitAt col2 line in
1926 BS.concat [a, BS.pack end_bold, b]
1929 highlight_carets no line
1930 | no == line1 && no == line2
1931 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1932 BS.replicate (col2-col1) '^']
1934 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1935 BS.replicate (BS.length line-col1) '^']
1937 = BS.concat [line, nl, indent, BS.replicate col2 '^']
1940 indent = BS.pack " "
1941 nl = BS.singleton '\n'
1943 -- --------------------------------------------------------------------------
1946 getTickArray :: Module -> GHCi TickArray
1947 getTickArray modl = do
1949 let arrmap = tickarrays st
1950 case lookupModuleEnv arrmap modl of
1951 Just arr -> return arr
1953 (breakArray, ticks) <- getModBreak modl
1954 let arr = mkTickArray (assocs ticks)
1955 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1958 discardTickArrays :: GHCi ()
1959 discardTickArrays = do
1961 setGHCiState st{tickarrays = emptyModuleEnv}
1963 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1965 = accumArray (flip (:)) [] (1, max_line)
1966 [ (line, (nm,span)) | (nm,span) <- ticks,
1967 line <- srcSpanLines span ]
1969 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1970 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1971 GHC.srcSpanEndLine span ]
1973 lookupModule :: String -> GHCi Module
1974 lookupModule modName
1975 = do session <- getSession
1976 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1978 -- don't reset the counter back to zero?
1979 discardActiveBreakPoints :: GHCi ()
1980 discardActiveBreakPoints = do
1982 mapM (turnOffBreak.snd) (breaks st)
1983 setGHCiState $ st { breaks = [] }
1985 deleteBreak :: Int -> GHCi ()
1986 deleteBreak identity = do
1988 let oldLocations = breaks st
1989 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
1991 then printForUser (text "Breakpoint" <+> ppr identity <+>
1992 text "does not exist")
1994 mapM (turnOffBreak.snd) this
1995 setGHCiState $ st { breaks = rest }
1997 turnOffBreak loc = do
1998 (arr, _) <- getModBreak (breakModule loc)
1999 io $ setBreakFlag False arr (breakTick loc)
2001 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2002 getModBreak mod = do
2003 session <- getSession
2004 Just mod_info <- io $ GHC.getModuleInfo session mod
2005 let modBreaks = GHC.modInfoModBreaks mod_info
2006 let array = GHC.modBreaks_flags modBreaks
2007 let ticks = GHC.modBreaks_locs modBreaks
2008 return (array, ticks)
2010 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2011 setBreakFlag toggle array index
2012 | toggle = GHC.setBreakOn array index
2013 | otherwise = GHC.setBreakOff array index