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 (getEnv "HOME"))
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
429 #ifdef mingw32_HOST_OS
432 Util.handle (\_ -> return False) $ do
433 st <- getFileStatus name
435 if fileOwner st /= me then do
436 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
439 let mode = fileMode st
440 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
441 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
443 putStrLn $ "*** WARNING: " ++ name ++
444 " is writable by someone else, IGNORING!"
449 fileLoop :: Handle -> Bool -> GHCi ()
450 fileLoop hdl show_prompt = do
451 when show_prompt $ do
454 l <- io (IO.try (hGetLine hdl))
456 Left e | isEOFError e -> return ()
457 | InvalidArgument <- etype -> return ()
458 | otherwise -> io (ioError e)
459 where etype = ioeGetErrorType e
460 -- treat InvalidArgument in the same way as EOF:
461 -- this can happen if the user closed stdin, or
462 -- perhaps did getContents which closes stdin at
465 case removeSpaces l of
466 "" -> fileLoop hdl show_prompt
467 l -> do quit <- runCommands l
468 if quit then return () else fileLoop hdl show_prompt
470 mkPrompt :: GHCi String
472 session <- getSession
473 (toplevs,exports) <- io (GHC.getContext session)
474 resumes <- io $ GHC.getResumeContext session
480 let ix = GHC.resumeHistoryIx r
482 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
484 let hist = GHC.resumeHistory r !! (ix-1)
485 span <- io$ GHC.getHistorySpan session hist
486 return (brackets (ppr (negate ix) <> char ':'
487 <+> ppr span) <> space)
489 dots | _:rs <- resumes, not (null rs) = text "... "
493 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
494 hsep (map (ppr . GHC.moduleName) exports)
496 deflt_prompt = dots <> context_bit <> modules_bit
498 f ('%':'s':xs) = deflt_prompt <> f xs
499 f ('%':'%':xs) = char '%' <> f xs
500 f (x:xs) = char x <> f xs
504 return (showSDoc (f (prompt st)))
508 readlineLoop :: GHCi ()
511 saveSession -- for use by completion
513 l <- io (readline prompt `finally` setNonBlockingFD 0)
514 -- readline sometimes puts stdin into blocking mode,
515 -- so we need to put it back for the IO library
520 case removeSpaces l of
524 quit <- runCommands l
525 if quit then return () else readlineLoop
528 runCommands :: String -> GHCi Bool
530 q <- ghciHandle handler (doCommand cmd)
531 if q then return True else runNext
537 c:cs -> do setGHCiState st{ cmdqueue = cs }
540 doCommand (':' : cmd) = specialCommand cmd
541 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
544 enqueueCommands :: [String] -> GHCi ()
545 enqueueCommands cmds = do
547 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
550 -- This version is for the GHC command-line option -e. The only difference
551 -- from runCommand is that it catches the ExitException exception and
552 -- exits, rather than printing out the exception.
553 runCommandEval :: String -> GHCi Bool
554 runCommandEval c = ghciHandle handleEval (doCommand c)
556 handleEval (ExitException code) = io (exitWith code)
557 handleEval e = do handler e
558 io (exitWith (ExitFailure 1))
560 doCommand (':' : command) = specialCommand command
562 = do r <- runStmt stmt GHC.RunToCompletion
564 False -> io (exitWith (ExitFailure 1))
565 -- failure to run the command causes exit(1) for ghc -e.
568 runStmt :: String -> SingleStep -> GHCi Bool
570 | null (filter (not.isSpace) stmt) = return False
571 | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
573 = do st <- getGHCiState
574 session <- getSession
575 result <- io $ withProgName (progname st) $ withArgs (args st) $
576 GHC.runStmt session stmt step
577 afterRunStmt (const True) result
580 --afterRunStmt :: GHC.RunResult -> GHCi Bool
581 -- False <=> the statement failed to compile
582 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
583 afterRunStmt _ (GHC.RunException e) = throw e
584 afterRunStmt step_here run_result = do
585 session <- getSession
586 resumes <- io $ GHC.getResumeContext session
588 GHC.RunOk names -> do
589 show_types <- isOptionSet ShowType
590 when show_types $ printTypeOfNames session names
591 GHC.RunBreak _ names mb_info
592 | isNothing mb_info ||
593 step_here (GHC.resumeSpan $ head resumes) -> do
594 printForUser $ ptext SLIT("Stopped at") <+>
595 ppr (GHC.resumeSpan $ head resumes)
596 -- printTypeOfNames session names
597 printTypeAndContentOfNames session names
598 maybe (return ()) runBreakCmd mb_info
599 -- run the command set with ":set stop <cmd>"
601 enqueueCommands [stop st]
603 | otherwise -> io(GHC.resume session GHC.SingleStep) >>=
604 afterRunStmt step_here >> return ()
608 io installSignalHandlers
609 b <- isOptionSet RevertCAFs
610 io (when b revertCAFs)
612 return (case run_result of GHC.RunOk _ -> True; _ -> False)
614 where printTypeAndContentOfNames session names = do
615 let namesSorted = sortBy compareNames names
616 tythings <- catMaybes `liftM`
617 io (mapM (GHC.lookupName session) namesSorted)
618 let ids = [id | AnId id <- tythings]
619 terms <- mapM (io . GHC.obtainTermB session 10 False) ids
620 docs_terms <- mapM (io . showTerm session) terms
621 dflags <- getDynFlags
622 let pefas = dopt Opt_PrintExplicitForalls dflags
623 printForUser $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts)
624 (map (pprTyThing pefas . AnId) ids)
627 runBreakCmd :: GHC.BreakInfo -> GHCi ()
628 runBreakCmd info = do
629 let mod = GHC.breakInfo_module info
630 nm = GHC.breakInfo_number info
632 case [ loc | (_,loc) <- breaks st,
633 breakModule loc == mod, breakTick loc == nm ] of
635 loc:_ | null cmd -> return ()
636 | otherwise -> do enqueueCommands [cmd]; return ()
637 where cmd = onBreakCmd loc
639 printTypeOfNames :: Session -> [Name] -> GHCi ()
640 printTypeOfNames session names
641 = mapM_ (printTypeOfName session) $ sortBy compareNames names
643 compareNames :: Name -> Name -> Ordering
644 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
645 where compareWith n = (getOccString n, getSrcSpan n)
647 printTypeOfName :: Session -> Name -> GHCi ()
648 printTypeOfName session n
649 = do maybe_tything <- io (GHC.lookupName session n)
650 case maybe_tything of
652 Just thing -> printTyThing thing
654 specialCommand :: String -> GHCi Bool
655 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
656 specialCommand str = do
657 let (cmd,rest) = break isSpace str
658 maybe_cmd <- io (lookupCommand cmd)
660 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
661 ++ shortHelpText) >> return False)
662 Just (_,f,_,_) -> f (dropWhile isSpace rest)
664 lookupCommand :: String -> IO (Maybe Command)
665 lookupCommand str = do
666 cmds <- readIORef commands
667 -- look for exact match first, then the first prefix match
668 case [ c | c <- cmds, str == cmdName c ] of
669 c:_ -> return (Just c)
670 [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
672 c:_ -> return (Just c)
675 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
676 getCurrentBreakSpan = do
677 session <- getSession
678 resumes <- io $ GHC.getResumeContext session
682 let ix = GHC.resumeHistoryIx r
684 then return (Just (GHC.resumeSpan r))
686 let hist = GHC.resumeHistory r !! (ix-1)
687 span <- io $ GHC.getHistorySpan session hist
690 getCurrentBreakModule :: GHCi (Maybe Module)
691 getCurrentBreakModule = do
692 session <- getSession
693 resumes <- io $ GHC.getResumeContext session
697 let ix = GHC.resumeHistoryIx r
699 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
701 let hist = GHC.resumeHistory r !! (ix-1)
702 return $ Just $ GHC.getHistoryModule hist
704 -----------------------------------------------------------------------------
707 noArgs :: GHCi () -> String -> GHCi ()
709 noArgs _ _ = io $ putStrLn "This command takes no arguments"
711 help :: String -> GHCi ()
712 help _ = io (putStr helpText)
714 info :: String -> GHCi ()
715 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
716 info s = do { let names = words s
717 ; session <- getSession
718 ; dflags <- getDynFlags
719 ; let pefas = dopt Opt_PrintExplicitForalls dflags
720 ; mapM_ (infoThing pefas session) names }
722 infoThing pefas session str = io $ do
723 names <- GHC.parseName session str
724 mb_stuffs <- mapM (GHC.getInfo session) names
725 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
726 unqual <- GHC.getPrintUnqual session
727 putStrLn (showSDocForUser unqual $
728 vcat (intersperse (text "") $
729 map (pprInfo pefas) filtered))
731 -- Filter out names whose parent is also there Good
732 -- example is '[]', which is both a type and data
733 -- constructor in the same type
734 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
735 filterOutChildren get_thing xs
736 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
738 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
740 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
741 pprInfo pefas (thing, fixity, insts)
742 = pprTyThingInContextLoc pefas thing
743 $$ show_fixity fixity
744 $$ vcat (map GHC.pprInstance insts)
747 | fix == GHC.defaultFixity = empty
748 | otherwise = ppr fix <+> ppr (GHC.getName thing)
750 runMain :: String -> GHCi ()
752 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
753 enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
755 addModule :: [FilePath] -> GHCi ()
757 io (revertCAFs) -- always revert CAFs on load/add.
758 files <- mapM expandPath files
759 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
760 session <- getSession
761 io (mapM_ (GHC.addTarget session) targets)
762 ok <- io (GHC.load session LoadAllTargets)
765 changeDirectory :: String -> GHCi ()
766 changeDirectory dir = do
767 session <- getSession
768 graph <- io (GHC.getModuleGraph session)
769 when (not (null graph)) $
770 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
771 io (GHC.setTargets session [])
772 io (GHC.load session LoadAllTargets)
773 setContextAfterLoad session []
774 io (GHC.workingDirectoryChanged session)
775 dir <- expandPath dir
776 io (setCurrentDirectory dir)
778 editFile :: String -> GHCi ()
780 do file <- if null str then chooseEditFile else return str
784 $ throwDyn (CmdLineError "editor not set, use :set editor")
785 io $ system (cmd ++ ' ':file)
788 -- The user didn't specify a file so we pick one for them.
789 -- Our strategy is to pick the first module that failed to load,
790 -- or otherwise the first target.
792 -- XXX: Can we figure out what happened if the depndecy analysis fails
793 -- (e.g., because the porgrammeer mistyped the name of a module)?
794 -- XXX: Can we figure out the location of an error to pass to the editor?
795 -- XXX: if we could figure out the list of errors that occured during the
796 -- last load/reaload, then we could start the editor focused on the first
798 chooseEditFile :: GHCi String
800 do session <- getSession
801 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
803 graph <- io (GHC.getModuleGraph session)
804 failed_graph <- filterM hasFailed graph
805 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
807 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
810 case pick (order failed_graph) of
811 Just file -> return file
813 do targets <- io (GHC.getTargets session)
814 case msum (map fromTarget targets) of
815 Just file -> return file
816 Nothing -> throwDyn (CmdLineError "No files to edit.")
818 where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
819 fromTarget _ = Nothing -- when would we get a module target?
821 defineMacro :: String -> GHCi ()
823 let (macro_name, definition) = break isSpace s
824 cmds <- io (readIORef commands)
826 then throwDyn (CmdLineError "invalid macro name")
828 if (macro_name `elem` map cmdName cmds)
829 then throwDyn (CmdLineError
830 ("command '" ++ macro_name ++ "' is already defined"))
833 -- give the expression a type signature, so we can be sure we're getting
834 -- something of the right type.
835 let new_expr = '(' : definition ++ ") :: String -> IO String"
837 -- compile the expression
839 maybe_hv <- io (GHC.compileExpr cms new_expr)
842 Just hv -> io (writeIORef commands --
843 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
845 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
847 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
848 enqueueCommands (lines str)
851 undefineMacro :: String -> GHCi ()
852 undefineMacro macro_name = do
853 cmds <- io (readIORef commands)
854 if (macro_name `elem` map cmdName builtin_commands)
855 then throwDyn (CmdLineError
856 ("command '" ++ macro_name ++ "' cannot be undefined"))
858 if (macro_name `notElem` map cmdName cmds)
859 then throwDyn (CmdLineError
860 ("command '" ++ macro_name ++ "' not defined"))
862 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
864 cmdCmd :: String -> GHCi ()
866 let expr = '(' : str ++ ") :: IO String"
867 session <- getSession
868 maybe_hv <- io (GHC.compileExpr session expr)
872 cmds <- io $ (unsafeCoerce# hv :: IO String)
873 enqueueCommands (lines cmds)
876 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
877 loadModule fs = timeIt (loadModule' fs)
879 loadModule_ :: [FilePath] -> GHCi ()
880 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
882 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
883 loadModule' files = do
884 session <- getSession
887 discardActiveBreakPoints
888 io (GHC.setTargets session [])
889 io (GHC.load session LoadAllTargets)
892 let (filenames, phases) = unzip files
893 exp_filenames <- mapM expandPath filenames
894 let files' = zip exp_filenames phases
895 targets <- io (mapM (uncurry GHC.guessTarget) files')
897 -- NOTE: we used to do the dependency anal first, so that if it
898 -- fails we didn't throw away the current set of modules. This would
899 -- require some re-working of the GHC interface, so we'll leave it
900 -- as a ToDo for now.
902 io (GHC.setTargets session targets)
903 doLoad session LoadAllTargets
905 checkModule :: String -> GHCi ()
907 let modl = GHC.mkModuleName m
908 session <- getSession
909 result <- io (GHC.checkModule session modl False)
911 Nothing -> io $ putStrLn "Nothing"
912 Just r -> io $ putStrLn (showSDoc (
913 case GHC.checkedModuleInfo r of
914 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
916 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
918 (text "global names: " <+> ppr global) $$
919 (text "local names: " <+> ppr local)
921 afterLoad (successIf (isJust result)) session
923 reloadModule :: String -> GHCi ()
925 session <- getSession
926 doLoad session $ if null m then LoadAllTargets
927 else LoadUpTo (GHC.mkModuleName m)
930 doLoad :: Session -> LoadHowMuch -> GHCi SuccessFlag
931 doLoad session howmuch = do
932 -- turn off breakpoints before we load: we can't turn them off later, because
933 -- the ModBreaks will have gone away.
934 discardActiveBreakPoints
935 ok <- io (GHC.load session howmuch)
939 afterLoad :: SuccessFlag -> Session -> GHCi ()
940 afterLoad ok session = do
941 io (revertCAFs) -- always revert CAFs on load.
943 loaded_mods <- getLoadedModules session
944 setContextAfterLoad session loaded_mods
945 modulesLoadedMsg ok (map GHC.ms_mod_name loaded_mods)
947 setContextAfterLoad :: Session -> [GHC.ModSummary] -> GHCi ()
948 setContextAfterLoad session [] = do
949 prel_mod <- getPrelude
950 io (GHC.setContext session [] [prel_mod])
951 setContextAfterLoad session ms = do
952 -- load a target if one is available, otherwise load the topmost module.
953 targets <- io (GHC.getTargets session)
954 case [ m | Just m <- map (findTarget ms) targets ] of
956 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
957 load_this (last graph')
962 = case filter (`matches` t) ms of
966 summary `matches` Target (TargetModule m) _
967 = GHC.ms_mod_name summary == m
968 summary `matches` Target (TargetFile f _) _
969 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
973 load_this summary | m <- GHC.ms_mod summary = do
974 b <- io (GHC.moduleIsInterpreted session m)
975 if b then io (GHC.setContext session [m] [])
977 prel_mod <- getPrelude
978 io (GHC.setContext session [] [prel_mod,m])
981 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
982 modulesLoadedMsg ok mods = do
983 dflags <- getDynFlags
984 when (verbosity dflags > 0) $ do
986 | null mods = text "none."
988 punctuate comma (map ppr mods)) <> text "."
991 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
993 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
996 typeOfExpr :: String -> GHCi ()
998 = do cms <- getSession
999 maybe_ty <- io (GHC.exprType cms str)
1001 Nothing -> return ()
1002 Just ty -> do dflags <- getDynFlags
1003 let pefas = dopt Opt_PrintExplicitForalls dflags
1004 printForUser $ text str <+> dcolon
1005 <+> pprTypeForUser pefas ty
1007 kindOfType :: String -> GHCi ()
1009 = do cms <- getSession
1010 maybe_ty <- io (GHC.typeKind cms str)
1012 Nothing -> return ()
1013 Just ty -> printForUser $ text str <+> dcolon <+> ppr ty
1015 quit :: String -> GHCi Bool
1016 quit _ = return True
1018 shellEscape :: String -> GHCi Bool
1019 shellEscape str = io (system str >> return False)
1021 -----------------------------------------------------------------------------
1022 -- Browsing a module's contents
1024 browseCmd :: String -> GHCi ()
1027 ['*':m] | looksLikeModuleName m -> browseModule m False
1028 [m] | looksLikeModuleName m -> browseModule m True
1029 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1031 browseModule :: String -> Bool -> GHCi ()
1032 browseModule m exports_only = do
1034 modl <- if exports_only then lookupModule m
1035 else wantInterpretedModule m
1037 -- Temporarily set the context to the module we're interested in,
1038 -- just so we can get an appropriate PrintUnqualified
1039 (as,bs) <- io (GHC.getContext s)
1040 prel_mod <- getPrelude
1041 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1042 else GHC.setContext s [modl] [])
1043 unqual <- io (GHC.getPrintUnqual s)
1044 io (GHC.setContext s as bs)
1046 mb_mod_info <- io $ GHC.getModuleInfo s modl
1048 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1051 | exports_only = GHC.modInfoExports mod_info
1052 | otherwise = GHC.modInfoTopLevelScope mod_info
1055 mb_things <- io $ mapM (GHC.lookupName s) names
1056 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1058 dflags <- getDynFlags
1059 let pefas = dopt Opt_PrintExplicitForalls dflags
1060 io (putStrLn (showSDocForUser unqual (
1061 vcat (map (pprTyThingInContext pefas) filtered_things)
1063 -- ToDo: modInfoInstances currently throws an exception for
1064 -- package modules. When it works, we can do this:
1065 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1067 -----------------------------------------------------------------------------
1068 -- Setting the module context
1070 setContext :: String -> GHCi ()
1072 | all sensible mods = fn mods
1073 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1075 (fn, mods) = case str of
1076 '+':stuff -> (addToContext, words stuff)
1077 '-':stuff -> (removeFromContext, words stuff)
1078 stuff -> (newContext, words stuff)
1080 sensible ('*':m) = looksLikeModuleName m
1081 sensible m = looksLikeModuleName m
1083 separate :: Session -> [String] -> [Module] -> [Module]
1084 -> GHCi ([Module],[Module])
1085 separate _ [] as bs = return (as,bs)
1086 separate session (('*':str):ms) as bs = do
1087 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1088 b <- io $ GHC.moduleIsInterpreted session m
1089 if b then separate session ms (m:as) bs
1090 else throwDyn (CmdLineError ("module '"
1091 ++ GHC.moduleNameString (GHC.moduleName m)
1092 ++ "' is not interpreted"))
1093 separate session (str:ms) as bs = do
1094 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1095 separate session ms as (m:bs)
1097 newContext :: [String] -> GHCi ()
1098 newContext strs = do
1100 (as,bs) <- separate s strs [] []
1101 prel_mod <- getPrelude
1102 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1103 io $ GHC.setContext s as bs'
1106 addToContext :: [String] -> GHCi ()
1107 addToContext strs = do
1109 (as,bs) <- io $ GHC.getContext s
1111 (new_as,new_bs) <- separate s strs [] []
1113 let as_to_add = new_as \\ (as ++ bs)
1114 bs_to_add = new_bs \\ (as ++ bs)
1116 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1119 removeFromContext :: [String] -> GHCi ()
1120 removeFromContext strs = do
1122 (as,bs) <- io $ GHC.getContext s
1124 (as_to_remove,bs_to_remove) <- separate s strs [] []
1126 let as' = as \\ (as_to_remove ++ bs_to_remove)
1127 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1129 io $ GHC.setContext s as' bs'
1131 ----------------------------------------------------------------------------
1134 -- set options in the interpreter. Syntax is exactly the same as the
1135 -- ghc command line, except that certain options aren't available (-C,
1138 -- This is pretty fragile: most options won't work as expected. ToDo:
1139 -- figure out which ones & disallow them.
1141 setCmd :: String -> GHCi ()
1143 = do st <- getGHCiState
1144 let opts = options st
1145 io $ putStrLn (showSDoc (
1146 text "options currently set: " <>
1149 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1152 = case toArgs str of
1153 ("args":args) -> setArgs args
1154 ("prog":prog) -> setProg prog
1155 ("prompt":_) -> setPrompt (after 6)
1156 ("editor":_) -> setEditor (after 6)
1157 ("stop":_) -> setStop (after 4)
1158 wds -> setOptions wds
1159 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1161 setArgs, setProg, setOptions :: [String] -> GHCi ()
1162 setEditor, setStop, setPrompt :: String -> GHCi ()
1166 setGHCiState st{ args = args }
1170 setGHCiState st{ progname = prog }
1172 io (hPutStrLn stderr "syntax: :set prog <progname>")
1176 setGHCiState st{ editor = cmd }
1178 setStop str@(c:_) | isDigit c
1179 = do let (nm_str,rest) = break (not.isDigit) str
1182 let old_breaks = breaks st
1183 if all ((/= nm) . fst) old_breaks
1184 then printForUser (text "Breakpoint" <+> ppr nm <+>
1185 text "does not exist")
1187 let new_breaks = map fn old_breaks
1188 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1189 | otherwise = (i,loc)
1190 setGHCiState st{ breaks = new_breaks }
1193 setGHCiState st{ stop = cmd }
1195 setPrompt value = do
1198 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1199 else setGHCiState st{ prompt = remQuotes value }
1201 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1205 do -- first, deal with the GHCi opts (+s, +t, etc.)
1206 let (plus_opts, minus_opts) = partitionWith isPlus wds
1207 mapM_ setOpt plus_opts
1208 -- then, dynamic flags
1209 newDynFlags minus_opts
1211 newDynFlags :: [String] -> GHCi ()
1212 newDynFlags minus_opts = do
1213 dflags <- getDynFlags
1214 let pkg_flags = packageFlags dflags
1215 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1217 if (not (null leftovers))
1218 then throwDyn (CmdLineError ("unrecognised flags: " ++
1222 new_pkgs <- setDynFlags dflags'
1224 -- if the package flags changed, we should reset the context
1225 -- and link the new packages.
1226 dflags <- getDynFlags
1227 when (packageFlags dflags /= pkg_flags) $ do
1228 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1229 session <- getSession
1230 io (GHC.setTargets session [])
1231 io (GHC.load session LoadAllTargets)
1232 io (linkPackages dflags new_pkgs)
1233 setContextAfterLoad session []
1237 unsetOptions :: String -> GHCi ()
1239 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1240 let opts = words str
1241 (minus_opts, rest1) = partition isMinus opts
1242 (plus_opts, rest2) = partitionWith isPlus rest1
1244 if (not (null rest2))
1245 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1248 mapM_ unsetOpt plus_opts
1250 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1251 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1253 no_flags <- mapM no_flag minus_opts
1254 newDynFlags no_flags
1256 isMinus :: String -> Bool
1257 isMinus ('-':_) = True
1260 isPlus :: String -> Either String String
1261 isPlus ('+':opt) = Left opt
1262 isPlus other = Right other
1264 setOpt, unsetOpt :: String -> GHCi ()
1267 = case strToGHCiOpt str of
1268 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1269 Just o -> setOption o
1272 = case strToGHCiOpt str of
1273 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1274 Just o -> unsetOption o
1276 strToGHCiOpt :: String -> (Maybe GHCiOption)
1277 strToGHCiOpt "s" = Just ShowTiming
1278 strToGHCiOpt "t" = Just ShowType
1279 strToGHCiOpt "r" = Just RevertCAFs
1280 strToGHCiOpt _ = Nothing
1282 optToStr :: GHCiOption -> String
1283 optToStr ShowTiming = "s"
1284 optToStr ShowType = "t"
1285 optToStr RevertCAFs = "r"
1287 -- ---------------------------------------------------------------------------
1290 showCmd :: String -> GHCi ()
1294 ["args"] -> io $ putStrLn (show (args st))
1295 ["prog"] -> io $ putStrLn (show (progname st))
1296 ["prompt"] -> io $ putStrLn (show (prompt st))
1297 ["editor"] -> io $ putStrLn (show (editor st))
1298 ["stop"] -> io $ putStrLn (show (stop st))
1299 ["modules" ] -> showModules
1300 ["bindings"] -> showBindings
1301 ["linker"] -> io showLinkerState
1302 ["breaks"] -> showBkptTable
1303 ["context"] -> showContext
1304 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1306 showModules :: GHCi ()
1308 session <- getSession
1309 loaded_mods <- getLoadedModules session
1310 -- we want *loaded* modules only, see #1734
1311 let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m)
1312 mapM_ show_one loaded_mods
1314 getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary]
1315 getLoadedModules session = do
1316 graph <- io (GHC.getModuleGraph session)
1317 filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
1319 showBindings :: GHCi ()
1322 bindings <- io (GHC.getBindings s)
1323 mapM_ printTyThing $ sortBy compareTyThings bindings
1326 compareTyThings :: TyThing -> TyThing -> Ordering
1327 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1329 printTyThing :: TyThing -> GHCi ()
1330 printTyThing tyth = do dflags <- getDynFlags
1331 let pefas = dopt Opt_PrintExplicitForalls dflags
1332 printForUser (pprTyThing pefas tyth)
1334 showBkptTable :: GHCi ()
1337 printForUser $ prettyLocations (breaks st)
1339 showContext :: GHCi ()
1341 session <- getSession
1342 resumes <- io $ GHC.getResumeContext session
1343 printForUser $ vcat (map pp_resume (reverse resumes))
1346 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1347 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1350 -- -----------------------------------------------------------------------------
1353 completeNone :: String -> IO [String]
1354 completeNone _w = return []
1356 completeMacro, completeIdentifier, completeModule,
1357 completeHomeModule, completeSetOptions, completeFilename,
1358 completeHomeModuleOrFile
1359 :: String -> IO [String]
1362 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1363 completeWord w start end = do
1364 line <- Readline.getLineBuffer
1365 let line_words = words (dropWhile isSpace line)
1367 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1369 | ((':':c) : _) <- line_words -> do
1370 maybe_cmd <- lookupCommand c
1371 let (n,w') = selectWord (words' 0 line)
1373 Nothing -> return Nothing
1374 Just (_,_,False,complete) -> wrapCompleter complete w
1375 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1376 return (map (drop n) rets)
1377 in wrapCompleter complete' w'
1378 | ("import" : _) <- line_words ->
1379 wrapCompleter completeModule w
1381 --printf "complete %s, start = %d, end = %d\n" w start end
1382 wrapCompleter completeIdentifier w
1383 where words' _ [] = []
1384 words' n str = let (w,r) = break isSpace str
1385 (s,r') = span isSpace r
1386 in (n,w):words' (n+length w+length s) r'
1387 -- In a Haskell expression we want to parse 'a-b' as three words
1388 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1389 -- only be a single word.
1390 selectWord [] = (0,w)
1391 selectWord ((offset,x):xs)
1392 | offset+length x >= start = (start-offset,take (end-offset) x)
1393 | otherwise = selectWord xs
1395 completeCmd :: String -> IO [String]
1397 cmds <- readIORef commands
1398 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1400 completeMacro w = do
1401 cmds <- readIORef commands
1402 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1403 return (filter (w `isPrefixOf`) cmds')
1405 completeIdentifier w = do
1407 rdrs <- GHC.getRdrNamesInScope s
1408 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1410 completeModule w = do
1412 dflags <- GHC.getSessionDynFlags s
1413 let pkg_mods = allExposedModules dflags
1414 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1416 completeHomeModule w = do
1418 g <- GHC.getModuleGraph s
1419 let home_mods = map GHC.ms_mod_name g
1420 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1422 completeSetOptions w = do
1423 return (filter (w `isPrefixOf`) options)
1424 where options = "args":"prog":allFlags
1426 completeFilename = Readline.filenameCompletionFunction
1428 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1430 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1431 unionComplete f1 f2 w = do
1436 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1437 wrapCompleter fun w = do
1440 [] -> return Nothing
1441 [x] -> return (Just (x,[]))
1442 xs -> case getCommonPrefix xs of
1443 "" -> return (Just ("",xs))
1444 pref -> return (Just (pref,xs))
1446 getCommonPrefix :: [String] -> String
1447 getCommonPrefix [] = ""
1448 getCommonPrefix (s:ss) = foldl common s ss
1449 where common _s "" = ""
1451 common (c:cs) (d:ds)
1452 | c == d = c : common cs ds
1455 allExposedModules :: DynFlags -> [ModuleName]
1456 allExposedModules dflags
1457 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1459 pkg_db = pkgIdMap (pkgState dflags)
1461 completeMacro = completeNone
1462 completeIdentifier = completeNone
1463 completeModule = completeNone
1464 completeHomeModule = completeNone
1465 completeSetOptions = completeNone
1466 completeFilename = completeNone
1467 completeHomeModuleOrFile=completeNone
1470 -- ---------------------------------------------------------------------------
1471 -- User code exception handling
1473 -- This is the exception handler for exceptions generated by the
1474 -- user's code and exceptions coming from children sessions;
1475 -- it normally just prints out the exception. The
1476 -- handler must be recursive, in case showing the exception causes
1477 -- more exceptions to be raised.
1479 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1480 -- raising another exception. We therefore don't put the recursive
1481 -- handler arond the flushing operation, so if stderr is closed
1482 -- GHCi will just die gracefully rather than going into an infinite loop.
1483 handler :: Exception -> GHCi Bool
1485 handler exception = do
1487 io installSignalHandlers
1488 ghciHandle handler (showException exception >> return False)
1490 showException :: Exception -> GHCi ()
1491 showException (DynException dyn) =
1492 case fromDynamic dyn of
1493 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1494 Just Interrupted -> io (putStrLn "Interrupted.")
1495 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1496 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1497 Just other_ghc_ex -> io (print other_ghc_ex)
1499 showException other_exception
1500 = io (putStrLn ("*** Exception: " ++ show other_exception))
1502 -----------------------------------------------------------------------------
1503 -- recursive exception handlers
1505 -- Don't forget to unblock async exceptions in the handler, or if we're
1506 -- in an exception loop (eg. let a = error a in a) the ^C exception
1507 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1509 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1510 ghciHandle h (GHCi m) = GHCi $ \s ->
1511 Exception.catch (m s)
1512 (\e -> unGHCi (ghciUnblock (h e)) s)
1514 ghciUnblock :: GHCi a -> GHCi a
1515 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1518 -- ----------------------------------------------------------------------------
1521 expandPath :: String -> GHCi String
1523 case dropWhile isSpace path of
1525 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1526 return (tilde ++ '/':d)
1530 wantInterpretedModule :: String -> GHCi Module
1531 wantInterpretedModule str = do
1532 session <- getSession
1533 modl <- lookupModule str
1534 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1535 when (not is_interpreted) $
1536 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1539 wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String
1540 -> (Name -> GHCi ())
1542 wantNameFromInterpretedModule noCanDo str and_then = do
1543 session <- getSession
1544 names <- io $ GHC.parseName session str
1548 let modl = GHC.nameModule n
1549 if not (GHC.isExternalName n)
1550 then noCanDo n $ ppr n <>
1551 text " is not defined in an interpreted module"
1553 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1554 if not is_interpreted
1555 then noCanDo n $ text "module " <> ppr modl <>
1556 text " is not interpreted"
1559 -- ----------------------------------------------------------------------------
1560 -- Windows console setup
1562 setUpConsole :: IO ()
1564 #ifdef mingw32_HOST_OS
1565 -- On Windows we need to set a known code page, otherwise the characters
1566 -- we read from the console will be be in some strange encoding, and
1567 -- similarly for characters we write to the console.
1569 -- At the moment, GHCi pretends all input is Latin-1. In the
1570 -- future we should support UTF-8, but for now we set the code
1571 -- pages to Latin-1. Doing it this way does lead to problems,
1572 -- however: see bug #1649.
1574 -- It seems you have to set the font in the console window to
1575 -- a Unicode font in order for output to work properly,
1576 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1577 -- (see MSDN for SetConsoleOutputCP()).
1579 -- This call has been known to hang on some machines, see bug #1483
1581 setConsoleCP 28591 -- ISO Latin-1
1582 setConsoleOutputCP 28591 -- ISO Latin-1
1586 -- -----------------------------------------------------------------------------
1587 -- commands for debugger
1589 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1590 sprintCmd = pprintCommand False False
1591 printCmd = pprintCommand True False
1592 forceCmd = pprintCommand False True
1594 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1595 pprintCommand bind force str = do
1596 session <- getSession
1597 io $ pprintClosureCommand session bind force str
1599 stepCmd :: String -> GHCi ()
1600 stepCmd [] = doContinue (const True) GHC.SingleStep
1601 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1603 stepLocalCmd :: String -> GHCi ()
1604 stepLocalCmd [] = do
1605 mb_span <- getCurrentBreakSpan
1607 Nothing -> stepCmd []
1609 Just mod <- getCurrentBreakModule
1610 current_toplevel_decl <- enclosingTickSpan mod loc
1611 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1613 stepLocalCmd expression = stepCmd expression
1615 stepModuleCmd :: String -> GHCi ()
1616 stepModuleCmd [] = do
1617 mb_span <- getCurrentBreakSpan
1619 Nothing -> stepCmd []
1621 Just span <- getCurrentBreakSpan
1622 let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
1623 doContinue f GHC.SingleStep
1625 stepModuleCmd expression = stepCmd expression
1627 -- | Returns the span of the largest tick containing the srcspan given
1628 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1629 enclosingTickSpan mod src = do
1630 ticks <- getTickArray mod
1631 let line = srcSpanStartLine src
1632 ASSERT (inRange (bounds ticks) line) do
1633 let enclosing_spans = [ span | (_,span) <- ticks ! line
1634 , srcSpanEnd span >= srcSpanEnd src]
1635 return . head . sortBy leftmost_largest $ enclosing_spans
1637 traceCmd :: String -> GHCi ()
1638 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1639 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1641 continueCmd :: String -> GHCi ()
1642 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1644 -- doContinue :: SingleStep -> GHCi ()
1645 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1646 doContinue pred step = do
1647 session <- getSession
1648 runResult <- io $ GHC.resume session step
1649 afterRunStmt pred runResult
1652 abandonCmd :: String -> GHCi ()
1653 abandonCmd = noArgs $ do
1655 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1656 when (not b) $ io $ putStrLn "There is no computation running."
1659 deleteCmd :: String -> GHCi ()
1660 deleteCmd argLine = do
1661 deleteSwitch $ words argLine
1663 deleteSwitch :: [String] -> GHCi ()
1665 io $ putStrLn "The delete command requires at least one argument."
1666 -- delete all break points
1667 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1668 deleteSwitch idents = do
1669 mapM_ deleteOneBreak idents
1671 deleteOneBreak :: String -> GHCi ()
1673 | all isDigit str = deleteBreak (read str)
1674 | otherwise = return ()
1676 historyCmd :: String -> GHCi ()
1678 | null arg = history 20
1679 | all isDigit arg = history (read arg)
1680 | otherwise = io $ putStrLn "Syntax: :history [num]"
1684 resumes <- io $ GHC.getResumeContext s
1686 [] -> io $ putStrLn "Not stopped at a breakpoint"
1688 let hist = GHC.resumeHistory r
1689 (took,rest) = splitAt num hist
1690 spans <- mapM (io . GHC.getHistorySpan s) took
1691 let nums = map (printf "-%-3d:") [(1::Int)..]
1692 let names = map GHC.historyEnclosingDecl took
1693 printForUser (vcat(zipWith3
1694 (\x y z -> x <+> y <+> z)
1696 (map (bold . ppr) names)
1697 (map (parens . ppr) spans)))
1698 io $ putStrLn $ if null rest then "<end of history>" else "..."
1700 bold :: SDoc -> SDoc
1701 bold c | do_bold = text start_bold <> c <> text end_bold
1704 backCmd :: String -> GHCi ()
1705 backCmd = noArgs $ do
1707 (names, _, span) <- io $ GHC.back s
1708 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1709 printTypeOfNames s names
1710 -- run the command set with ":set stop <cmd>"
1712 enqueueCommands [stop st]
1714 forwardCmd :: String -> GHCi ()
1715 forwardCmd = noArgs $ do
1717 (names, ix, span) <- io $ GHC.forward s
1718 printForUser $ (if (ix == 0)
1719 then ptext SLIT("Stopped at")
1720 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1721 printTypeOfNames s names
1722 -- run the command set with ":set stop <cmd>"
1724 enqueueCommands [stop st]
1726 -- handle the "break" command
1727 breakCmd :: String -> GHCi ()
1728 breakCmd argLine = do
1729 session <- getSession
1730 breakSwitch session $ words argLine
1732 breakSwitch :: Session -> [String] -> GHCi ()
1733 breakSwitch _session [] = do
1734 io $ putStrLn "The break command requires at least one argument."
1735 breakSwitch session (arg1:rest)
1736 | looksLikeModuleName arg1 = do
1737 mod <- wantInterpretedModule arg1
1738 breakByModule mod rest
1739 | all isDigit arg1 = do
1740 (toplevel, _) <- io $ GHC.getContext session
1742 (mod : _) -> breakByModuleLine mod (read arg1) rest
1744 io $ putStrLn "Cannot find default module for breakpoint."
1745 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1746 | otherwise = do -- try parsing it as an identifier
1747 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1748 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1749 if GHC.isGoodSrcLoc loc
1750 then findBreakAndSet (GHC.nameModule name) $
1751 findBreakByCoord (Just (GHC.srcLocFile loc))
1752 (GHC.srcLocLine loc,
1754 else noCanDo name $ text "can't find its location: " <> ppr loc
1756 noCanDo n why = printForUser $
1757 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1759 breakByModule :: Module -> [String] -> GHCi ()
1760 breakByModule mod (arg1:rest)
1761 | all isDigit arg1 = do -- looks like a line number
1762 breakByModuleLine mod (read arg1) rest
1766 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1767 breakByModuleLine mod line args
1768 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1769 | [col] <- args, all isDigit col =
1770 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1771 | otherwise = breakSyntax
1774 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1776 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1777 findBreakAndSet mod lookupTickTree = do
1778 tickArray <- getTickArray mod
1779 (breakArray, _) <- getModBreak mod
1780 case lookupTickTree tickArray of
1781 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1782 Just (tick, span) -> do
1783 success <- io $ setBreakFlag True breakArray tick
1787 recordBreak $ BreakLocation
1794 text "Breakpoint " <> ppr nm <>
1796 then text " was already set at " <> ppr span
1797 else text " activated at " <> ppr span
1799 printForUser $ text "Breakpoint could not be activated at"
1802 -- When a line number is specified, the current policy for choosing
1803 -- the best breakpoint is this:
1804 -- - the leftmost complete subexpression on the specified line, or
1805 -- - the leftmost subexpression starting on the specified line, or
1806 -- - the rightmost subexpression enclosing the specified line
1808 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1809 findBreakByLine line arr
1810 | not (inRange (bounds arr) line) = Nothing
1812 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
1813 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
1814 listToMaybe (sortBy (rightmost `on` snd) ticks)
1818 starts_here = [ tick | tick@(_,span) <- ticks,
1819 GHC.srcSpanStartLine span == line ]
1821 (complete,incomplete) = partition ends_here starts_here
1822 where ends_here (_,span) = GHC.srcSpanEndLine span == line
1824 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1825 -> Maybe (BreakIndex,SrcSpan)
1826 findBreakByCoord mb_file (line, col) arr
1827 | not (inRange (bounds arr) line) = Nothing
1829 listToMaybe (sortBy (rightmost `on` snd) contains ++
1830 sortBy (leftmost_smallest `on` snd) after_here)
1834 -- the ticks that span this coordinate
1835 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
1836 is_correct_file span ]
1838 is_correct_file span
1839 | Just f <- mb_file = GHC.srcSpanFile span == f
1842 after_here = [ tick | tick@(_,span) <- ticks,
1843 GHC.srcSpanStartLine span == line,
1844 GHC.srcSpanStartCol span >= col ]
1846 -- For now, use ANSI bold on terminals that we know support it.
1847 -- Otherwise, we add a line of carets under the active expression instead.
1848 -- In particular, on Windows and when running the testsuite (which sets
1849 -- TERM to vt100 for other reasons) we get carets.
1850 -- We really ought to use a proper termcap/terminfo library.
1852 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
1853 where mTerm = System.Environment.getEnv "TERM"
1854 `Exception.catch` \_ -> return "TERM not set"
1856 start_bold :: String
1857 start_bold = "\ESC[1m"
1859 end_bold = "\ESC[0m"
1861 listCmd :: String -> GHCi ()
1863 mb_span <- getCurrentBreakSpan
1865 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1866 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1867 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
1868 listCmd str = list2 (words str)
1870 list2 :: [String] -> GHCi ()
1871 list2 [arg] | all isDigit arg = do
1872 session <- getSession
1873 (toplevel, _) <- io $ GHC.getContext session
1875 [] -> io $ putStrLn "No module to list"
1876 (mod : _) -> listModuleLine mod (read arg)
1877 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1878 mod <- wantInterpretedModule arg1
1879 listModuleLine mod (read arg2)
1881 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1882 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1883 if GHC.isGoodSrcLoc loc
1885 tickArray <- getTickArray (GHC.nameModule name)
1886 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1887 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1890 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1891 Just (_,span) -> io $ listAround span False
1893 noCanDo name $ text "can't find its location: " <>
1896 noCanDo n why = printForUser $
1897 text "cannot list source code for " <> ppr n <> text ": " <> why
1899 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1901 listModuleLine :: Module -> Int -> GHCi ()
1902 listModuleLine modl line = do
1903 session <- getSession
1904 graph <- io (GHC.getModuleGraph session)
1905 let this = filter ((== modl) . GHC.ms_mod) graph
1907 [] -> panic "listModuleLine"
1909 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1910 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1911 io $ listAround (GHC.srcLocSpan loc) False
1913 -- | list a section of a source file around a particular SrcSpan.
1914 -- If the highlight flag is True, also highlight the span using
1915 -- start_bold/end_bold.
1916 listAround :: SrcSpan -> Bool -> IO ()
1917 listAround span do_highlight = do
1918 contents <- BS.readFile (unpackFS file)
1920 lines = BS.split '\n' contents
1921 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1922 drop (line1 - 1 - pad_before) $ lines
1923 fst_line = max 1 (line1 - pad_before)
1924 line_nos = [ fst_line .. ]
1926 highlighted | do_highlight = zipWith highlight line_nos these_lines
1927 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
1929 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1930 prefixed = zipWith ($) highlighted bs_line_nos
1932 BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed)
1934 file = GHC.srcSpanFile span
1935 line1 = GHC.srcSpanStartLine span
1936 col1 = GHC.srcSpanStartCol span
1937 line2 = GHC.srcSpanEndLine span
1938 col2 = GHC.srcSpanEndCol span
1940 pad_before | line1 == 1 = 0
1944 highlight | do_bold = highlight_bold
1945 | otherwise = highlight_carets
1947 highlight_bold no line prefix
1948 | no == line1 && no == line2
1949 = let (a,r) = BS.splitAt col1 line
1950 (b,c) = BS.splitAt (col2-col1) r
1952 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
1954 = let (a,b) = BS.splitAt col1 line in
1955 BS.concat [prefix, a, BS.pack start_bold, b]
1957 = let (a,b) = BS.splitAt col2 line in
1958 BS.concat [prefix, a, BS.pack end_bold, b]
1959 | otherwise = BS.concat [prefix, line]
1961 highlight_carets no line prefix
1962 | no == line1 && no == line2
1963 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
1964 BS.replicate (col2-col1) '^']
1966 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
1969 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
1971 | otherwise = BS.concat [prefix, line]
1973 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
1974 nl = BS.singleton '\n'
1976 -- --------------------------------------------------------------------------
1979 getTickArray :: Module -> GHCi TickArray
1980 getTickArray modl = do
1982 let arrmap = tickarrays st
1983 case lookupModuleEnv arrmap modl of
1984 Just arr -> return arr
1986 (_breakArray, ticks) <- getModBreak modl
1987 let arr = mkTickArray (assocs ticks)
1988 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1991 discardTickArrays :: GHCi ()
1992 discardTickArrays = do
1994 setGHCiState st{tickarrays = emptyModuleEnv}
1996 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1998 = accumArray (flip (:)) [] (1, max_line)
1999 [ (line, (nm,span)) | (nm,span) <- ticks,
2000 line <- srcSpanLines span ]
2002 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2003 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2004 GHC.srcSpanEndLine span ]
2006 lookupModule :: String -> GHCi Module
2007 lookupModule modName
2008 = do session <- getSession
2009 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
2011 -- don't reset the counter back to zero?
2012 discardActiveBreakPoints :: GHCi ()
2013 discardActiveBreakPoints = do
2015 mapM (turnOffBreak.snd) (breaks st)
2016 setGHCiState $ st { breaks = [] }
2018 deleteBreak :: Int -> GHCi ()
2019 deleteBreak identity = do
2021 let oldLocations = breaks st
2022 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2024 then printForUser (text "Breakpoint" <+> ppr identity <+>
2025 text "does not exist")
2027 mapM (turnOffBreak.snd) this
2028 setGHCiState $ st { breaks = rest }
2030 turnOffBreak :: BreakLocation -> GHCi Bool
2031 turnOffBreak loc = do
2032 (arr, _) <- getModBreak (breakModule loc)
2033 io $ setBreakFlag False arr (breakTick loc)
2035 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2036 getModBreak mod = do
2037 session <- getSession
2038 Just mod_info <- io $ GHC.getModuleInfo session mod
2039 let modBreaks = GHC.modInfoModBreaks mod_info
2040 let array = GHC.modBreaks_flags modBreaks
2041 let ticks = GHC.modBreaks_locs modBreaks
2042 return (array, ticks)
2044 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2045 setBreakFlag toggle array index
2046 | toggle = GHC.setBreakOn array index
2047 | otherwise = GHC.setBreakOff array index