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 printTypeAndContentOfNames session names
583 maybe (return ()) runBreakCmd mb_info
584 -- run the command set with ":set stop <cmd>"
586 enqueueCommands [stop st]
588 | otherwise -> io(GHC.resume session GHC.SingleStep) >>=
589 afterRunStmt pred >> return ()
593 io installSignalHandlers
594 b <- isOptionSet RevertCAFs
595 io (when b revertCAFs)
597 return (case run_result of GHC.RunOk _ -> True; _ -> False)
599 where printTypeAndContentOfNames session names = do
600 let namesSorted = sortBy compareNames names
601 tythings <- catMaybes `liftM`
602 io (mapM (GHC.lookupName session) names)
603 docs_ty <- mapM showTyThing tythings
604 terms <- mapM (io . GHC.obtainTermB session 10 False)
605 [ id | (AnId id, Just _) <- zip tythings docs_ty]
606 docs_terms <- mapM (io . showTerm session) terms
607 printForUser $ vcat $ zipWith (\ty cts -> ty <> text " = " <> cts)
611 runBreakCmd :: GHC.BreakInfo -> GHCi ()
612 runBreakCmd info = do
613 let mod = GHC.breakInfo_module info
614 nm = GHC.breakInfo_number info
616 case [ loc | (i,loc) <- breaks st,
617 breakModule loc == mod, breakTick loc == nm ] of
619 loc:_ | null cmd -> return ()
620 | otherwise -> do enqueueCommands [cmd]; return ()
621 where cmd = onBreakCmd loc
623 printTypeOfNames :: Session -> [Name] -> GHCi ()
624 printTypeOfNames session names
625 = mapM_ (printTypeOfName session) $ sortBy compareNames names
627 compareNames :: Name -> Name -> Ordering
628 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
629 where compareWith n = (getOccString n, getSrcSpan n)
631 printTypeOfName :: Session -> Name -> GHCi ()
632 printTypeOfName session n
633 = do maybe_tything <- io (GHC.lookupName session n)
634 case maybe_tything of
636 Just thing -> printTyThing thing
638 specialCommand :: String -> GHCi Bool
639 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
640 specialCommand str = do
641 let (cmd,rest) = break isSpace str
642 maybe_cmd <- io (lookupCommand cmd)
644 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
645 ++ shortHelpText) >> return False)
646 Just (_,f,_,_) -> f (dropWhile isSpace rest)
648 lookupCommand :: String -> IO (Maybe Command)
649 lookupCommand str = do
650 cmds <- readIORef commands
651 -- look for exact match first, then the first prefix match
652 case [ c | c <- cmds, str == cmdName c ] of
653 c:_ -> return (Just c)
654 [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
656 c:_ -> return (Just c)
659 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
660 getCurrentBreakSpan = do
661 session <- getSession
662 resumes <- io $ GHC.getResumeContext session
666 let ix = GHC.resumeHistoryIx r
668 then return (Just (GHC.resumeSpan r))
670 let hist = GHC.resumeHistory r !! (ix-1)
671 span <- io $ GHC.getHistorySpan session hist
674 getCurrentBreakModule :: GHCi (Maybe Module)
675 getCurrentBreakModule = do
676 session <- getSession
677 resumes <- io $ GHC.getResumeContext session
681 let ix = GHC.resumeHistoryIx r
683 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
685 let hist = GHC.resumeHistory r !! (ix-1)
686 return $ Just $ GHC.getHistoryModule hist
688 -----------------------------------------------------------------------------
691 noArgs :: GHCi () -> String -> GHCi ()
693 noArgs m _ = io $ putStrLn "This command takes no arguments"
695 help :: String -> GHCi ()
696 help _ = io (putStr helpText)
698 info :: String -> GHCi ()
699 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
700 info s = do { let names = words s
701 ; session <- getSession
702 ; dflags <- getDynFlags
703 ; let pefas = dopt Opt_PrintExplicitForalls dflags
704 ; mapM_ (infoThing pefas session) names }
706 infoThing pefas session str = io $ do
707 names <- GHC.parseName session str
708 mb_stuffs <- mapM (GHC.getInfo session) names
709 let filtered = filterOutChildren (\(t,f,i) -> t) (catMaybes mb_stuffs)
710 unqual <- GHC.getPrintUnqual session
711 putStrLn (showSDocForUser unqual $
712 vcat (intersperse (text "") $
713 map (pprInfo pefas) filtered))
715 -- Filter out names whose parent is also there Good
716 -- example is '[]', which is both a type and data
717 -- constructor in the same type
718 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
719 filterOutChildren get_thing xs
720 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
722 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
724 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
725 pprInfo pefas (thing, fixity, insts)
726 = pprTyThingInContextLoc pefas thing
727 $$ show_fixity fixity
728 $$ vcat (map GHC.pprInstance insts)
731 | fix == GHC.defaultFixity = empty
732 | otherwise = ppr fix <+> ppr (GHC.getName thing)
734 runMain :: String -> GHCi ()
736 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
737 enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
739 addModule :: [FilePath] -> GHCi ()
741 io (revertCAFs) -- always revert CAFs on load/add.
742 files <- mapM expandPath files
743 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
744 session <- getSession
745 io (mapM_ (GHC.addTarget session) targets)
746 ok <- io (GHC.load session LoadAllTargets)
749 changeDirectory :: String -> GHCi ()
750 changeDirectory dir = do
751 session <- getSession
752 graph <- io (GHC.getModuleGraph session)
753 when (not (null graph)) $
754 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
755 io (GHC.setTargets session [])
756 io (GHC.load session LoadAllTargets)
757 setContextAfterLoad session []
758 io (GHC.workingDirectoryChanged session)
759 dir <- expandPath dir
760 io (setCurrentDirectory dir)
762 editFile :: String -> GHCi ()
764 do file <- if null str then chooseEditFile else return str
768 $ throwDyn (CmdLineError "editor not set, use :set editor")
769 io $ system (cmd ++ ' ':file)
772 -- The user didn't specify a file so we pick one for them.
773 -- Our strategy is to pick the first module that failed to load,
774 -- or otherwise the first target.
776 -- XXX: Can we figure out what happened if the depndecy analysis fails
777 -- (e.g., because the porgrammeer mistyped the name of a module)?
778 -- XXX: Can we figure out the location of an error to pass to the editor?
779 -- XXX: if we could figure out the list of errors that occured during the
780 -- last load/reaload, then we could start the editor focused on the first
782 chooseEditFile :: GHCi String
784 do session <- getSession
785 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
787 graph <- io (GHC.getModuleGraph session)
788 failed_graph <- filterM hasFailed graph
789 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
791 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
794 case pick (order failed_graph) of
795 Just file -> return file
797 do targets <- io (GHC.getTargets session)
798 case msum (map fromTarget targets) of
799 Just file -> return file
800 Nothing -> throwDyn (CmdLineError "No files to edit.")
802 where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
803 fromTarget _ = Nothing -- when would we get a module target?
805 defineMacro :: String -> GHCi ()
807 let (macro_name, definition) = break isSpace s
808 cmds <- io (readIORef commands)
810 then throwDyn (CmdLineError "invalid macro name")
812 if (macro_name `elem` map cmdName cmds)
813 then throwDyn (CmdLineError
814 ("command '" ++ macro_name ++ "' is already defined"))
817 -- give the expression a type signature, so we can be sure we're getting
818 -- something of the right type.
819 let new_expr = '(' : definition ++ ") :: String -> IO String"
821 -- compile the expression
823 maybe_hv <- io (GHC.compileExpr cms new_expr)
826 Just hv -> io (writeIORef commands --
827 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
829 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
831 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
832 enqueueCommands (lines str)
835 undefineMacro :: String -> GHCi ()
836 undefineMacro macro_name = do
837 cmds <- io (readIORef commands)
838 if (macro_name `elem` map cmdName builtin_commands)
839 then throwDyn (CmdLineError
840 ("command '" ++ macro_name ++ "' cannot be undefined"))
842 if (macro_name `notElem` map cmdName cmds)
843 then throwDyn (CmdLineError
844 ("command '" ++ macro_name ++ "' not defined"))
846 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
848 cmdCmd :: String -> GHCi ()
850 let expr = '(' : str ++ ") :: IO String"
851 session <- getSession
852 maybe_hv <- io (GHC.compileExpr session expr)
856 cmds <- io $ (unsafeCoerce# hv :: IO String)
857 enqueueCommands (lines cmds)
860 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
861 loadModule fs = timeIt (loadModule' fs)
863 loadModule_ :: [FilePath] -> GHCi ()
864 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
866 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
867 loadModule' files = do
868 session <- getSession
871 discardActiveBreakPoints
872 io (GHC.setTargets session [])
873 io (GHC.load session LoadAllTargets)
876 let (filenames, phases) = unzip files
877 exp_filenames <- mapM expandPath filenames
878 let files' = zip exp_filenames phases
879 targets <- io (mapM (uncurry GHC.guessTarget) files')
881 -- NOTE: we used to do the dependency anal first, so that if it
882 -- fails we didn't throw away the current set of modules. This would
883 -- require some re-working of the GHC interface, so we'll leave it
884 -- as a ToDo for now.
886 io (GHC.setTargets session targets)
887 doLoad session LoadAllTargets
889 checkModule :: String -> GHCi ()
891 let modl = GHC.mkModuleName m
892 session <- getSession
893 result <- io (GHC.checkModule session modl False)
895 Nothing -> io $ putStrLn "Nothing"
896 Just r -> io $ putStrLn (showSDoc (
897 case GHC.checkedModuleInfo r of
898 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
900 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
902 (text "global names: " <+> ppr global) $$
903 (text "local names: " <+> ppr local)
905 afterLoad (successIf (isJust result)) session
907 reloadModule :: String -> GHCi ()
909 session <- getSession
910 doLoad session $ if null m then LoadAllTargets
911 else LoadUpTo (GHC.mkModuleName m)
914 doLoad session howmuch = do
915 -- turn off breakpoints before we load: we can't turn them off later, because
916 -- the ModBreaks will have gone away.
917 discardActiveBreakPoints
918 ok <- io (GHC.load session howmuch)
922 afterLoad ok session = do
923 io (revertCAFs) -- always revert CAFs on load.
925 graph <- io (GHC.getModuleGraph session)
926 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
927 setContextAfterLoad session graph'
928 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
930 setContextAfterLoad session [] = do
931 prel_mod <- getPrelude
932 io (GHC.setContext session [] [prel_mod])
933 setContextAfterLoad session ms = do
934 -- load a target if one is available, otherwise load the topmost module.
935 targets <- io (GHC.getTargets session)
936 case [ m | Just m <- map (findTarget ms) targets ] of
938 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
939 load_this (last graph')
944 = case filter (`matches` t) ms of
948 summary `matches` Target (TargetModule m) _
949 = GHC.ms_mod_name summary == m
950 summary `matches` Target (TargetFile f _) _
951 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
952 summary `matches` target
955 load_this summary | m <- GHC.ms_mod summary = do
956 b <- io (GHC.moduleIsInterpreted session m)
957 if b then io (GHC.setContext session [m] [])
959 prel_mod <- getPrelude
960 io (GHC.setContext session [] [prel_mod,m])
963 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
964 modulesLoadedMsg ok mods = do
965 dflags <- getDynFlags
966 when (verbosity dflags > 0) $ do
968 | null mods = text "none."
970 punctuate comma (map ppr mods)) <> text "."
973 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
975 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
978 typeOfExpr :: String -> GHCi ()
980 = do cms <- getSession
981 maybe_ty <- io (GHC.exprType cms str)
984 Just ty -> do ty' <- cleanType ty
985 printForUser $ text str <> text " :: " <> ppr ty'
987 kindOfType :: String -> GHCi ()
989 = do cms <- getSession
990 maybe_ty <- io (GHC.typeKind cms str)
993 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
995 quit :: String -> GHCi Bool
998 shellEscape :: String -> GHCi Bool
999 shellEscape str = io (system str >> return False)
1001 -----------------------------------------------------------------------------
1002 -- Browsing a module's contents
1004 browseCmd :: String -> GHCi ()
1007 ['*':m] | looksLikeModuleName m -> browseModule m False
1008 [m] | looksLikeModuleName m -> browseModule m True
1009 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1011 browseModule m exports_only = do
1013 modl <- if exports_only then lookupModule m
1014 else wantInterpretedModule m
1016 -- Temporarily set the context to the module we're interested in,
1017 -- just so we can get an appropriate PrintUnqualified
1018 (as,bs) <- io (GHC.getContext s)
1019 prel_mod <- getPrelude
1020 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1021 else GHC.setContext s [modl] [])
1022 unqual <- io (GHC.getPrintUnqual s)
1023 io (GHC.setContext s as bs)
1025 mb_mod_info <- io $ GHC.getModuleInfo s modl
1027 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1030 | exports_only = GHC.modInfoExports mod_info
1031 | otherwise = GHC.modInfoTopLevelScope mod_info
1034 mb_things <- io $ mapM (GHC.lookupName s) names
1035 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1037 dflags <- getDynFlags
1038 let pefas = dopt Opt_PrintExplicitForalls dflags
1039 io (putStrLn (showSDocForUser unqual (
1040 vcat (map (pprTyThingInContext pefas) filtered_things)
1042 -- ToDo: modInfoInstances currently throws an exception for
1043 -- package modules. When it works, we can do this:
1044 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1046 -----------------------------------------------------------------------------
1047 -- Setting the module context
1050 | all sensible mods = fn mods
1051 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1053 (fn, mods) = case str of
1054 '+':stuff -> (addToContext, words stuff)
1055 '-':stuff -> (removeFromContext, words stuff)
1056 stuff -> (newContext, words stuff)
1058 sensible ('*':m) = looksLikeModuleName m
1059 sensible m = looksLikeModuleName m
1061 separate :: Session -> [String] -> [Module] -> [Module]
1062 -> GHCi ([Module],[Module])
1063 separate session [] as bs = return (as,bs)
1064 separate session (('*':str):ms) as bs = do
1065 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1066 b <- io $ GHC.moduleIsInterpreted session m
1067 if b then separate session ms (m:as) bs
1068 else throwDyn (CmdLineError ("module '"
1069 ++ GHC.moduleNameString (GHC.moduleName m)
1070 ++ "' is not interpreted"))
1071 separate session (str:ms) as bs = do
1072 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1073 separate session ms as (m:bs)
1075 newContext :: [String] -> GHCi ()
1076 newContext strs = do
1078 (as,bs) <- separate s strs [] []
1079 prel_mod <- getPrelude
1080 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1081 io $ GHC.setContext s as bs'
1084 addToContext :: [String] -> GHCi ()
1085 addToContext strs = do
1087 (as,bs) <- io $ GHC.getContext s
1089 (new_as,new_bs) <- separate s strs [] []
1091 let as_to_add = new_as \\ (as ++ bs)
1092 bs_to_add = new_bs \\ (as ++ bs)
1094 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1097 removeFromContext :: [String] -> GHCi ()
1098 removeFromContext strs = do
1100 (as,bs) <- io $ GHC.getContext s
1102 (as_to_remove,bs_to_remove) <- separate s strs [] []
1104 let as' = as \\ (as_to_remove ++ bs_to_remove)
1105 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1107 io $ GHC.setContext s as' bs'
1109 ----------------------------------------------------------------------------
1112 -- set options in the interpreter. Syntax is exactly the same as the
1113 -- ghc command line, except that certain options aren't available (-C,
1116 -- This is pretty fragile: most options won't work as expected. ToDo:
1117 -- figure out which ones & disallow them.
1119 setCmd :: String -> GHCi ()
1121 = do st <- getGHCiState
1122 let opts = options st
1123 io $ putStrLn (showSDoc (
1124 text "options currently set: " <>
1127 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1130 = case toArgs str of
1131 ("args":args) -> setArgs args
1132 ("prog":prog) -> setProg prog
1133 ("prompt":prompt) -> setPrompt (after 6)
1134 ("editor":cmd) -> setEditor (after 6)
1135 ("stop":cmd) -> setStop (after 4)
1136 wds -> setOptions wds
1137 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1141 setGHCiState st{ args = args }
1145 setGHCiState st{ progname = prog }
1147 io (hPutStrLn stderr "syntax: :set prog <progname>")
1151 setGHCiState st{ editor = cmd }
1153 setStop str@(c:_) | isDigit c
1154 = do let (nm_str,rest) = break (not.isDigit) str
1157 let old_breaks = breaks st
1158 if all ((/= nm) . fst) old_breaks
1159 then printForUser (text "Breakpoint" <+> ppr nm <+>
1160 text "does not exist")
1162 let new_breaks = map fn old_breaks
1163 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1164 | otherwise = (i,loc)
1165 setGHCiState st{ breaks = new_breaks }
1168 setGHCiState st{ stop = cmd }
1170 setPrompt value = do
1173 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1174 else setGHCiState st{ prompt = remQuotes value }
1176 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1180 do -- first, deal with the GHCi opts (+s, +t, etc.)
1181 let (plus_opts, minus_opts) = partition isPlus wds
1182 mapM_ setOpt plus_opts
1183 -- then, dynamic flags
1184 newDynFlags minus_opts
1186 newDynFlags minus_opts = do
1187 dflags <- getDynFlags
1188 let pkg_flags = packageFlags dflags
1189 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1191 if (not (null leftovers))
1192 then throwDyn (CmdLineError ("unrecognised flags: " ++
1196 new_pkgs <- setDynFlags dflags'
1198 -- if the package flags changed, we should reset the context
1199 -- and link the new packages.
1200 dflags <- getDynFlags
1201 when (packageFlags dflags /= pkg_flags) $ do
1202 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1203 session <- getSession
1204 io (GHC.setTargets session [])
1205 io (GHC.load session LoadAllTargets)
1206 io (linkPackages dflags new_pkgs)
1207 setContextAfterLoad session []
1211 unsetOptions :: String -> GHCi ()
1213 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1214 let opts = words str
1215 (minus_opts, rest1) = partition isMinus opts
1216 (plus_opts, rest2) = partition isPlus rest1
1218 if (not (null rest2))
1219 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1222 mapM_ unsetOpt plus_opts
1224 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1225 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1227 no_flags <- mapM no_flag minus_opts
1228 newDynFlags no_flags
1230 isMinus ('-':s) = True
1233 isPlus ('+':s) = True
1237 = case strToGHCiOpt str of
1238 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1239 Just o -> setOption o
1242 = case strToGHCiOpt str of
1243 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1244 Just o -> unsetOption o
1246 strToGHCiOpt :: String -> (Maybe GHCiOption)
1247 strToGHCiOpt "s" = Just ShowTiming
1248 strToGHCiOpt "t" = Just ShowType
1249 strToGHCiOpt "r" = Just RevertCAFs
1250 strToGHCiOpt _ = Nothing
1252 optToStr :: GHCiOption -> String
1253 optToStr ShowTiming = "s"
1254 optToStr ShowType = "t"
1255 optToStr RevertCAFs = "r"
1257 -- ---------------------------------------------------------------------------
1263 ["args"] -> io $ putStrLn (show (args st))
1264 ["prog"] -> io $ putStrLn (show (progname st))
1265 ["prompt"] -> io $ putStrLn (show (prompt st))
1266 ["editor"] -> io $ putStrLn (show (editor st))
1267 ["stop"] -> io $ putStrLn (show (stop st))
1268 ["modules" ] -> showModules
1269 ["bindings"] -> showBindings
1270 ["linker"] -> io showLinkerState
1271 ["breaks"] -> showBkptTable
1272 ["context"] -> showContext
1273 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1276 session <- getSession
1277 let show_one ms = do m <- io (GHC.showModule session ms)
1279 graph <- io (GHC.getModuleGraph session)
1280 mapM_ show_one graph
1284 unqual <- io (GHC.getPrintUnqual s)
1285 bindings <- io (GHC.getBindings s)
1286 mapM_ printTyThing $ sortBy compareTyThings bindings
1289 compareTyThings :: TyThing -> TyThing -> Ordering
1290 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1292 showTyThing :: TyThing -> GHCi (Maybe SDoc)
1293 showTyThing (AnId id) = do
1294 ty' <- cleanType (GHC.idType id)
1295 return $ Just $ ppr id <> text " :: " <> ppr ty'
1296 showTyThing _ = return Nothing
1298 printTyThing :: TyThing -> GHCi ()
1299 printTyThing tyth = do
1300 mb_x <- showTyThing tyth
1302 Just x -> printForUser x
1303 Nothing -> return ()
1305 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1306 cleanType :: Type -> GHCi Type
1308 dflags <- getDynFlags
1309 if dopt Opt_PrintExplicitForalls dflags
1311 else return $! GHC.dropForAlls ty
1313 showBkptTable :: GHCi ()
1316 printForUser $ prettyLocations (breaks st)
1318 showContext :: GHCi ()
1320 session <- getSession
1321 resumes <- io $ GHC.getResumeContext session
1322 printForUser $ vcat (map pp_resume (reverse resumes))
1325 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1326 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1329 -- -----------------------------------------------------------------------------
1332 completeNone :: String -> IO [String]
1333 completeNone w = return []
1336 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1337 completeWord w start end = do
1338 line <- Readline.getLineBuffer
1340 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1342 | Just c <- is_cmd line -> do
1343 maybe_cmd <- lookupCommand c
1344 let (n,w') = selectWord (words' 0 line)
1346 Nothing -> return Nothing
1347 Just (_,_,False,complete) -> wrapCompleter complete w
1348 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1349 return (map (drop n) rets)
1350 in wrapCompleter complete' w'
1352 --printf "complete %s, start = %d, end = %d\n" w start end
1353 wrapCompleter completeIdentifier w
1354 where words' _ [] = []
1355 words' n str = let (w,r) = break isSpace str
1356 (s,r') = span isSpace r
1357 in (n,w):words' (n+length w+length s) r'
1358 -- In a Haskell expression we want to parse 'a-b' as three words
1359 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1360 -- only be a single word.
1361 selectWord [] = (0,w)
1362 selectWord ((offset,x):xs)
1363 | offset+length x >= start = (start-offset,take (end-offset) x)
1364 | otherwise = selectWord xs
1367 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1368 | otherwise = Nothing
1371 cmds <- readIORef commands
1372 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1374 completeMacro w = do
1375 cmds <- readIORef commands
1376 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1377 return (filter (w `isPrefixOf`) cmds')
1379 completeIdentifier w = do
1381 rdrs <- GHC.getRdrNamesInScope s
1382 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1384 completeModule w = do
1386 dflags <- GHC.getSessionDynFlags s
1387 let pkg_mods = allExposedModules dflags
1388 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1390 completeHomeModule w = do
1392 g <- GHC.getModuleGraph s
1393 let home_mods = map GHC.ms_mod_name g
1394 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1396 completeSetOptions w = do
1397 return (filter (w `isPrefixOf`) options)
1398 where options = "args":"prog":allFlags
1400 completeFilename = Readline.filenameCompletionFunction
1402 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1404 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1405 unionComplete f1 f2 w = do
1410 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1411 wrapCompleter fun w = do
1414 [] -> return Nothing
1415 [x] -> return (Just (x,[]))
1416 xs -> case getCommonPrefix xs of
1417 "" -> return (Just ("",xs))
1418 pref -> return (Just (pref,xs))
1420 getCommonPrefix :: [String] -> String
1421 getCommonPrefix [] = ""
1422 getCommonPrefix (s:ss) = foldl common s ss
1423 where common s "" = ""
1425 common (c:cs) (d:ds)
1426 | c == d = c : common cs ds
1429 allExposedModules :: DynFlags -> [ModuleName]
1430 allExposedModules dflags
1431 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1433 pkg_db = pkgIdMap (pkgState dflags)
1435 completeCmd = completeNone
1436 completeMacro = completeNone
1437 completeIdentifier = completeNone
1438 completeModule = completeNone
1439 completeHomeModule = completeNone
1440 completeSetOptions = completeNone
1441 completeFilename = completeNone
1442 completeHomeModuleOrFile=completeNone
1443 completeBkpt = completeNone
1446 -- ---------------------------------------------------------------------------
1447 -- User code exception handling
1449 -- This is the exception handler for exceptions generated by the
1450 -- user's code and exceptions coming from children sessions;
1451 -- it normally just prints out the exception. The
1452 -- handler must be recursive, in case showing the exception causes
1453 -- more exceptions to be raised.
1455 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1456 -- raising another exception. We therefore don't put the recursive
1457 -- handler arond the flushing operation, so if stderr is closed
1458 -- GHCi will just die gracefully rather than going into an infinite loop.
1459 handler :: Exception -> GHCi Bool
1461 handler exception = do
1463 io installSignalHandlers
1464 ghciHandle handler (showException exception >> return False)
1466 showException (DynException dyn) =
1467 case fromDynamic dyn of
1468 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1469 Just Interrupted -> io (putStrLn "Interrupted.")
1470 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1471 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1472 Just other_ghc_ex -> io (print other_ghc_ex)
1474 showException other_exception
1475 = io (putStrLn ("*** Exception: " ++ show other_exception))
1477 -----------------------------------------------------------------------------
1478 -- recursive exception handlers
1480 -- Don't forget to unblock async exceptions in the handler, or if we're
1481 -- in an exception loop (eg. let a = error a in a) the ^C exception
1482 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1484 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1485 ghciHandle h (GHCi m) = GHCi $ \s ->
1486 Exception.catch (m s)
1487 (\e -> unGHCi (ghciUnblock (h e)) s)
1489 ghciUnblock :: GHCi a -> GHCi a
1490 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1493 -- ----------------------------------------------------------------------------
1496 expandPath :: String -> GHCi String
1498 case dropWhile isSpace path of
1500 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1501 return (tilde ++ '/':d)
1505 wantInterpretedModule :: String -> GHCi Module
1506 wantInterpretedModule str = do
1507 session <- getSession
1508 modl <- lookupModule str
1509 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1510 when (not is_interpreted) $
1511 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1514 wantNameFromInterpretedModule noCanDo str and_then = do
1515 session <- getSession
1516 names <- io $ GHC.parseName session str
1520 let modl = GHC.nameModule n
1521 if not (GHC.isExternalName n)
1522 then noCanDo n $ ppr n <>
1523 text " is not defined in an interpreted module"
1525 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1526 if not is_interpreted
1527 then noCanDo n $ text "module " <> ppr modl <>
1528 text " is not interpreted"
1531 -- ----------------------------------------------------------------------------
1532 -- Windows console setup
1534 setUpConsole :: IO ()
1536 #ifdef mingw32_HOST_OS
1537 -- On Windows we need to set a known code page, otherwise the characters
1538 -- we read from the console will be be in some strange encoding, and
1539 -- similarly for characters we write to the console.
1541 -- At the moment, GHCi pretends all input is Latin-1. In the
1542 -- future we should support UTF-8, but for now we set the code pages
1545 -- It seems you have to set the font in the console window to
1546 -- a Unicode font in order for output to work properly,
1547 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1548 -- (see MSDN for SetConsoleOutputCP()).
1550 setConsoleCP 28591 -- ISO Latin-1
1551 setConsoleOutputCP 28591 -- ISO Latin-1
1555 -- -----------------------------------------------------------------------------
1556 -- commands for debugger
1558 sprintCmd = pprintCommand False False
1559 printCmd = pprintCommand True False
1560 forceCmd = pprintCommand False True
1562 pprintCommand bind force str = do
1563 session <- getSession
1564 io $ pprintClosureCommand session bind force str
1566 stepCmd :: String -> GHCi ()
1567 stepCmd [] = doContinue (const True) GHC.SingleStep
1568 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1571 mb_span <- getCurrentBreakSpan
1573 Nothing -> stepCmd []
1575 Just mod <- getCurrentBreakModule
1576 parent <- enclosingTickSpan mod loc
1577 allTicksRightmost <- (sortBy rightmost . map snd) `fmap`
1579 let lastTick = null allTicksRightmost ||
1580 head allTicksRightmost == loc
1582 then doContinue (`isSubspanOf` parent) GHC.SingleStep
1583 else doContinue (const True) GHC.SingleStep
1585 stepOverCmd expression = stepCmd expression
1588 So, the only tricky part 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
1597 --ticksIn :: Module -> SrcSpan -> GHCi [Tick]
1598 ticksIn mod src = do
1599 ticks <- getTickArray mod
1600 let lines = [srcSpanStartLine src .. srcSpanEndLine src]
1601 return [ t | line <- lines
1602 , t@(_,span) <- ticks ! line
1603 , srcSpanStart src <= srcSpanStart span
1604 , srcSpanEnd src >= srcSpanEnd span
1607 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1608 enclosingTickSpan mod src = do
1609 ticks <- getTickArray mod
1610 let line = srcSpanStartLine src
1611 ASSERT (inRange (bounds ticks) line) do
1612 let enclosing_spans = [ span | (_,span) <- ticks ! line
1613 , srcSpanEnd span >= srcSpanEnd src]
1614 return . head . sortBy leftmost_largest $ enclosing_spans
1616 traceCmd :: String -> GHCi ()
1617 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1618 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1620 continueCmd :: String -> GHCi ()
1621 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1623 -- doContinue :: SingleStep -> GHCi ()
1624 doContinue pred step = do
1625 session <- getSession
1626 runResult <- io $ GHC.resume session step
1627 afterRunStmt pred runResult
1630 abandonCmd :: String -> GHCi ()
1631 abandonCmd = noArgs $ do
1633 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1634 when (not b) $ io $ putStrLn "There is no computation running."
1637 deleteCmd :: String -> GHCi ()
1638 deleteCmd argLine = do
1639 deleteSwitch $ words argLine
1641 deleteSwitch :: [String] -> GHCi ()
1643 io $ putStrLn "The delete command requires at least one argument."
1644 -- delete all break points
1645 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1646 deleteSwitch idents = do
1647 mapM_ deleteOneBreak idents
1649 deleteOneBreak :: String -> GHCi ()
1651 | all isDigit str = deleteBreak (read str)
1652 | otherwise = return ()
1654 historyCmd :: String -> GHCi ()
1656 | null arg = history 20
1657 | all isDigit arg = history (read arg)
1658 | otherwise = io $ putStrLn "Syntax: :history [num]"
1662 resumes <- io $ GHC.getResumeContext s
1664 [] -> io $ putStrLn "Not stopped at a breakpoint"
1666 let hist = GHC.resumeHistory r
1667 (took,rest) = splitAt num hist
1668 spans <- mapM (io . GHC.getHistorySpan s) took
1669 let nums = map (printf "-%-3d:") [(1::Int)..]
1670 let names = map GHC.historyEnclosingDecl took
1671 printForUser (vcat(zipWith3
1672 (\x y z -> x <+> y <+> z)
1674 (map (bold . ppr) names)
1675 (map (parens . ppr) spans)))
1676 io $ putStrLn $ if null rest then "<end of history>" else "..."
1678 bold c | do_bold = text start_bold <> c <> text end_bold
1681 backCmd :: String -> GHCi ()
1682 backCmd = noArgs $ do
1684 (names, ix, span) <- io $ GHC.back s
1685 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1686 printTypeOfNames s names
1687 -- run the command set with ":set stop <cmd>"
1689 enqueueCommands [stop st]
1691 forwardCmd :: String -> GHCi ()
1692 forwardCmd = noArgs $ do
1694 (names, ix, span) <- io $ GHC.forward s
1695 printForUser $ (if (ix == 0)
1696 then ptext SLIT("Stopped at")
1697 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1698 printTypeOfNames s names
1699 -- run the command set with ":set stop <cmd>"
1701 enqueueCommands [stop st]
1703 -- handle the "break" command
1704 breakCmd :: String -> GHCi ()
1705 breakCmd argLine = do
1706 session <- getSession
1707 breakSwitch session $ words argLine
1709 breakSwitch :: Session -> [String] -> GHCi ()
1710 breakSwitch _session [] = do
1711 io $ putStrLn "The break command requires at least one argument."
1712 breakSwitch session args@(arg1:rest)
1713 | looksLikeModuleName arg1 = do
1714 mod <- wantInterpretedModule arg1
1715 breakByModule session mod rest
1716 | all isDigit arg1 = do
1717 (toplevel, _) <- io $ GHC.getContext session
1719 (mod : _) -> breakByModuleLine mod (read arg1) rest
1721 io $ putStrLn "Cannot find default module for breakpoint."
1722 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1723 | otherwise = do -- try parsing it as an identifier
1724 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1725 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1726 if GHC.isGoodSrcLoc loc
1727 then findBreakAndSet (GHC.nameModule name) $
1728 findBreakByCoord (Just (GHC.srcLocFile loc))
1729 (GHC.srcLocLine loc,
1731 else noCanDo name $ text "can't find its location: " <> ppr loc
1733 noCanDo n why = printForUser $
1734 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1736 breakByModule :: Session -> Module -> [String] -> GHCi ()
1737 breakByModule session mod args@(arg1:rest)
1738 | all isDigit arg1 = do -- looks like a line number
1739 breakByModuleLine mod (read arg1) rest
1740 breakByModule session mod _
1743 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1744 breakByModuleLine mod line args
1745 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1746 | [col] <- args, all isDigit col =
1747 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1748 | otherwise = breakSyntax
1750 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1752 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1753 findBreakAndSet mod lookupTickTree = do
1754 tickArray <- getTickArray mod
1755 (breakArray, _) <- getModBreak mod
1756 case lookupTickTree tickArray of
1757 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1758 Just (tick, span) -> do
1759 success <- io $ setBreakFlag True breakArray tick
1760 session <- getSession
1764 recordBreak $ BreakLocation
1771 text "Breakpoint " <> ppr nm <>
1773 then text " was already set at " <> ppr span
1774 else text " activated at " <> ppr span
1776 printForUser $ text "Breakpoint could not be activated at"
1779 -- When a line number is specified, the current policy for choosing
1780 -- the best breakpoint is this:
1781 -- - the leftmost complete subexpression on the specified line, or
1782 -- - the leftmost subexpression starting on the specified line, or
1783 -- - the rightmost subexpression enclosing the specified line
1785 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1786 findBreakByLine line arr
1787 | not (inRange (bounds arr) line) = Nothing
1789 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
1790 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
1791 listToMaybe (sortBy (rightmost `on` snd) ticks)
1795 starts_here = [ tick | tick@(nm,span) <- ticks,
1796 GHC.srcSpanStartLine span == line ]
1798 (complete,incomplete) = partition ends_here starts_here
1799 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1801 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1802 -> Maybe (BreakIndex,SrcSpan)
1803 findBreakByCoord mb_file (line, col) arr
1804 | not (inRange (bounds arr) line) = Nothing
1806 listToMaybe (sortBy (rightmost `on` snd) contains ++
1807 sortBy (leftmost_smallest `on` snd) after_here)
1811 -- the ticks that span this coordinate
1812 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1813 is_correct_file span ]
1815 is_correct_file span
1816 | Just f <- mb_file = GHC.srcSpanFile span == f
1819 after_here = [ tick | tick@(nm,span) <- ticks,
1820 GHC.srcSpanStartLine span == line,
1821 GHC.srcSpanStartCol span >= col ]
1823 -- for now, use ANSI bold on Unixy systems. On Windows, we add a line
1824 -- of carets under the active expression instead. The Windows console
1825 -- doesn't support ANSI escape sequences, and most Unix terminals
1826 -- (including xterm) do, so this is a reasonable guess until we have a
1827 -- proper termcap/terminfo library.
1828 #if !defined(mingw32_TARGET_OS)
1834 start_bold = "\ESC[1m"
1835 end_bold = "\ESC[0m"
1837 listCmd :: String -> GHCi ()
1839 mb_span <- getCurrentBreakSpan
1841 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1842 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1843 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
1844 listCmd str = list2 (words str)
1846 list2 [arg] | all isDigit arg = do
1847 session <- getSession
1848 (toplevel, _) <- io $ GHC.getContext session
1850 [] -> io $ putStrLn "No module to list"
1851 (mod : _) -> listModuleLine mod (read arg)
1852 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1853 mod <- wantInterpretedModule arg1
1854 listModuleLine mod (read arg2)
1856 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1857 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1858 if GHC.isGoodSrcLoc loc
1860 tickArray <- getTickArray (GHC.nameModule name)
1861 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1862 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1865 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1866 Just (_,span) -> io $ listAround span False
1868 noCanDo name $ text "can't find its location: " <>
1871 noCanDo n why = printForUser $
1872 text "cannot list source code for " <> ppr n <> text ": " <> why
1874 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1876 listModuleLine :: Module -> Int -> GHCi ()
1877 listModuleLine modl line = do
1878 session <- getSession
1879 graph <- io (GHC.getModuleGraph session)
1880 let this = filter ((== modl) . GHC.ms_mod) graph
1882 [] -> panic "listModuleLine"
1884 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1885 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1886 io $ listAround (GHC.srcLocSpan loc) False
1888 -- | list a section of a source file around a particular SrcSpan.
1889 -- If the highlight flag is True, also highlight the span using
1890 -- start_bold/end_bold.
1891 listAround span do_highlight = do
1892 contents <- BS.readFile (unpackFS file)
1894 lines = BS.split '\n' contents
1895 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1896 drop (line1 - 1 - pad_before) $ lines
1897 fst_line = max 1 (line1 - pad_before)
1898 line_nos = [ fst_line .. ]
1900 highlighted | do_highlight = zipWith highlight line_nos these_lines
1901 | otherwise = these_lines
1903 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1904 prefixed = zipWith BS.append bs_line_nos highlighted
1906 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1908 file = GHC.srcSpanFile span
1909 line1 = GHC.srcSpanStartLine span
1910 col1 = GHC.srcSpanStartCol span
1911 line2 = GHC.srcSpanEndLine span
1912 col2 = GHC.srcSpanEndCol span
1914 pad_before | line1 == 1 = 0
1918 highlight | do_bold = highlight_bold
1919 | otherwise = highlight_carets
1921 highlight_bold no line
1922 | no == line1 && no == line2
1923 = let (a,r) = BS.splitAt col1 line
1924 (b,c) = BS.splitAt (col2-col1) r
1926 BS.concat [a,BS.pack start_bold,b,BS.pack end_bold,c]
1928 = let (a,b) = BS.splitAt col1 line in
1929 BS.concat [a, BS.pack start_bold, b]
1931 = let (a,b) = BS.splitAt col2 line in
1932 BS.concat [a, BS.pack end_bold, b]
1935 highlight_carets no line
1936 | no == line1 && no == line2
1937 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1938 BS.replicate (col2-col1) '^']
1940 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1941 BS.replicate (BS.length line-col1) '^']
1943 = BS.concat [line, nl, indent, BS.replicate col2 '^']
1946 indent = BS.pack " "
1947 nl = BS.singleton '\n'
1949 -- --------------------------------------------------------------------------
1952 getTickArray :: Module -> GHCi TickArray
1953 getTickArray modl = do
1955 let arrmap = tickarrays st
1956 case lookupModuleEnv arrmap modl of
1957 Just arr -> return arr
1959 (breakArray, ticks) <- getModBreak modl
1960 let arr = mkTickArray (assocs ticks)
1961 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1964 discardTickArrays :: GHCi ()
1965 discardTickArrays = do
1967 setGHCiState st{tickarrays = emptyModuleEnv}
1969 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1971 = accumArray (flip (:)) [] (1, max_line)
1972 [ (line, (nm,span)) | (nm,span) <- ticks,
1973 line <- srcSpanLines span ]
1975 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1976 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1977 GHC.srcSpanEndLine span ]
1979 lookupModule :: String -> GHCi Module
1980 lookupModule modName
1981 = do session <- getSession
1982 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1984 -- don't reset the counter back to zero?
1985 discardActiveBreakPoints :: GHCi ()
1986 discardActiveBreakPoints = do
1988 mapM (turnOffBreak.snd) (breaks st)
1989 setGHCiState $ st { breaks = [] }
1991 deleteBreak :: Int -> GHCi ()
1992 deleteBreak identity = do
1994 let oldLocations = breaks st
1995 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
1997 then printForUser (text "Breakpoint" <+> ppr identity <+>
1998 text "does not exist")
2000 mapM (turnOffBreak.snd) this
2001 setGHCiState $ st { breaks = rest }
2003 turnOffBreak loc = do
2004 (arr, _) <- getModBreak (breakModule loc)
2005 io $ setBreakFlag False arr (breakTick loc)
2007 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2008 getModBreak mod = do
2009 session <- getSession
2010 Just mod_info <- io $ GHC.getModuleInfo session mod
2011 let modBreaks = GHC.modInfoModBreaks mod_info
2012 let array = GHC.modBreaks_flags modBreaks
2013 let ticks = GHC.modBreaks_locs modBreaks
2014 return (array, ticks)
2016 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2017 setBreakFlag toggle array index
2018 | toggle = GHC.setBreakOn array index
2019 | otherwise = GHC.setBreakOff array index