1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005-2006
8 -----------------------------------------------------------------------------
10 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
12 #include "HsVersions.h"
20 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
21 Module, ModuleName, TyThing(..), Phase,
22 BreakIndex, SrcSpan, Resume, SingleStep )
32 import HscTypes ( implicitTyThings )
33 import Outputable hiding (printForUser)
34 import Module -- for ModuleEnv
38 -- Other random utilities
40 import BasicTypes hiding (isTopLevel)
41 import Panic hiding (showException)
47 import Maybes ( orElse )
50 #ifndef mingw32_HOST_OS
51 import System.Posix hiding (getEnv)
53 import GHC.ConsoleHandler ( flushConsole )
54 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
55 import qualified System.Win32
59 import Control.Concurrent ( yield ) -- Used in readline loop
60 import System.Console.Readline as Readline
65 import Control.Exception as Exception
66 -- import Control.Concurrent
68 import qualified Data.ByteString.Char8 as BS
72 import System.Environment
73 import System.Exit ( exitWith, ExitCode(..) )
74 import System.Directory
76 import System.IO.Error as IO
77 import System.IO.Unsafe
81 import Control.Monad as Monad
84 import Foreign.StablePtr ( newStablePtr )
85 import GHC.Exts ( unsafeCoerce# )
86 import GHC.IOBase ( IOErrorType(InvalidArgument) )
88 import Data.IORef ( IORef, readIORef, writeIORef )
91 import System.Posix.Internals ( setNonBlockingFD )
94 -----------------------------------------------------------------------------
96 ghciWelcomeMsg :: String
97 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
98 ": http://www.haskell.org/ghc/ :? for help"
100 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
102 cmdName :: Command -> String
103 cmdName (n,_,_,_) = n
105 commands :: IORef [Command]
106 GLOBAL_VAR(commands, builtin_commands, [Command])
108 builtin_commands :: [Command]
110 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
111 ("?", keepGoing help, False, completeNone),
112 ("add", keepGoingPaths addModule, False, completeFilename),
113 ("abandon", keepGoing abandonCmd, False, completeNone),
114 ("break", keepGoing breakCmd, False, completeIdentifier),
115 ("back", keepGoing backCmd, False, completeNone),
116 ("browse", keepGoing browseCmd, False, completeModule),
117 ("cd", keepGoing changeDirectory, False, completeFilename),
118 ("check", keepGoing checkModule, False, completeHomeModule),
119 ("continue", keepGoing continueCmd, False, completeNone),
120 ("cmd", keepGoing cmdCmd, False, completeIdentifier),
121 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
122 ("def", keepGoing defineMacro, False, completeIdentifier),
123 ("delete", keepGoing deleteCmd, False, completeNone),
124 ("e", keepGoing editFile, False, completeFilename),
125 ("edit", keepGoing editFile, False, completeFilename),
126 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
127 ("force", keepGoing forceCmd, False, completeIdentifier),
128 ("forward", keepGoing forwardCmd, False, completeNone),
129 ("help", keepGoing help, False, completeNone),
130 ("history", keepGoing historyCmd, False, completeNone),
131 ("info", keepGoing info, False, completeIdentifier),
132 ("kind", keepGoing kindOfType, False, completeIdentifier),
133 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
134 ("list", keepGoing listCmd, False, completeNone),
135 ("module", keepGoing setContext, False, completeModule),
136 ("main", keepGoing runMain, False, completeIdentifier),
137 ("print", keepGoing printCmd, False, completeIdentifier),
138 ("quit", quit, False, completeNone),
139 ("reload", keepGoing reloadModule, False, completeNone),
140 ("set", keepGoing setCmd, True, completeSetOptions),
141 ("show", keepGoing showCmd, False, completeNone),
142 ("sprint", keepGoing sprintCmd, False, completeIdentifier),
143 ("step", keepGoing stepCmd, False, completeIdentifier),
144 ("steplocal", keepGoing stepLocalCmd, False, completeIdentifier),
145 ("stepmodule",keepGoing stepModuleCmd, False, completeIdentifier),
146 ("type", keepGoing typeOfExpr, False, completeIdentifier),
147 ("trace", keepGoing traceCmd, False, completeIdentifier),
148 ("undef", keepGoing undefineMacro, False, completeMacro),
149 ("unset", keepGoing unsetOptions, True, completeSetOptions)
152 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
153 keepGoing a str = a str >> return False
155 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
156 keepGoingPaths a str = a (toArgs str) >> return False
158 shortHelpText :: String
159 shortHelpText = "use :? for help.\n"
163 " Commands available from the prompt:\n" ++
165 " <statement> evaluate/run <statement>\n" ++
166 " :add <filename> ... add module(s) to the current target set\n" ++
167 " :browse [[*]<module>] display the names defined by <module>\n" ++
168 " :cd <dir> change directory to <dir>\n" ++
169 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
170 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
171 " :def <cmd> <expr> define a command :<cmd>\n" ++
172 " :edit <file> edit file\n" ++
173 " :edit edit last module\n" ++
174 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
175 " :help, :? display this list of commands\n" ++
176 " :info [<name> ...] display information about the given names\n" ++
177 " :kind <type> show the kind of <type>\n" ++
178 " :load <filename> ... load module(s) and their dependents\n" ++
179 " :main [<arguments> ...] run the main function with the given arguments\n" ++
180 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
181 " :quit exit GHCi\n" ++
182 " :reload reload the current module set\n" ++
183 " :type <expr> show the type of <expr>\n" ++
184 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
185 " :!<command> run the shell command <command>\n" ++
187 " -- Commands for debugging:\n" ++
189 " :abandon at a breakpoint, abandon current computation\n" ++
190 " :back go back in the history (after :trace)\n" ++
191 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
192 " :break <name> set a breakpoint on the specified function\n" ++
193 " :continue resume after a breakpoint\n" ++
194 " :delete <number> delete the specified breakpoint\n" ++
195 " :delete * delete all breakpoints\n" ++
196 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
197 " :forward go forward in the history (after :back)\n" ++
198 " :history [<n>] show the last <n> items in the history (after :trace)\n" ++
199 " :print [<name> ...] prints a value without forcing its computation\n" ++
200 " :sprint [<name> ...] simplifed version of :print\n" ++
201 " :step single-step after stopping at a breakpoint\n"++
202 " :step <expr> single-step into <expr>\n"++
203 " :steplocal single-step restricted to the current top level decl.\n"++
204 " :stepmodule single-step restricted to the current module\n"++
205 " :trace trace after stopping at a breakpoint\n"++
206 " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
209 " -- Commands for changing settings:\n" ++
211 " :set <option> ... set options\n" ++
212 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
213 " :set prog <progname> set the value returned by System.getProgName\n" ++
214 " :set prompt <prompt> set the prompt used in GHCi\n" ++
215 " :set editor <cmd> set the command used for :edit\n" ++
216 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
217 " :unset <option> ... unset options\n" ++
219 " Options for ':set' and ':unset':\n" ++
221 " +r revert top-level expressions after each evaluation\n" ++
222 " +s print timing/memory stats after each evaluation\n" ++
223 " +t print type after evaluation\n" ++
224 " -<flags> most GHC command line flags can also be set here\n" ++
225 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
227 " -- Commands for displaying information:\n" ++
229 " :show bindings show the current bindings made at the prompt\n" ++
230 " :show breaks show the active breakpoints\n" ++
231 " :show context show the breakpoint context\n" ++
232 " :show modules show the currently loaded modules\n" ++
233 " :show <setting> show anything that can be set with :set (e.g. args)\n" ++
236 findEditor :: IO String
241 win <- System.Win32.getWindowsDirectory
242 return (win `joinFileName` "notepad.exe")
247 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
248 interactiveUI session srcs maybe_expr = do
249 -- HACK! If we happen to get into an infinite loop (eg the user
250 -- types 'let x=x in x' at the prompt), then the thread will block
251 -- on a blackhole, and become unreachable during GC. The GC will
252 -- detect that it is unreachable and send it the NonTermination
253 -- exception. However, since the thread is unreachable, everything
254 -- it refers to might be finalized, including the standard Handles.
255 -- This sounds like a bug, but we don't have a good solution right
261 -- Initialise buffering for the *interpreted* I/O system
262 initInterpBuffering session
264 when (isNothing maybe_expr) $ do
265 -- Only for GHCi (not runghc and ghc -e):
267 -- Turn buffering off for the compiled program's stdout/stderr
269 -- Turn buffering off for GHCi's stdout
271 hSetBuffering stdout NoBuffering
272 -- We don't want the cmd line to buffer any input that might be
273 -- intended for the program, so unbuffer stdin.
274 hSetBuffering stdin NoBuffering
276 -- initial context is just the Prelude
277 prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude")
279 GHC.setContext session [] [prel_mod]
283 Readline.setAttemptedCompletionFunction (Just completeWord)
284 --Readline.parseAndBind "set show-all-if-ambiguous 1"
286 let symbols = "!#$%&*+/<=>?@\\^|-~"
287 specials = "(),;[]`{}"
289 word_break_chars = spaces ++ specials ++ symbols
291 Readline.setBasicWordBreakCharacters word_break_chars
292 Readline.setCompleterWordBreakCharacters word_break_chars
295 default_editor <- findEditor
297 startGHCi (runGHCi srcs maybe_expr)
298 GHCiState{ progname = "<interactive>",
302 editor = default_editor,
308 tickarrays = emptyModuleEnv,
313 Readline.resetTerminal Nothing
318 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
319 runGHCi paths maybe_expr = do
320 let read_dot_files = not opt_IgnoreDotGhci
322 when (read_dot_files) $ do
325 exists <- io (doesFileExist file)
327 dir_ok <- io (checkPerms ".")
328 file_ok <- io (checkPerms file)
329 when (dir_ok && file_ok) $ do
330 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
333 Right hdl -> fileLoop hdl False
335 when (read_dot_files) $ do
336 -- Read in $HOME/.ghci
337 either_dir <- io (IO.try getHomeDirectory)
341 cwd <- io (getCurrentDirectory)
342 when (dir /= cwd) $ do
343 let file = dir ++ "/.ghci"
344 ok <- io (checkPerms file)
346 either_hdl <- io (IO.try (openFile file ReadMode))
349 Right hdl -> fileLoop hdl False
351 -- Perform a :load for files given on the GHCi command line
352 -- When in -e mode, if the load fails then we want to stop
353 -- immediately rather than going on to evaluate the expression.
354 when (not (null paths)) $ do
355 ok <- ghciHandle (\e -> do showException e; return Failed) $
357 when (isJust maybe_expr && failed ok) $
358 io (exitWith (ExitFailure 1))
360 -- if verbosity is greater than 0, or we are connected to a
361 -- terminal, display the prompt in the interactive loop.
362 is_tty <- io (hIsTerminalDevice stdin)
363 dflags <- getDynFlags
364 let show_prompt = verbosity dflags > 0 || is_tty
369 #if defined(mingw32_HOST_OS)
370 -- The win32 Console API mutates the first character of
371 -- type-ahead when reading from it in a non-buffered manner. Work
372 -- around this by flushing the input buffer of type-ahead characters,
373 -- but only if stdin is available.
374 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
376 Left err | isDoesNotExistError err -> return ()
377 | otherwise -> io (ioError err)
378 Right () -> return ()
380 -- initialise the console if necessary
383 -- enter the interactive loop
384 interactiveLoop is_tty show_prompt
386 -- just evaluate the expression we were given
391 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
394 interactiveLoop :: Bool -> Bool -> GHCi ()
395 interactiveLoop is_tty show_prompt =
396 -- Ignore ^C exceptions caught here
397 ghciHandleDyn (\e -> case e of
399 #if defined(mingw32_HOST_OS)
402 interactiveLoop is_tty show_prompt
403 _other -> return ()) $
405 ghciUnblock $ do -- unblock necessary if we recursed from the
406 -- exception handler above.
408 -- read commands from stdin
412 else fileLoop stdin show_prompt
414 fileLoop stdin show_prompt
418 -- NOTE: We only read .ghci files if they are owned by the current user,
419 -- and aren't world writable. Otherwise, we could be accidentally
420 -- running code planted by a malicious third party.
422 -- Furthermore, We only read ./.ghci if . is owned by the current user
423 -- and isn't writable by anyone else. I think this is sufficient: we
424 -- don't need to check .. and ../.. etc. because "." always refers to
425 -- the same directory while a process is running.
427 checkPerms :: String -> IO Bool
428 #ifdef mingw32_HOST_OS
433 Util.handle (\_ -> return False) $ do
434 st <- getFileStatus name
436 if fileOwner st /= me then do
437 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
440 let mode = fileMode st
441 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
442 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
444 putStrLn $ "*** WARNING: " ++ name ++
445 " is writable by someone else, IGNORING!"
450 fileLoop :: Handle -> Bool -> GHCi ()
451 fileLoop hdl show_prompt = do
452 when show_prompt $ do
455 l <- io (IO.try (hGetLine hdl))
457 Left e | isEOFError e -> return ()
458 | InvalidArgument <- etype -> return ()
459 | otherwise -> io (ioError e)
460 where etype = ioeGetErrorType e
461 -- treat InvalidArgument in the same way as EOF:
462 -- this can happen if the user closed stdin, or
463 -- perhaps did getContents which closes stdin at
466 case removeSpaces l of
467 "" -> fileLoop hdl show_prompt
468 l -> do quit <- runCommands l
469 if quit then return () else fileLoop hdl show_prompt
471 mkPrompt :: GHCi String
473 session <- getSession
474 (toplevs,exports) <- io (GHC.getContext session)
475 resumes <- io $ GHC.getResumeContext session
481 let ix = GHC.resumeHistoryIx r
483 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
485 let hist = GHC.resumeHistory r !! (ix-1)
486 span <- io$ GHC.getHistorySpan session hist
487 return (brackets (ppr (negate ix) <> char ':'
488 <+> ppr span) <> space)
490 dots | _:rs <- resumes, not (null rs) = text "... "
494 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
495 hsep (map (ppr . GHC.moduleName) exports)
497 deflt_prompt = dots <> context_bit <> modules_bit
499 f ('%':'s':xs) = deflt_prompt <> f xs
500 f ('%':'%':xs) = char '%' <> f xs
501 f (x:xs) = char x <> f xs
505 return (showSDoc (f (prompt st)))
509 readlineLoop :: GHCi ()
512 saveSession -- for use by completion
514 l <- io (readline prompt `finally` setNonBlockingFD 0)
515 -- readline sometimes puts stdin into blocking mode,
516 -- so we need to put it back for the IO library
521 case removeSpaces l of
525 quit <- runCommands l
526 if quit then return () else readlineLoop
529 runCommands :: String -> GHCi Bool
531 q <- ghciHandle handler (doCommand cmd)
532 if q then return True else runNext
538 c:cs -> do setGHCiState st{ cmdqueue = cs }
541 doCommand (':' : cmd) = specialCommand cmd
542 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
545 enqueueCommands :: [String] -> GHCi ()
546 enqueueCommands cmds = do
548 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
551 -- This version is for the GHC command-line option -e. The only difference
552 -- from runCommand is that it catches the ExitException exception and
553 -- exits, rather than printing out the exception.
554 runCommandEval :: String -> GHCi Bool
555 runCommandEval c = ghciHandle handleEval (doCommand c)
557 handleEval (ExitException code) = io (exitWith code)
558 handleEval e = do handler e
559 io (exitWith (ExitFailure 1))
561 doCommand (':' : command) = specialCommand command
563 = do r <- runStmt stmt GHC.RunToCompletion
565 False -> io (exitWith (ExitFailure 1))
566 -- failure to run the command causes exit(1) for ghc -e.
569 runStmt :: String -> SingleStep -> GHCi Bool
571 | null (filter (not.isSpace) stmt) = return False
572 | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
574 = do st <- getGHCiState
575 session <- getSession
576 result <- io $ withProgName (progname st) $ withArgs (args st) $
577 GHC.runStmt session stmt step
578 afterRunStmt (const True) result
581 --afterRunStmt :: GHC.RunResult -> GHCi Bool
582 -- False <=> the statement failed to compile
583 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
584 afterRunStmt _ (GHC.RunException e) = throw e
585 afterRunStmt step_here run_result = do
586 session <- getSession
587 resumes <- io $ GHC.getResumeContext session
589 GHC.RunOk names -> do
590 show_types <- isOptionSet ShowType
591 when show_types $ printTypeOfNames session names
592 GHC.RunBreak _ names mb_info
593 | isNothing mb_info ||
594 step_here (GHC.resumeSpan $ head resumes) -> do
595 printForUser $ ptext SLIT("Stopped at") <+>
596 ppr (GHC.resumeSpan $ head resumes)
597 -- printTypeOfNames session names
598 printTypeAndContentOfNames session names
599 maybe (return ()) runBreakCmd mb_info
600 -- run the command set with ":set stop <cmd>"
602 enqueueCommands [stop st]
604 | otherwise -> io(GHC.resume session GHC.SingleStep) >>=
605 afterRunStmt step_here >> return ()
609 io installSignalHandlers
610 b <- isOptionSet RevertCAFs
611 io (when b revertCAFs)
613 return (case run_result of GHC.RunOk _ -> True; _ -> False)
615 where printTypeAndContentOfNames session names = do
616 let namesSorted = sortBy compareNames names
617 tythings <- catMaybes `liftM`
618 io (mapM (GHC.lookupName session) namesSorted)
619 let ids = [id | AnId id <- tythings]
620 terms <- mapM (io . GHC.obtainTermB session 10 False) ids
621 docs_terms <- mapM (io . showTerm session) terms
622 dflags <- getDynFlags
623 let pefas = dopt Opt_PrintExplicitForalls dflags
624 printForUser $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts)
625 (map (pprTyThing pefas . AnId) ids)
628 runBreakCmd :: GHC.BreakInfo -> GHCi ()
629 runBreakCmd info = do
630 let mod = GHC.breakInfo_module info
631 nm = GHC.breakInfo_number info
633 case [ loc | (_,loc) <- breaks st,
634 breakModule loc == mod, breakTick loc == nm ] of
636 loc:_ | null cmd -> return ()
637 | otherwise -> do enqueueCommands [cmd]; return ()
638 where cmd = onBreakCmd loc
640 printTypeOfNames :: Session -> [Name] -> GHCi ()
641 printTypeOfNames session names
642 = mapM_ (printTypeOfName session) $ sortBy compareNames names
644 compareNames :: Name -> Name -> Ordering
645 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
646 where compareWith n = (getOccString n, getSrcSpan n)
648 printTypeOfName :: Session -> Name -> GHCi ()
649 printTypeOfName session n
650 = do maybe_tything <- io (GHC.lookupName session n)
651 case maybe_tything of
653 Just thing -> printTyThing thing
655 specialCommand :: String -> GHCi Bool
656 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
657 specialCommand str = do
658 let (cmd,rest) = break isSpace str
659 maybe_cmd <- io (lookupCommand cmd)
661 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
662 ++ shortHelpText) >> return False)
663 Just (_,f,_,_) -> f (dropWhile isSpace rest)
665 lookupCommand :: String -> IO (Maybe Command)
666 lookupCommand str = do
667 cmds <- readIORef commands
668 -- look for exact match first, then the first prefix match
669 case [ c | c <- cmds, str == cmdName c ] of
670 c:_ -> return (Just c)
671 [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
673 c:_ -> return (Just c)
676 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
677 getCurrentBreakSpan = do
678 session <- getSession
679 resumes <- io $ GHC.getResumeContext session
683 let ix = GHC.resumeHistoryIx r
685 then return (Just (GHC.resumeSpan r))
687 let hist = GHC.resumeHistory r !! (ix-1)
688 span <- io $ GHC.getHistorySpan session hist
691 getCurrentBreakModule :: GHCi (Maybe Module)
692 getCurrentBreakModule = do
693 session <- getSession
694 resumes <- io $ GHC.getResumeContext session
698 let ix = GHC.resumeHistoryIx r
700 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
702 let hist = GHC.resumeHistory r !! (ix-1)
703 return $ Just $ GHC.getHistoryModule hist
705 -----------------------------------------------------------------------------
708 noArgs :: GHCi () -> String -> GHCi ()
710 noArgs _ _ = io $ putStrLn "This command takes no arguments"
712 help :: String -> GHCi ()
713 help _ = io (putStr helpText)
715 info :: String -> GHCi ()
716 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
717 info s = do { let names = words s
718 ; session <- getSession
719 ; dflags <- getDynFlags
720 ; let pefas = dopt Opt_PrintExplicitForalls dflags
721 ; mapM_ (infoThing pefas session) names }
723 infoThing pefas session str = io $ do
724 names <- GHC.parseName session str
725 mb_stuffs <- mapM (GHC.getInfo session) names
726 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
727 unqual <- GHC.getPrintUnqual session
728 putStrLn (showSDocForUser unqual $
729 vcat (intersperse (text "") $
730 map (pprInfo pefas) filtered))
732 -- Filter out names whose parent is also there Good
733 -- example is '[]', which is both a type and data
734 -- constructor in the same type
735 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
736 filterOutChildren get_thing xs
737 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
739 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
741 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
742 pprInfo pefas (thing, fixity, insts)
743 = pprTyThingInContextLoc pefas thing
744 $$ show_fixity fixity
745 $$ vcat (map GHC.pprInstance insts)
748 | fix == GHC.defaultFixity = empty
749 | otherwise = ppr fix <+> ppr (GHC.getName thing)
751 runMain :: String -> GHCi ()
753 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
754 enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
756 addModule :: [FilePath] -> GHCi ()
758 io (revertCAFs) -- always revert CAFs on load/add.
759 files <- mapM expandPath files
760 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
761 session <- getSession
762 io (mapM_ (GHC.addTarget session) targets)
763 ok <- io (GHC.load session LoadAllTargets)
766 changeDirectory :: String -> GHCi ()
767 changeDirectory dir = do
768 session <- getSession
769 graph <- io (GHC.getModuleGraph session)
770 when (not (null graph)) $
771 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
772 io (GHC.setTargets session [])
773 io (GHC.load session LoadAllTargets)
774 setContextAfterLoad session []
775 io (GHC.workingDirectoryChanged session)
776 dir <- expandPath dir
777 io (setCurrentDirectory dir)
779 editFile :: String -> GHCi ()
781 do file <- if null str then chooseEditFile else return str
785 $ throwDyn (CmdLineError "editor not set, use :set editor")
786 io $ system (cmd ++ ' ':file)
789 -- The user didn't specify a file so we pick one for them.
790 -- Our strategy is to pick the first module that failed to load,
791 -- or otherwise the first target.
793 -- XXX: Can we figure out what happened if the depndecy analysis fails
794 -- (e.g., because the porgrammeer mistyped the name of a module)?
795 -- XXX: Can we figure out the location of an error to pass to the editor?
796 -- XXX: if we could figure out the list of errors that occured during the
797 -- last load/reaload, then we could start the editor focused on the first
799 chooseEditFile :: GHCi String
801 do session <- getSession
802 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
804 graph <- io (GHC.getModuleGraph session)
805 failed_graph <- filterM hasFailed graph
806 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
808 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
811 case pick (order failed_graph) of
812 Just file -> return file
814 do targets <- io (GHC.getTargets session)
815 case msum (map fromTarget targets) of
816 Just file -> return file
817 Nothing -> throwDyn (CmdLineError "No files to edit.")
819 where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
820 fromTarget _ = Nothing -- when would we get a module target?
822 defineMacro :: String -> GHCi ()
824 let (macro_name, definition) = break isSpace s
825 cmds <- io (readIORef commands)
827 then throwDyn (CmdLineError "invalid macro name")
829 if (macro_name `elem` map cmdName cmds)
830 then throwDyn (CmdLineError
831 ("command '" ++ macro_name ++ "' is already defined"))
834 -- give the expression a type signature, so we can be sure we're getting
835 -- something of the right type.
836 let new_expr = '(' : definition ++ ") :: String -> IO String"
838 -- compile the expression
840 maybe_hv <- io (GHC.compileExpr cms new_expr)
843 Just hv -> io (writeIORef commands --
844 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
846 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
848 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
849 enqueueCommands (lines str)
852 undefineMacro :: String -> GHCi ()
853 undefineMacro macro_name = do
854 cmds <- io (readIORef commands)
855 if (macro_name `elem` map cmdName builtin_commands)
856 then throwDyn (CmdLineError
857 ("command '" ++ macro_name ++ "' cannot be undefined"))
859 if (macro_name `notElem` map cmdName cmds)
860 then throwDyn (CmdLineError
861 ("command '" ++ macro_name ++ "' not defined"))
863 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
865 cmdCmd :: String -> GHCi ()
867 let expr = '(' : str ++ ") :: IO String"
868 session <- getSession
869 maybe_hv <- io (GHC.compileExpr session expr)
873 cmds <- io $ (unsafeCoerce# hv :: IO String)
874 enqueueCommands (lines cmds)
877 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
878 loadModule fs = timeIt (loadModule' fs)
880 loadModule_ :: [FilePath] -> GHCi ()
881 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
883 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
884 loadModule' files = do
885 session <- getSession
888 discardActiveBreakPoints
889 io (GHC.setTargets session [])
890 io (GHC.load session LoadAllTargets)
893 let (filenames, phases) = unzip files
894 exp_filenames <- mapM expandPath filenames
895 let files' = zip exp_filenames phases
896 targets <- io (mapM (uncurry GHC.guessTarget) files')
898 -- NOTE: we used to do the dependency anal first, so that if it
899 -- fails we didn't throw away the current set of modules. This would
900 -- require some re-working of the GHC interface, so we'll leave it
901 -- as a ToDo for now.
903 io (GHC.setTargets session targets)
904 doLoad session LoadAllTargets
906 checkModule :: String -> GHCi ()
908 let modl = GHC.mkModuleName m
909 session <- getSession
910 result <- io (GHC.checkModule session modl False)
912 Nothing -> io $ putStrLn "Nothing"
913 Just r -> io $ putStrLn (showSDoc (
914 case GHC.checkedModuleInfo r of
915 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
917 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
919 (text "global names: " <+> ppr global) $$
920 (text "local names: " <+> ppr local)
922 afterLoad (successIf (isJust result)) session
924 reloadModule :: String -> GHCi ()
926 session <- getSession
927 doLoad session $ if null m then LoadAllTargets
928 else LoadUpTo (GHC.mkModuleName m)
931 doLoad :: Session -> LoadHowMuch -> GHCi SuccessFlag
932 doLoad session howmuch = do
933 -- turn off breakpoints before we load: we can't turn them off later, because
934 -- the ModBreaks will have gone away.
935 discardActiveBreakPoints
936 ok <- io (GHC.load session howmuch)
940 afterLoad :: SuccessFlag -> Session -> GHCi ()
941 afterLoad ok session = do
942 io (revertCAFs) -- always revert CAFs on load.
944 loaded_mods <- getLoadedModules session
945 setContextAfterLoad session loaded_mods
946 modulesLoadedMsg ok (map GHC.ms_mod_name loaded_mods)
948 setContextAfterLoad :: Session -> [GHC.ModSummary] -> GHCi ()
949 setContextAfterLoad session [] = do
950 prel_mod <- getPrelude
951 io (GHC.setContext session [] [prel_mod])
952 setContextAfterLoad session ms = do
953 -- load a target if one is available, otherwise load the topmost module.
954 targets <- io (GHC.getTargets session)
955 case [ m | Just m <- map (findTarget ms) targets ] of
957 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
958 load_this (last graph')
963 = case filter (`matches` t) ms of
967 summary `matches` Target (TargetModule m) _
968 = GHC.ms_mod_name summary == m
969 summary `matches` Target (TargetFile f _) _
970 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
974 load_this summary | m <- GHC.ms_mod summary = do
975 b <- io (GHC.moduleIsInterpreted session m)
976 if b then io (GHC.setContext session [m] [])
978 prel_mod <- getPrelude
979 io (GHC.setContext session [] [prel_mod,m])
982 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
983 modulesLoadedMsg ok mods = do
984 dflags <- getDynFlags
985 when (verbosity dflags > 0) $ do
987 | null mods = text "none."
989 punctuate comma (map ppr mods)) <> text "."
992 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
994 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
997 typeOfExpr :: String -> GHCi ()
999 = do cms <- getSession
1000 maybe_ty <- io (GHC.exprType cms str)
1002 Nothing -> return ()
1003 Just ty -> do dflags <- getDynFlags
1004 let pefas = dopt Opt_PrintExplicitForalls dflags
1005 printForUser $ text str <+> dcolon
1006 <+> pprTypeForUser pefas ty
1008 kindOfType :: String -> GHCi ()
1010 = do cms <- getSession
1011 maybe_ty <- io (GHC.typeKind cms str)
1013 Nothing -> return ()
1014 Just ty -> printForUser $ text str <+> dcolon <+> ppr ty
1016 quit :: String -> GHCi Bool
1017 quit _ = return True
1019 shellEscape :: String -> GHCi Bool
1020 shellEscape str = io (system str >> return False)
1022 -----------------------------------------------------------------------------
1023 -- Browsing a module's contents
1025 browseCmd :: String -> GHCi ()
1028 ['*':s] | looksLikeModuleName s -> do
1029 m <- wantInterpretedModule s
1030 browseModule m False
1031 [s] | looksLikeModuleName s -> do
1036 (as,bs) <- io $ GHC.getContext s
1037 -- Guess which module the user wants to browse. Pick
1038 -- modules that are interpreted first. The most
1039 -- recently-added module occurs last, it seems.
1041 (as@(_:_), _) -> browseModule (last as) True
1042 ([], bs@(_:_)) -> browseModule (last bs) True
1043 ([], []) -> throwDyn (CmdLineError ":browse: no current module")
1044 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1046 browseModule :: Module -> Bool -> GHCi ()
1047 browseModule modl exports_only = do
1049 -- Temporarily set the context to the module we're interested in,
1050 -- just so we can get an appropriate PrintUnqualified
1051 (as,bs) <- io (GHC.getContext s)
1052 prel_mod <- getPrelude
1053 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1054 else GHC.setContext s [modl] [])
1055 unqual <- io (GHC.getPrintUnqual s)
1056 io (GHC.setContext s as bs)
1058 mb_mod_info <- io $ GHC.getModuleInfo s modl
1060 Nothing -> throwDyn (CmdLineError ("unknown module: " ++
1061 GHC.moduleNameString (GHC.moduleName modl)))
1064 | exports_only = GHC.modInfoExports mod_info
1065 | otherwise = GHC.modInfoTopLevelScope mod_info
1068 mb_things <- io $ mapM (GHC.lookupName s) names
1069 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1071 dflags <- getDynFlags
1072 let pefas = dopt Opt_PrintExplicitForalls dflags
1073 io (putStrLn (showSDocForUser unqual (
1074 vcat (map (pprTyThingInContext pefas) filtered_things)
1076 -- ToDo: modInfoInstances currently throws an exception for
1077 -- package modules. When it works, we can do this:
1078 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1080 -----------------------------------------------------------------------------
1081 -- Setting the module context
1083 setContext :: String -> GHCi ()
1085 | all sensible mods = fn mods
1086 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1088 (fn, mods) = case str of
1089 '+':stuff -> (addToContext, words stuff)
1090 '-':stuff -> (removeFromContext, words stuff)
1091 stuff -> (newContext, words stuff)
1093 sensible ('*':m) = looksLikeModuleName m
1094 sensible m = looksLikeModuleName m
1096 separate :: Session -> [String] -> [Module] -> [Module]
1097 -> GHCi ([Module],[Module])
1098 separate _ [] as bs = return (as,bs)
1099 separate session (('*':str):ms) as bs = do
1100 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1101 b <- io $ GHC.moduleIsInterpreted session m
1102 if b then separate session ms (m:as) bs
1103 else throwDyn (CmdLineError ("module '"
1104 ++ GHC.moduleNameString (GHC.moduleName m)
1105 ++ "' is not interpreted"))
1106 separate session (str:ms) as bs = do
1107 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1108 separate session ms as (m:bs)
1110 newContext :: [String] -> GHCi ()
1111 newContext strs = do
1113 (as,bs) <- separate s strs [] []
1114 prel_mod <- getPrelude
1115 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1116 io $ GHC.setContext s as bs'
1119 addToContext :: [String] -> GHCi ()
1120 addToContext strs = do
1122 (as,bs) <- io $ GHC.getContext s
1124 (new_as,new_bs) <- separate s strs [] []
1126 let as_to_add = new_as \\ (as ++ bs)
1127 bs_to_add = new_bs \\ (as ++ bs)
1129 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1132 removeFromContext :: [String] -> GHCi ()
1133 removeFromContext strs = do
1135 (as,bs) <- io $ GHC.getContext s
1137 (as_to_remove,bs_to_remove) <- separate s strs [] []
1139 let as' = as \\ (as_to_remove ++ bs_to_remove)
1140 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1142 io $ GHC.setContext s as' bs'
1144 ----------------------------------------------------------------------------
1147 -- set options in the interpreter. Syntax is exactly the same as the
1148 -- ghc command line, except that certain options aren't available (-C,
1151 -- This is pretty fragile: most options won't work as expected. ToDo:
1152 -- figure out which ones & disallow them.
1154 setCmd :: String -> GHCi ()
1156 = do st <- getGHCiState
1157 let opts = options st
1158 io $ putStrLn (showSDoc (
1159 text "options currently set: " <>
1162 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1165 = case toArgs str of
1166 ("args":args) -> setArgs args
1167 ("prog":prog) -> setProg prog
1168 ("prompt":_) -> setPrompt (after 6)
1169 ("editor":_) -> setEditor (after 6)
1170 ("stop":_) -> setStop (after 4)
1171 wds -> setOptions wds
1172 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1174 setArgs, setProg, setOptions :: [String] -> GHCi ()
1175 setEditor, setStop, setPrompt :: String -> GHCi ()
1179 setGHCiState st{ args = args }
1183 setGHCiState st{ progname = prog }
1185 io (hPutStrLn stderr "syntax: :set prog <progname>")
1189 setGHCiState st{ editor = cmd }
1191 setStop str@(c:_) | isDigit c
1192 = do let (nm_str,rest) = break (not.isDigit) str
1195 let old_breaks = breaks st
1196 if all ((/= nm) . fst) old_breaks
1197 then printForUser (text "Breakpoint" <+> ppr nm <+>
1198 text "does not exist")
1200 let new_breaks = map fn old_breaks
1201 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1202 | otherwise = (i,loc)
1203 setGHCiState st{ breaks = new_breaks }
1206 setGHCiState st{ stop = cmd }
1208 setPrompt value = do
1211 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1212 else setGHCiState st{ prompt = remQuotes value }
1214 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1218 do -- first, deal with the GHCi opts (+s, +t, etc.)
1219 let (plus_opts, minus_opts) = partitionWith isPlus wds
1220 mapM_ setOpt plus_opts
1221 -- then, dynamic flags
1222 newDynFlags minus_opts
1224 newDynFlags :: [String] -> GHCi ()
1225 newDynFlags minus_opts = do
1226 dflags <- getDynFlags
1227 let pkg_flags = packageFlags dflags
1228 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1230 if (not (null leftovers))
1231 then throwDyn (CmdLineError ("unrecognised flags: " ++
1235 new_pkgs <- setDynFlags dflags'
1237 -- if the package flags changed, we should reset the context
1238 -- and link the new packages.
1239 dflags <- getDynFlags
1240 when (packageFlags dflags /= pkg_flags) $ do
1241 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1242 session <- getSession
1243 io (GHC.setTargets session [])
1244 io (GHC.load session LoadAllTargets)
1245 io (linkPackages dflags new_pkgs)
1246 setContextAfterLoad session []
1250 unsetOptions :: String -> GHCi ()
1252 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1253 let opts = words str
1254 (minus_opts, rest1) = partition isMinus opts
1255 (plus_opts, rest2) = partitionWith isPlus rest1
1257 if (not (null rest2))
1258 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1261 mapM_ unsetOpt plus_opts
1263 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1264 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1266 no_flags <- mapM no_flag minus_opts
1267 newDynFlags no_flags
1269 isMinus :: String -> Bool
1270 isMinus ('-':_) = True
1273 isPlus :: String -> Either String String
1274 isPlus ('+':opt) = Left opt
1275 isPlus other = Right other
1277 setOpt, unsetOpt :: String -> GHCi ()
1280 = case strToGHCiOpt str of
1281 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1282 Just o -> setOption o
1285 = case strToGHCiOpt str of
1286 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1287 Just o -> unsetOption o
1289 strToGHCiOpt :: String -> (Maybe GHCiOption)
1290 strToGHCiOpt "s" = Just ShowTiming
1291 strToGHCiOpt "t" = Just ShowType
1292 strToGHCiOpt "r" = Just RevertCAFs
1293 strToGHCiOpt _ = Nothing
1295 optToStr :: GHCiOption -> String
1296 optToStr ShowTiming = "s"
1297 optToStr ShowType = "t"
1298 optToStr RevertCAFs = "r"
1300 -- ---------------------------------------------------------------------------
1303 showCmd :: String -> GHCi ()
1307 ["args"] -> io $ putStrLn (show (args st))
1308 ["prog"] -> io $ putStrLn (show (progname st))
1309 ["prompt"] -> io $ putStrLn (show (prompt st))
1310 ["editor"] -> io $ putStrLn (show (editor st))
1311 ["stop"] -> io $ putStrLn (show (stop st))
1312 ["modules" ] -> showModules
1313 ["bindings"] -> showBindings
1314 ["linker"] -> io showLinkerState
1315 ["breaks"] -> showBkptTable
1316 ["context"] -> showContext
1317 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1319 showModules :: GHCi ()
1321 session <- getSession
1322 loaded_mods <- getLoadedModules session
1323 -- we want *loaded* modules only, see #1734
1324 let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m)
1325 mapM_ show_one loaded_mods
1327 getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary]
1328 getLoadedModules session = do
1329 graph <- io (GHC.getModuleGraph session)
1330 filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
1332 showBindings :: GHCi ()
1335 bindings <- io (GHC.getBindings s)
1336 mapM_ printTyThing $ sortBy compareTyThings bindings
1339 compareTyThings :: TyThing -> TyThing -> Ordering
1340 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1342 printTyThing :: TyThing -> GHCi ()
1343 printTyThing tyth = do dflags <- getDynFlags
1344 let pefas = dopt Opt_PrintExplicitForalls dflags
1345 printForUser (pprTyThing pefas tyth)
1347 showBkptTable :: GHCi ()
1350 printForUser $ prettyLocations (breaks st)
1352 showContext :: GHCi ()
1354 session <- getSession
1355 resumes <- io $ GHC.getResumeContext session
1356 printForUser $ vcat (map pp_resume (reverse resumes))
1359 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1360 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1363 -- -----------------------------------------------------------------------------
1366 completeNone :: String -> IO [String]
1367 completeNone _w = return []
1369 completeMacro, completeIdentifier, completeModule,
1370 completeHomeModule, completeSetOptions, completeFilename,
1371 completeHomeModuleOrFile
1372 :: String -> IO [String]
1375 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1376 completeWord w start end = do
1377 line <- Readline.getLineBuffer
1378 let line_words = words (dropWhile isSpace line)
1380 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1382 | ((':':c) : _) <- line_words -> do
1383 maybe_cmd <- lookupCommand c
1384 let (n,w') = selectWord (words' 0 line)
1386 Nothing -> return Nothing
1387 Just (_,_,False,complete) -> wrapCompleter complete w
1388 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1389 return (map (drop n) rets)
1390 in wrapCompleter complete' w'
1391 | ("import" : _) <- line_words ->
1392 wrapCompleter completeModule w
1394 --printf "complete %s, start = %d, end = %d\n" w start end
1395 wrapCompleter completeIdentifier w
1396 where words' _ [] = []
1397 words' n str = let (w,r) = break isSpace str
1398 (s,r') = span isSpace r
1399 in (n,w):words' (n+length w+length s) r'
1400 -- In a Haskell expression we want to parse 'a-b' as three words
1401 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1402 -- only be a single word.
1403 selectWord [] = (0,w)
1404 selectWord ((offset,x):xs)
1405 | offset+length x >= start = (start-offset,take (end-offset) x)
1406 | otherwise = selectWord xs
1408 completeCmd :: String -> IO [String]
1410 cmds <- readIORef commands
1411 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1413 completeMacro w = do
1414 cmds <- readIORef commands
1415 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1416 return (filter (w `isPrefixOf`) cmds')
1418 completeIdentifier w = do
1420 rdrs <- GHC.getRdrNamesInScope s
1421 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1423 completeModule w = do
1425 dflags <- GHC.getSessionDynFlags s
1426 let pkg_mods = allExposedModules dflags
1427 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1429 completeHomeModule w = do
1431 g <- GHC.getModuleGraph s
1432 let home_mods = map GHC.ms_mod_name g
1433 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1435 completeSetOptions w = do
1436 return (filter (w `isPrefixOf`) options)
1437 where options = "args":"prog":allFlags
1439 completeFilename = Readline.filenameCompletionFunction
1441 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1443 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1444 unionComplete f1 f2 w = do
1449 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1450 wrapCompleter fun w = do
1453 [] -> return Nothing
1454 [x] -> return (Just (x,[]))
1455 xs -> case getCommonPrefix xs of
1456 "" -> return (Just ("",xs))
1457 pref -> return (Just (pref,xs))
1459 getCommonPrefix :: [String] -> String
1460 getCommonPrefix [] = ""
1461 getCommonPrefix (s:ss) = foldl common s ss
1462 where common _s "" = ""
1464 common (c:cs) (d:ds)
1465 | c == d = c : common cs ds
1468 allExposedModules :: DynFlags -> [ModuleName]
1469 allExposedModules dflags
1470 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1472 pkg_db = pkgIdMap (pkgState dflags)
1474 completeMacro = completeNone
1475 completeIdentifier = completeNone
1476 completeModule = completeNone
1477 completeHomeModule = completeNone
1478 completeSetOptions = completeNone
1479 completeFilename = completeNone
1480 completeHomeModuleOrFile=completeNone
1483 -- ---------------------------------------------------------------------------
1484 -- User code exception handling
1486 -- This is the exception handler for exceptions generated by the
1487 -- user's code and exceptions coming from children sessions;
1488 -- it normally just prints out the exception. The
1489 -- handler must be recursive, in case showing the exception causes
1490 -- more exceptions to be raised.
1492 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1493 -- raising another exception. We therefore don't put the recursive
1494 -- handler arond the flushing operation, so if stderr is closed
1495 -- GHCi will just die gracefully rather than going into an infinite loop.
1496 handler :: Exception -> GHCi Bool
1498 handler exception = do
1500 io installSignalHandlers
1501 ghciHandle handler (showException exception >> return False)
1503 showException :: Exception -> GHCi ()
1504 showException (DynException dyn) =
1505 case fromDynamic dyn of
1506 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1507 Just Interrupted -> io (putStrLn "Interrupted.")
1508 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1509 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1510 Just other_ghc_ex -> io (print other_ghc_ex)
1512 showException other_exception
1513 = io (putStrLn ("*** Exception: " ++ show other_exception))
1515 -----------------------------------------------------------------------------
1516 -- recursive exception handlers
1518 -- Don't forget to unblock async exceptions in the handler, or if we're
1519 -- in an exception loop (eg. let a = error a in a) the ^C exception
1520 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1522 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1523 ghciHandle h (GHCi m) = GHCi $ \s ->
1524 Exception.catch (m s)
1525 (\e -> unGHCi (ghciUnblock (h e)) s)
1527 ghciUnblock :: GHCi a -> GHCi a
1528 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1531 -- ----------------------------------------------------------------------------
1534 expandPath :: String -> GHCi String
1536 case dropWhile isSpace path of
1538 tilde <- io getHomeDirectory -- will fail if HOME not defined
1539 return (tilde ++ '/':d)
1543 wantInterpretedModule :: String -> GHCi Module
1544 wantInterpretedModule str = do
1545 session <- getSession
1546 modl <- lookupModule str
1547 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1548 when (not is_interpreted) $
1549 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1552 wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String
1553 -> (Name -> GHCi ())
1555 wantNameFromInterpretedModule noCanDo str and_then = do
1556 session <- getSession
1557 names <- io $ GHC.parseName session str
1561 let modl = GHC.nameModule n
1562 if not (GHC.isExternalName n)
1563 then noCanDo n $ ppr n <>
1564 text " is not defined in an interpreted module"
1566 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1567 if not is_interpreted
1568 then noCanDo n $ text "module " <> ppr modl <>
1569 text " is not interpreted"
1572 -- ----------------------------------------------------------------------------
1573 -- Windows console setup
1575 setUpConsole :: IO ()
1577 #ifdef mingw32_HOST_OS
1578 -- On Windows we need to set a known code page, otherwise the characters
1579 -- we read from the console will be be in some strange encoding, and
1580 -- similarly for characters we write to the console.
1582 -- At the moment, GHCi pretends all input is Latin-1. In the
1583 -- future we should support UTF-8, but for now we set the code
1584 -- pages to Latin-1. Doing it this way does lead to problems,
1585 -- however: see bug #1649.
1587 -- It seems you have to set the font in the console window to
1588 -- a Unicode font in order for output to work properly,
1589 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1590 -- (see MSDN for SetConsoleOutputCP()).
1592 -- This call has been known to hang on some machines, see bug #1483
1594 setConsoleCP 28591 -- ISO Latin-1
1595 setConsoleOutputCP 28591 -- ISO Latin-1
1599 -- -----------------------------------------------------------------------------
1600 -- commands for debugger
1602 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1603 sprintCmd = pprintCommand False False
1604 printCmd = pprintCommand True False
1605 forceCmd = pprintCommand False True
1607 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1608 pprintCommand bind force str = do
1609 session <- getSession
1610 io $ pprintClosureCommand session bind force str
1612 stepCmd :: String -> GHCi ()
1613 stepCmd [] = doContinue (const True) GHC.SingleStep
1614 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1616 stepLocalCmd :: String -> GHCi ()
1617 stepLocalCmd [] = do
1618 mb_span <- getCurrentBreakSpan
1620 Nothing -> stepCmd []
1622 Just mod <- getCurrentBreakModule
1623 current_toplevel_decl <- enclosingTickSpan mod loc
1624 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1626 stepLocalCmd expression = stepCmd expression
1628 stepModuleCmd :: String -> GHCi ()
1629 stepModuleCmd [] = do
1630 mb_span <- getCurrentBreakSpan
1632 Nothing -> stepCmd []
1634 Just span <- getCurrentBreakSpan
1635 let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
1636 doContinue f GHC.SingleStep
1638 stepModuleCmd expression = stepCmd expression
1640 -- | Returns the span of the largest tick containing the srcspan given
1641 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1642 enclosingTickSpan mod src = do
1643 ticks <- getTickArray mod
1644 let line = srcSpanStartLine src
1645 ASSERT (inRange (bounds ticks) line) do
1646 let enclosing_spans = [ span | (_,span) <- ticks ! line
1647 , srcSpanEnd span >= srcSpanEnd src]
1648 return . head . sortBy leftmost_largest $ enclosing_spans
1650 traceCmd :: String -> GHCi ()
1651 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1652 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1654 continueCmd :: String -> GHCi ()
1655 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1657 -- doContinue :: SingleStep -> GHCi ()
1658 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1659 doContinue pred step = do
1660 session <- getSession
1661 runResult <- io $ GHC.resume session step
1662 afterRunStmt pred runResult
1665 abandonCmd :: String -> GHCi ()
1666 abandonCmd = noArgs $ do
1668 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1669 when (not b) $ io $ putStrLn "There is no computation running."
1672 deleteCmd :: String -> GHCi ()
1673 deleteCmd argLine = do
1674 deleteSwitch $ words argLine
1676 deleteSwitch :: [String] -> GHCi ()
1678 io $ putStrLn "The delete command requires at least one argument."
1679 -- delete all break points
1680 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1681 deleteSwitch idents = do
1682 mapM_ deleteOneBreak idents
1684 deleteOneBreak :: String -> GHCi ()
1686 | all isDigit str = deleteBreak (read str)
1687 | otherwise = return ()
1689 historyCmd :: String -> GHCi ()
1691 | null arg = history 20
1692 | all isDigit arg = history (read arg)
1693 | otherwise = io $ putStrLn "Syntax: :history [num]"
1697 resumes <- io $ GHC.getResumeContext s
1699 [] -> io $ putStrLn "Not stopped at a breakpoint"
1701 let hist = GHC.resumeHistory r
1702 (took,rest) = splitAt num hist
1703 spans <- mapM (io . GHC.getHistorySpan s) took
1704 let nums = map (printf "-%-3d:") [(1::Int)..]
1705 let names = map GHC.historyEnclosingDecl took
1706 printForUser (vcat(zipWith3
1707 (\x y z -> x <+> y <+> z)
1709 (map (bold . ppr) names)
1710 (map (parens . ppr) spans)))
1711 io $ putStrLn $ if null rest then "<end of history>" else "..."
1713 bold :: SDoc -> SDoc
1714 bold c | do_bold = text start_bold <> c <> text end_bold
1717 backCmd :: String -> GHCi ()
1718 backCmd = noArgs $ do
1720 (names, _, span) <- io $ GHC.back s
1721 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1722 printTypeOfNames s names
1723 -- run the command set with ":set stop <cmd>"
1725 enqueueCommands [stop st]
1727 forwardCmd :: String -> GHCi ()
1728 forwardCmd = noArgs $ do
1730 (names, ix, span) <- io $ GHC.forward s
1731 printForUser $ (if (ix == 0)
1732 then ptext SLIT("Stopped at")
1733 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1734 printTypeOfNames s names
1735 -- run the command set with ":set stop <cmd>"
1737 enqueueCommands [stop st]
1739 -- handle the "break" command
1740 breakCmd :: String -> GHCi ()
1741 breakCmd argLine = do
1742 session <- getSession
1743 breakSwitch session $ words argLine
1745 breakSwitch :: Session -> [String] -> GHCi ()
1746 breakSwitch _session [] = do
1747 io $ putStrLn "The break command requires at least one argument."
1748 breakSwitch session (arg1:rest)
1749 | looksLikeModuleName arg1 = do
1750 mod <- wantInterpretedModule arg1
1751 breakByModule mod rest
1752 | all isDigit arg1 = do
1753 (toplevel, _) <- io $ GHC.getContext session
1755 (mod : _) -> breakByModuleLine mod (read arg1) rest
1757 io $ putStrLn "Cannot find default module for breakpoint."
1758 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1759 | otherwise = do -- try parsing it as an identifier
1760 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1761 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1762 if GHC.isGoodSrcLoc loc
1763 then findBreakAndSet (GHC.nameModule name) $
1764 findBreakByCoord (Just (GHC.srcLocFile loc))
1765 (GHC.srcLocLine loc,
1767 else noCanDo name $ text "can't find its location: " <> ppr loc
1769 noCanDo n why = printForUser $
1770 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1772 breakByModule :: Module -> [String] -> GHCi ()
1773 breakByModule mod (arg1:rest)
1774 | all isDigit arg1 = do -- looks like a line number
1775 breakByModuleLine mod (read arg1) rest
1779 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1780 breakByModuleLine mod line args
1781 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1782 | [col] <- args, all isDigit col =
1783 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1784 | otherwise = breakSyntax
1787 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1789 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1790 findBreakAndSet mod lookupTickTree = do
1791 tickArray <- getTickArray mod
1792 (breakArray, _) <- getModBreak mod
1793 case lookupTickTree tickArray of
1794 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1795 Just (tick, span) -> do
1796 success <- io $ setBreakFlag True breakArray tick
1800 recordBreak $ BreakLocation
1807 text "Breakpoint " <> ppr nm <>
1809 then text " was already set at " <> ppr span
1810 else text " activated at " <> ppr span
1812 printForUser $ text "Breakpoint could not be activated at"
1815 -- When a line number is specified, the current policy for choosing
1816 -- the best breakpoint is this:
1817 -- - the leftmost complete subexpression on the specified line, or
1818 -- - the leftmost subexpression starting on the specified line, or
1819 -- - the rightmost subexpression enclosing the specified line
1821 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1822 findBreakByLine line arr
1823 | not (inRange (bounds arr) line) = Nothing
1825 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
1826 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
1827 listToMaybe (sortBy (rightmost `on` snd) ticks)
1831 starts_here = [ tick | tick@(_,span) <- ticks,
1832 GHC.srcSpanStartLine span == line ]
1834 (complete,incomplete) = partition ends_here starts_here
1835 where ends_here (_,span) = GHC.srcSpanEndLine span == line
1837 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1838 -> Maybe (BreakIndex,SrcSpan)
1839 findBreakByCoord mb_file (line, col) arr
1840 | not (inRange (bounds arr) line) = Nothing
1842 listToMaybe (sortBy (rightmost `on` snd) contains ++
1843 sortBy (leftmost_smallest `on` snd) after_here)
1847 -- the ticks that span this coordinate
1848 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
1849 is_correct_file span ]
1851 is_correct_file span
1852 | Just f <- mb_file = GHC.srcSpanFile span == f
1855 after_here = [ tick | tick@(_,span) <- ticks,
1856 GHC.srcSpanStartLine span == line,
1857 GHC.srcSpanStartCol span >= col ]
1859 -- For now, use ANSI bold on terminals that we know support it.
1860 -- Otherwise, we add a line of carets under the active expression instead.
1861 -- In particular, on Windows and when running the testsuite (which sets
1862 -- TERM to vt100 for other reasons) we get carets.
1863 -- We really ought to use a proper termcap/terminfo library.
1865 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
1866 where mTerm = System.Environment.getEnv "TERM"
1867 `Exception.catch` \_ -> return "TERM not set"
1869 start_bold :: String
1870 start_bold = "\ESC[1m"
1872 end_bold = "\ESC[0m"
1874 listCmd :: String -> GHCi ()
1876 mb_span <- getCurrentBreakSpan
1878 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1879 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1880 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
1881 listCmd str = list2 (words str)
1883 list2 :: [String] -> GHCi ()
1884 list2 [arg] | all isDigit arg = do
1885 session <- getSession
1886 (toplevel, _) <- io $ GHC.getContext session
1888 [] -> io $ putStrLn "No module to list"
1889 (mod : _) -> listModuleLine mod (read arg)
1890 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1891 mod <- wantInterpretedModule arg1
1892 listModuleLine mod (read arg2)
1894 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1895 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1896 if GHC.isGoodSrcLoc loc
1898 tickArray <- getTickArray (GHC.nameModule name)
1899 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1900 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1903 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1904 Just (_,span) -> io $ listAround span False
1906 noCanDo name $ text "can't find its location: " <>
1909 noCanDo n why = printForUser $
1910 text "cannot list source code for " <> ppr n <> text ": " <> why
1912 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1914 listModuleLine :: Module -> Int -> GHCi ()
1915 listModuleLine modl line = do
1916 session <- getSession
1917 graph <- io (GHC.getModuleGraph session)
1918 let this = filter ((== modl) . GHC.ms_mod) graph
1920 [] -> panic "listModuleLine"
1922 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1923 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1924 io $ listAround (GHC.srcLocSpan loc) False
1926 -- | list a section of a source file around a particular SrcSpan.
1927 -- If the highlight flag is True, also highlight the span using
1928 -- start_bold/end_bold.
1929 listAround :: SrcSpan -> Bool -> IO ()
1930 listAround span do_highlight = do
1931 contents <- BS.readFile (unpackFS file)
1933 lines = BS.split '\n' contents
1934 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1935 drop (line1 - 1 - pad_before) $ lines
1936 fst_line = max 1 (line1 - pad_before)
1937 line_nos = [ fst_line .. ]
1939 highlighted | do_highlight = zipWith highlight line_nos these_lines
1940 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
1942 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1943 prefixed = zipWith ($) highlighted bs_line_nos
1945 BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed)
1947 file = GHC.srcSpanFile span
1948 line1 = GHC.srcSpanStartLine span
1949 col1 = GHC.srcSpanStartCol span
1950 line2 = GHC.srcSpanEndLine span
1951 col2 = GHC.srcSpanEndCol span
1953 pad_before | line1 == 1 = 0
1957 highlight | do_bold = highlight_bold
1958 | otherwise = highlight_carets
1960 highlight_bold no line prefix
1961 | no == line1 && no == line2
1962 = let (a,r) = BS.splitAt col1 line
1963 (b,c) = BS.splitAt (col2-col1) r
1965 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
1967 = let (a,b) = BS.splitAt col1 line in
1968 BS.concat [prefix, a, BS.pack start_bold, b]
1970 = let (a,b) = BS.splitAt col2 line in
1971 BS.concat [prefix, a, BS.pack end_bold, b]
1972 | otherwise = BS.concat [prefix, line]
1974 highlight_carets no line prefix
1975 | no == line1 && no == line2
1976 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
1977 BS.replicate (col2-col1) '^']
1979 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
1982 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
1984 | otherwise = BS.concat [prefix, line]
1986 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
1987 nl = BS.singleton '\n'
1989 -- --------------------------------------------------------------------------
1992 getTickArray :: Module -> GHCi TickArray
1993 getTickArray modl = do
1995 let arrmap = tickarrays st
1996 case lookupModuleEnv arrmap modl of
1997 Just arr -> return arr
1999 (_breakArray, ticks) <- getModBreak modl
2000 let arr = mkTickArray (assocs ticks)
2001 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2004 discardTickArrays :: GHCi ()
2005 discardTickArrays = do
2007 setGHCiState st{tickarrays = emptyModuleEnv}
2009 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2011 = accumArray (flip (:)) [] (1, max_line)
2012 [ (line, (nm,span)) | (nm,span) <- ticks,
2013 line <- srcSpanLines span ]
2015 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2016 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2017 GHC.srcSpanEndLine span ]
2019 lookupModule :: String -> GHCi Module
2020 lookupModule modName
2021 = do session <- getSession
2022 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
2024 -- don't reset the counter back to zero?
2025 discardActiveBreakPoints :: GHCi ()
2026 discardActiveBreakPoints = do
2028 mapM (turnOffBreak.snd) (breaks st)
2029 setGHCiState $ st { breaks = [] }
2031 deleteBreak :: Int -> GHCi ()
2032 deleteBreak identity = do
2034 let oldLocations = breaks st
2035 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2037 then printForUser (text "Breakpoint" <+> ppr identity <+>
2038 text "does not exist")
2040 mapM (turnOffBreak.snd) this
2041 setGHCiState $ st { breaks = rest }
2043 turnOffBreak :: BreakLocation -> GHCi Bool
2044 turnOffBreak loc = do
2045 (arr, _) <- getModBreak (breakModule loc)
2046 io $ setBreakFlag False arr (breakTick loc)
2048 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2049 getModBreak mod = do
2050 session <- getSession
2051 Just mod_info <- io $ GHC.getModuleInfo session mod
2052 let modBreaks = GHC.modInfoModBreaks mod_info
2053 let array = GHC.modBreaks_flags modBreaks
2054 let ticks = GHC.modBreaks_locs modBreaks
2055 return (array, ticks)
2057 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2058 setBreakFlag toggle array index
2059 | toggle = GHC.setBreakOn array index
2060 | otherwise = GHC.setBreakOff array index