1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005-2006
8 -----------------------------------------------------------------------------
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
16 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
18 #include "HsVersions.h"
26 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
27 Type, Module, ModuleName, TyThing(..), Phase,
28 BreakIndex, SrcSpan, Resume, SingleStep )
34 import HscTypes ( implicitTyThings )
35 import Outputable hiding (printForUser)
36 import Module -- for ModuleEnv
40 -- Other random utilities
42 import BasicTypes hiding (isTopLevel)
43 import Panic hiding (showException)
49 import Maybes ( orElse )
52 #ifndef mingw32_HOST_OS
53 import System.Posix hiding (getEnv)
55 import GHC.ConsoleHandler ( flushConsole )
56 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
57 import qualified System.Win32
61 import Control.Concurrent ( yield ) -- Used in readline loop
62 import System.Console.Readline as Readline
67 import Control.Exception as Exception
68 -- import Control.Concurrent
70 import qualified Data.ByteString.Char8 as BS
74 import System.Environment
75 import System.Exit ( exitWith, ExitCode(..) )
76 import System.Directory
78 import System.IO.Error as IO
79 import System.IO.Unsafe
83 import Control.Monad as Monad
86 import Foreign.StablePtr ( newStablePtr )
87 import GHC.Exts ( unsafeCoerce# )
88 import GHC.IOBase ( IOErrorType(InvalidArgument) )
90 import Data.IORef ( IORef, readIORef, writeIORef )
92 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])
101 cmdName (n,_,_,_) = n
103 GLOBAL_VAR(commands, builtin_commands, [Command])
105 builtin_commands :: [Command]
107 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
108 ("?", keepGoing help, False, completeNone),
109 ("add", keepGoingPaths addModule, False, completeFilename),
110 ("abandon", keepGoing abandonCmd, False, completeNone),
111 ("break", keepGoing breakCmd, False, completeIdentifier),
112 ("back", keepGoing backCmd, False, completeNone),
113 ("browse", keepGoing browseCmd, False, completeModule),
114 ("cd", keepGoing changeDirectory, False, completeFilename),
115 ("check", keepGoing checkModule, False, completeHomeModule),
116 ("continue", keepGoing continueCmd, False, completeNone),
117 ("cmd", keepGoing cmdCmd, False, completeIdentifier),
118 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
119 ("def", keepGoing defineMacro, False, completeIdentifier),
120 ("delete", keepGoing deleteCmd, False, completeNone),
121 ("e", keepGoing editFile, False, completeFilename),
122 ("edit", keepGoing editFile, False, completeFilename),
123 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
124 ("force", keepGoing forceCmd, False, completeIdentifier),
125 ("forward", keepGoing forwardCmd, False, completeNone),
126 ("help", keepGoing help, False, completeNone),
127 ("history", keepGoing historyCmd, False, completeNone),
128 ("info", keepGoing info, False, completeIdentifier),
129 ("kind", keepGoing kindOfType, False, completeIdentifier),
130 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
131 ("list", keepGoing listCmd, False, completeNone),
132 ("module", keepGoing setContext, False, completeModule),
133 ("main", keepGoing runMain, False, completeIdentifier),
134 ("print", keepGoing printCmd, False, completeIdentifier),
135 ("quit", quit, False, completeNone),
136 ("reload", keepGoing reloadModule, False, completeNone),
137 ("set", keepGoing setCmd, True, completeSetOptions),
138 ("show", keepGoing showCmd, False, completeNone),
139 ("sprint", keepGoing sprintCmd, False, completeIdentifier),
140 ("step", keepGoing stepCmd, False, completeIdentifier),
141 ("steplocal", keepGoing stepLocalCmd, False, completeIdentifier),
142 ("stepmodule",keepGoing stepModuleCmd, False, completeIdentifier),
143 ("type", keepGoing typeOfExpr, False, completeIdentifier),
144 ("trace", keepGoing traceCmd, False, completeIdentifier),
145 ("undef", keepGoing undefineMacro, False, completeMacro),
146 ("unset", keepGoing unsetOptions, True, completeSetOptions)
149 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
150 keepGoing a str = a str >> return False
152 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
153 keepGoingPaths a str = a (toArgs str) >> return False
155 shortHelpText = "use :? for help.\n"
158 " Commands available from the prompt:\n" ++
160 " <statement> evaluate/run <statement>\n" ++
161 " :add <filename> ... add module(s) to the current target set\n" ++
162 " :browse [*]<module> display the names defined by <module>\n" ++
163 " :cd <dir> change directory to <dir>\n" ++
164 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
165 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
166 " :def <cmd> <expr> define a command :<cmd>\n" ++
167 " :edit <file> edit file\n" ++
168 " :edit edit last module\n" ++
169 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
170 " :help, :? display this list of commands\n" ++
171 " :info [<name> ...] display information about the given names\n" ++
172 " :kind <type> show the kind of <type>\n" ++
173 " :load <filename> ... load module(s) and their dependents\n" ++
174 " :main [<arguments> ...] run the main function with the given arguments\n" ++
175 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
176 " :quit exit GHCi\n" ++
177 " :reload reload the current module set\n" ++
178 " :type <expr> show the type of <expr>\n" ++
179 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
180 " :!<command> run the shell command <command>\n" ++
182 " -- Commands for debugging:\n" ++
184 " :abandon at a breakpoint, abandon current computation\n" ++
185 " :back go back in the history (after :trace)\n" ++
186 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
187 " :break <name> set a breakpoint on the specified function\n" ++
188 " :continue resume after a breakpoint\n" ++
189 " :delete <number> delete the specified breakpoint\n" ++
190 " :delete * delete all breakpoints\n" ++
191 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
192 " :forward go forward in the history (after :back)\n" ++
193 " :history [<n>] show the last <n> items in the history (after :trace)\n" ++
194 " :print [<name> ...] prints a value without forcing its computation\n" ++
195 " :sprint [<name> ...] simplifed version of :print\n" ++
196 " :step single-step after stopping at a breakpoint\n"++
197 " :step <expr> single-step into <expr>\n"++
198 " :steplocal single-step restricted to the current top level decl.\n"++
199 " :stepmodule single-step restricted to the current module\n"++
200 " :trace trace after stopping at a breakpoint\n"++
201 " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
204 " -- Commands for changing settings:\n" ++
206 " :set <option> ... set options\n" ++
207 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
208 " :set prog <progname> set the value returned by System.getProgName\n" ++
209 " :set prompt <prompt> set the prompt used in GHCi\n" ++
210 " :set editor <cmd> set the command used for :edit\n" ++
211 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
212 " :unset <option> ... unset options\n" ++
214 " Options for ':set' and ':unset':\n" ++
216 " +r revert top-level expressions after each evaluation\n" ++
217 " +s print timing/memory stats after each evaluation\n" ++
218 " +t print type after evaluation\n" ++
219 " -<flags> most GHC command line flags can also be set here\n" ++
220 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
222 " -- Commands for displaying information:\n" ++
224 " :show bindings show the current bindings made at the prompt\n" ++
225 " :show breaks show the active breakpoints\n" ++
226 " :show context show the breakpoint context\n" ++
227 " :show modules show the currently loaded modules\n" ++
228 " :show <setting> show anything that can be set with :set (e.g. args)\n" ++
235 win <- System.Win32.getWindowsDirectory
236 return (win `joinFileName` "notepad.exe")
241 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
242 interactiveUI session srcs maybe_expr = do
243 -- HACK! If we happen to get into an infinite loop (eg the user
244 -- types 'let x=x in x' at the prompt), then the thread will block
245 -- on a blackhole, and become unreachable during GC. The GC will
246 -- detect that it is unreachable and send it the NonTermination
247 -- exception. However, since the thread is unreachable, everything
248 -- it refers to might be finalized, including the standard Handles.
249 -- This sounds like a bug, but we don't have a good solution right
255 -- Initialise buffering for the *interpreted* I/O system
256 initInterpBuffering session
258 when (isNothing maybe_expr) $ do
259 -- Only for GHCi (not runghc and ghc -e):
261 -- Turn buffering off for the compiled program's stdout/stderr
263 -- Turn buffering off for GHCi's stdout
265 hSetBuffering stdout NoBuffering
266 -- We don't want the cmd line to buffer any input that might be
267 -- intended for the program, so unbuffer stdin.
268 hSetBuffering stdin NoBuffering
270 -- initial context is just the Prelude
271 prel_mod <- GHC.findModule session prel_name (Just basePackageId)
272 GHC.setContext session [] [prel_mod]
276 Readline.setAttemptedCompletionFunction (Just completeWord)
277 --Readline.parseAndBind "set show-all-if-ambiguous 1"
279 let symbols = "!#$%&*+/<=>?@\\^|-~"
280 specials = "(),;[]`{}"
282 word_break_chars = spaces ++ specials ++ symbols
284 Readline.setBasicWordBreakCharacters word_break_chars
285 Readline.setCompleterWordBreakCharacters word_break_chars
288 default_editor <- findEditor
290 startGHCi (runGHCi srcs maybe_expr)
291 GHCiState{ progname = "<interactive>",
295 editor = default_editor,
301 tickarrays = emptyModuleEnv,
306 Readline.resetTerminal Nothing
311 prel_name = GHC.mkModuleName "Prelude"
313 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
314 runGHCi paths maybe_expr = do
315 let read_dot_files = not opt_IgnoreDotGhci
317 when (read_dot_files) $ do
320 exists <- io (doesFileExist file)
322 dir_ok <- io (checkPerms ".")
323 file_ok <- io (checkPerms file)
324 when (dir_ok && file_ok) $ do
325 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
328 Right hdl -> fileLoop hdl False
330 when (read_dot_files) $ do
331 -- Read in $HOME/.ghci
332 either_dir <- io (IO.try (getEnv "HOME"))
336 cwd <- io (getCurrentDirectory)
337 when (dir /= cwd) $ do
338 let file = dir ++ "/.ghci"
339 ok <- io (checkPerms file)
341 either_hdl <- io (IO.try (openFile file ReadMode))
344 Right hdl -> fileLoop hdl False
346 -- Perform a :load for files given on the GHCi command line
347 -- When in -e mode, if the load fails then we want to stop
348 -- immediately rather than going on to evaluate the expression.
349 when (not (null paths)) $ do
350 ok <- ghciHandle (\e -> do showException e; return Failed) $
352 when (isJust maybe_expr && failed ok) $
353 io (exitWith (ExitFailure 1))
355 -- if verbosity is greater than 0, or we are connected to a
356 -- terminal, display the prompt in the interactive loop.
357 is_tty <- io (hIsTerminalDevice stdin)
358 dflags <- getDynFlags
359 let show_prompt = verbosity dflags > 0 || is_tty
364 #if defined(mingw32_HOST_OS)
365 -- The win32 Console API mutates the first character of
366 -- type-ahead when reading from it in a non-buffered manner. Work
367 -- around this by flushing the input buffer of type-ahead characters,
368 -- but only if stdin is available.
369 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
371 Left err | isDoesNotExistError err -> return ()
372 | otherwise -> io (ioError err)
373 Right () -> return ()
375 -- initialise the console if necessary
378 -- enter the interactive loop
379 interactiveLoop is_tty show_prompt
381 -- just evaluate the expression we were given
386 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
389 interactiveLoop is_tty show_prompt =
390 -- Ignore ^C exceptions caught here
391 ghciHandleDyn (\e -> case e of
393 #if defined(mingw32_HOST_OS)
396 interactiveLoop is_tty show_prompt
397 _other -> return ()) $
399 ghciUnblock $ do -- unblock necessary if we recursed from the
400 -- exception handler above.
402 -- read commands from stdin
406 else fileLoop stdin show_prompt
408 fileLoop stdin show_prompt
412 -- NOTE: We only read .ghci files if they are owned by the current user,
413 -- and aren't world writable. Otherwise, we could be accidentally
414 -- running code planted by a malicious third party.
416 -- Furthermore, We only read ./.ghci if . is owned by the current user
417 -- and isn't writable by anyone else. I think this is sufficient: we
418 -- don't need to check .. and ../.. etc. because "." always refers to
419 -- the same directory while a process is running.
421 checkPerms :: String -> IO Bool
423 #ifdef mingw32_HOST_OS
426 Util.handle (\_ -> return False) $ do
427 st <- getFileStatus name
429 if fileOwner st /= me then do
430 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
433 let mode = fileMode st
434 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
435 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
437 putStrLn $ "*** WARNING: " ++ name ++
438 " is writable by someone else, IGNORING!"
443 fileLoop :: Handle -> Bool -> GHCi ()
444 fileLoop hdl show_prompt = do
445 when show_prompt $ do
448 l <- io (IO.try (hGetLine hdl))
450 Left e | isEOFError e -> return ()
451 | InvalidArgument <- etype -> return ()
452 | otherwise -> io (ioError e)
453 where etype = ioeGetErrorType e
454 -- treat InvalidArgument in the same way as EOF:
455 -- this can happen if the user closed stdin, or
456 -- perhaps did getContents which closes stdin at
459 case removeSpaces l of
460 "" -> fileLoop hdl show_prompt
461 l -> do quit <- runCommands l
462 if quit then return () else fileLoop hdl show_prompt
465 session <- getSession
466 (toplevs,exports) <- io (GHC.getContext session)
467 resumes <- io $ GHC.getResumeContext session
473 let ix = GHC.resumeHistoryIx r
475 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
477 let hist = GHC.resumeHistory r !! (ix-1)
478 span <- io$ GHC.getHistorySpan session hist
479 return (brackets (ppr (negate ix) <> char ':'
480 <+> ppr span) <> space)
482 dots | r:rs <- resumes, not (null rs) = text "... "
486 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
487 hsep (map (ppr . GHC.moduleName) exports)
489 deflt_prompt = dots <> context_bit <> modules_bit
491 f ('%':'s':xs) = deflt_prompt <> f xs
492 f ('%':'%':xs) = char '%' <> f xs
493 f (x:xs) = char x <> f xs
497 return (showSDoc (f (prompt st)))
501 readlineLoop :: GHCi ()
503 session <- getSession
504 (mod,imports) <- io (GHC.getContext session)
506 saveSession -- for use by completion
508 mb_span <- getCurrentBreakSpan
510 l <- io (readline prompt `finally` setNonBlockingFD 0)
511 -- readline sometimes puts stdin into blocking mode,
512 -- so we need to put it back for the IO library
517 case removeSpaces l of
521 quit <- runCommands l
522 if quit then return () else readlineLoop
525 runCommands :: String -> GHCi Bool
527 q <- ghciHandle handler (doCommand cmd)
528 if q then return True else runNext
534 c:cs -> do setGHCiState st{ cmdqueue = cs }
537 doCommand (':' : cmd) = specialCommand cmd
538 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
541 enqueueCommands :: [String] -> GHCi ()
542 enqueueCommands cmds = do
544 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
547 -- This version is for the GHC command-line option -e. The only difference
548 -- from runCommand is that it catches the ExitException exception and
549 -- exits, rather than printing out the exception.
550 runCommandEval c = ghciHandle handleEval (doCommand c)
552 handleEval (ExitException code) = io (exitWith code)
553 handleEval e = do handler e
554 io (exitWith (ExitFailure 1))
556 doCommand (':' : command) = specialCommand command
558 = do r <- runStmt stmt GHC.RunToCompletion
560 False -> io (exitWith (ExitFailure 1))
561 -- failure to run the command causes exit(1) for ghc -e.
564 runStmt :: String -> SingleStep -> GHCi Bool
566 | null (filter (not.isSpace) stmt) = return False
567 | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
569 = do st <- getGHCiState
570 session <- getSession
571 result <- io $ withProgName (progname st) $ withArgs (args st) $
572 GHC.runStmt session stmt step
573 afterRunStmt (const True) result
576 --afterRunStmt :: GHC.RunResult -> GHCi Bool
577 -- False <=> the statement failed to compile
578 afterRunStmt _ (GHC.RunException e) = throw e
579 afterRunStmt step_here run_result = do
580 session <- getSession
581 resumes <- io $ GHC.getResumeContext session
583 GHC.RunOk names -> do
584 show_types <- isOptionSet ShowType
585 when show_types $ printTypeOfNames session names
586 GHC.RunBreak _ names mb_info
587 | isNothing mb_info ||
588 step_here (GHC.resumeSpan $ head resumes) -> do
589 printForUser $ ptext SLIT("Stopped at") <+>
590 ppr (GHC.resumeSpan $ head resumes)
591 -- printTypeOfNames session names
592 printTypeAndContentOfNames session names
593 maybe (return ()) runBreakCmd mb_info
594 -- run the command set with ":set stop <cmd>"
596 enqueueCommands [stop st]
598 | otherwise -> io(GHC.resume session GHC.SingleStep) >>=
599 afterRunStmt step_here >> return ()
603 io installSignalHandlers
604 b <- isOptionSet RevertCAFs
605 io (when b revertCAFs)
607 return (case run_result of GHC.RunOk _ -> True; _ -> False)
609 where printTypeAndContentOfNames session names = do
610 let namesSorted = sortBy compareNames names
611 tythings <- catMaybes `liftM`
612 io (mapM (GHC.lookupName session) namesSorted)
613 let ids = [id | AnId id <- tythings]
614 terms <- mapM (io . GHC.obtainTermB session 10 False) ids
615 docs_terms <- mapM (io . showTerm session) terms
616 dflags <- getDynFlags
617 let pefas = dopt Opt_PrintExplicitForalls dflags
618 printForUser $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts)
619 (map (pprTyThing pefas . AnId) ids)
622 runBreakCmd :: GHC.BreakInfo -> GHCi ()
623 runBreakCmd info = do
624 let mod = GHC.breakInfo_module info
625 nm = GHC.breakInfo_number info
627 case [ loc | (i,loc) <- breaks st,
628 breakModule loc == mod, breakTick loc == nm ] of
630 loc:_ | null cmd -> return ()
631 | otherwise -> do enqueueCommands [cmd]; return ()
632 where cmd = onBreakCmd loc
634 printTypeOfNames :: Session -> [Name] -> GHCi ()
635 printTypeOfNames session names
636 = mapM_ (printTypeOfName session) $ sortBy compareNames names
638 compareNames :: Name -> Name -> Ordering
639 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
640 where compareWith n = (getOccString n, getSrcSpan n)
642 printTypeOfName :: Session -> Name -> GHCi ()
643 printTypeOfName session n
644 = do maybe_tything <- io (GHC.lookupName session n)
645 case maybe_tything of
647 Just thing -> printTyThing thing
649 specialCommand :: String -> GHCi Bool
650 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
651 specialCommand str = do
652 let (cmd,rest) = break isSpace str
653 maybe_cmd <- io (lookupCommand cmd)
655 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
656 ++ shortHelpText) >> return False)
657 Just (_,f,_,_) -> f (dropWhile isSpace rest)
659 lookupCommand :: String -> IO (Maybe Command)
660 lookupCommand str = do
661 cmds <- readIORef commands
662 -- look for exact match first, then the first prefix match
663 case [ c | c <- cmds, str == cmdName c ] of
664 c:_ -> return (Just c)
665 [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
667 c:_ -> return (Just c)
670 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
671 getCurrentBreakSpan = do
672 session <- getSession
673 resumes <- io $ GHC.getResumeContext session
677 let ix = GHC.resumeHistoryIx r
679 then return (Just (GHC.resumeSpan r))
681 let hist = GHC.resumeHistory r !! (ix-1)
682 span <- io $ GHC.getHistorySpan session hist
685 getCurrentBreakModule :: GHCi (Maybe Module)
686 getCurrentBreakModule = do
687 session <- getSession
688 resumes <- io $ GHC.getResumeContext session
692 let ix = GHC.resumeHistoryIx r
694 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
696 let hist = GHC.resumeHistory r !! (ix-1)
697 return $ Just $ GHC.getHistoryModule hist
699 -----------------------------------------------------------------------------
702 noArgs :: GHCi () -> String -> GHCi ()
704 noArgs m _ = io $ putStrLn "This command takes no arguments"
706 help :: String -> GHCi ()
707 help _ = io (putStr helpText)
709 info :: String -> GHCi ()
710 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
711 info s = do { let names = words s
712 ; session <- getSession
713 ; dflags <- getDynFlags
714 ; let pefas = dopt Opt_PrintExplicitForalls dflags
715 ; mapM_ (infoThing pefas session) names }
717 infoThing pefas session str = io $ do
718 names <- GHC.parseName session str
719 mb_stuffs <- mapM (GHC.getInfo session) names
720 let filtered = filterOutChildren (\(t,f,i) -> t) (catMaybes mb_stuffs)
721 unqual <- GHC.getPrintUnqual session
722 putStrLn (showSDocForUser unqual $
723 vcat (intersperse (text "") $
724 map (pprInfo pefas) filtered))
726 -- Filter out names whose parent is also there Good
727 -- example is '[]', which is both a type and data
728 -- constructor in the same type
729 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
730 filterOutChildren get_thing xs
731 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
733 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
735 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
736 pprInfo pefas (thing, fixity, insts)
737 = pprTyThingInContextLoc pefas thing
738 $$ show_fixity fixity
739 $$ vcat (map GHC.pprInstance insts)
742 | fix == GHC.defaultFixity = empty
743 | otherwise = ppr fix <+> ppr (GHC.getName thing)
745 runMain :: String -> GHCi ()
747 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
748 enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
750 addModule :: [FilePath] -> GHCi ()
752 io (revertCAFs) -- always revert CAFs on load/add.
753 files <- mapM expandPath files
754 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
755 session <- getSession
756 io (mapM_ (GHC.addTarget session) targets)
757 ok <- io (GHC.load session LoadAllTargets)
760 changeDirectory :: String -> GHCi ()
761 changeDirectory dir = do
762 session <- getSession
763 graph <- io (GHC.getModuleGraph session)
764 when (not (null graph)) $
765 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
766 io (GHC.setTargets session [])
767 io (GHC.load session LoadAllTargets)
768 setContextAfterLoad session []
769 io (GHC.workingDirectoryChanged session)
770 dir <- expandPath dir
771 io (setCurrentDirectory dir)
773 editFile :: String -> GHCi ()
775 do file <- if null str then chooseEditFile else return str
779 $ throwDyn (CmdLineError "editor not set, use :set editor")
780 io $ system (cmd ++ ' ':file)
783 -- The user didn't specify a file so we pick one for them.
784 -- Our strategy is to pick the first module that failed to load,
785 -- or otherwise the first target.
787 -- XXX: Can we figure out what happened if the depndecy analysis fails
788 -- (e.g., because the porgrammeer mistyped the name of a module)?
789 -- XXX: Can we figure out the location of an error to pass to the editor?
790 -- XXX: if we could figure out the list of errors that occured during the
791 -- last load/reaload, then we could start the editor focused on the first
793 chooseEditFile :: GHCi String
795 do session <- getSession
796 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
798 graph <- io (GHC.getModuleGraph session)
799 failed_graph <- filterM hasFailed graph
800 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
802 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
805 case pick (order failed_graph) of
806 Just file -> return file
808 do targets <- io (GHC.getTargets session)
809 case msum (map fromTarget targets) of
810 Just file -> return file
811 Nothing -> throwDyn (CmdLineError "No files to edit.")
813 where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
814 fromTarget _ = Nothing -- when would we get a module target?
816 defineMacro :: String -> GHCi ()
818 let (macro_name, definition) = break isSpace s
819 cmds <- io (readIORef commands)
821 then throwDyn (CmdLineError "invalid macro name")
823 if (macro_name `elem` map cmdName cmds)
824 then throwDyn (CmdLineError
825 ("command '" ++ macro_name ++ "' is already defined"))
828 -- give the expression a type signature, so we can be sure we're getting
829 -- something of the right type.
830 let new_expr = '(' : definition ++ ") :: String -> IO String"
832 -- compile the expression
834 maybe_hv <- io (GHC.compileExpr cms new_expr)
837 Just hv -> io (writeIORef commands --
838 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
840 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
842 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
843 enqueueCommands (lines str)
846 undefineMacro :: String -> GHCi ()
847 undefineMacro macro_name = do
848 cmds <- io (readIORef commands)
849 if (macro_name `elem` map cmdName builtin_commands)
850 then throwDyn (CmdLineError
851 ("command '" ++ macro_name ++ "' cannot be undefined"))
853 if (macro_name `notElem` map cmdName cmds)
854 then throwDyn (CmdLineError
855 ("command '" ++ macro_name ++ "' not defined"))
857 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
859 cmdCmd :: String -> GHCi ()
861 let expr = '(' : str ++ ") :: IO String"
862 session <- getSession
863 maybe_hv <- io (GHC.compileExpr session expr)
867 cmds <- io $ (unsafeCoerce# hv :: IO String)
868 enqueueCommands (lines cmds)
871 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
872 loadModule fs = timeIt (loadModule' fs)
874 loadModule_ :: [FilePath] -> GHCi ()
875 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
877 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
878 loadModule' files = do
879 session <- getSession
882 discardActiveBreakPoints
883 io (GHC.setTargets session [])
884 io (GHC.load session LoadAllTargets)
887 let (filenames, phases) = unzip files
888 exp_filenames <- mapM expandPath filenames
889 let files' = zip exp_filenames phases
890 targets <- io (mapM (uncurry GHC.guessTarget) files')
892 -- NOTE: we used to do the dependency anal first, so that if it
893 -- fails we didn't throw away the current set of modules. This would
894 -- require some re-working of the GHC interface, so we'll leave it
895 -- as a ToDo for now.
897 io (GHC.setTargets session targets)
898 doLoad session LoadAllTargets
900 checkModule :: String -> GHCi ()
902 let modl = GHC.mkModuleName m
903 session <- getSession
904 result <- io (GHC.checkModule session modl False)
906 Nothing -> io $ putStrLn "Nothing"
907 Just r -> io $ putStrLn (showSDoc (
908 case GHC.checkedModuleInfo r of
909 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
911 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
913 (text "global names: " <+> ppr global) $$
914 (text "local names: " <+> ppr local)
916 afterLoad (successIf (isJust result)) session
918 reloadModule :: String -> GHCi ()
920 session <- getSession
921 doLoad session $ if null m then LoadAllTargets
922 else LoadUpTo (GHC.mkModuleName m)
925 doLoad session howmuch = do
926 -- turn off breakpoints before we load: we can't turn them off later, because
927 -- the ModBreaks will have gone away.
928 discardActiveBreakPoints
929 ok <- io (GHC.load session howmuch)
933 afterLoad ok session = do
934 io (revertCAFs) -- always revert CAFs on load.
936 loaded_mods <- getLoadedModules session
937 setContextAfterLoad session loaded_mods
938 modulesLoadedMsg ok (map GHC.ms_mod_name loaded_mods)
940 setContextAfterLoad session [] = do
941 prel_mod <- getPrelude
942 io (GHC.setContext session [] [prel_mod])
943 setContextAfterLoad session ms = do
944 -- load a target if one is available, otherwise load the topmost module.
945 targets <- io (GHC.getTargets session)
946 case [ m | Just m <- map (findTarget ms) targets ] of
948 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
949 load_this (last graph')
954 = case filter (`matches` t) ms of
958 summary `matches` Target (TargetModule m) _
959 = GHC.ms_mod_name summary == m
960 summary `matches` Target (TargetFile f _) _
961 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
962 summary `matches` target
965 load_this summary | m <- GHC.ms_mod summary = do
966 b <- io (GHC.moduleIsInterpreted session m)
967 if b then io (GHC.setContext session [m] [])
969 prel_mod <- getPrelude
970 io (GHC.setContext session [] [prel_mod,m])
973 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
974 modulesLoadedMsg ok mods = do
975 dflags <- getDynFlags
976 when (verbosity dflags > 0) $ do
978 | null mods = text "none."
980 punctuate comma (map ppr mods)) <> text "."
983 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
985 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
988 typeOfExpr :: String -> GHCi ()
990 = do cms <- getSession
991 maybe_ty <- io (GHC.exprType cms str)
994 Just ty -> do dflags <- getDynFlags
995 let pefas = dopt Opt_PrintExplicitForalls dflags
996 printForUser $ text str <+> dcolon
997 <+> pprTypeForUser pefas ty
999 kindOfType :: String -> GHCi ()
1001 = do cms <- getSession
1002 maybe_ty <- io (GHC.typeKind cms str)
1004 Nothing -> return ()
1005 Just ty -> printForUser $ text str <+> dcolon <+> ppr ty
1007 quit :: String -> GHCi Bool
1008 quit _ = return True
1010 shellEscape :: String -> GHCi Bool
1011 shellEscape str = io (system str >> return False)
1013 -----------------------------------------------------------------------------
1014 -- Browsing a module's contents
1016 browseCmd :: String -> GHCi ()
1019 ['*':m] | looksLikeModuleName m -> browseModule m False
1020 [m] | looksLikeModuleName m -> browseModule m True
1021 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1023 browseModule m exports_only = do
1025 modl <- if exports_only then lookupModule m
1026 else wantInterpretedModule m
1028 -- Temporarily set the context to the module we're interested in,
1029 -- just so we can get an appropriate PrintUnqualified
1030 (as,bs) <- io (GHC.getContext s)
1031 prel_mod <- getPrelude
1032 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1033 else GHC.setContext s [modl] [])
1034 unqual <- io (GHC.getPrintUnqual s)
1035 io (GHC.setContext s as bs)
1037 mb_mod_info <- io $ GHC.getModuleInfo s modl
1039 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1042 | exports_only = GHC.modInfoExports mod_info
1043 | otherwise = GHC.modInfoTopLevelScope mod_info
1046 mb_things <- io $ mapM (GHC.lookupName s) names
1047 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1049 dflags <- getDynFlags
1050 let pefas = dopt Opt_PrintExplicitForalls dflags
1051 io (putStrLn (showSDocForUser unqual (
1052 vcat (map (pprTyThingInContext pefas) filtered_things)
1054 -- ToDo: modInfoInstances currently throws an exception for
1055 -- package modules. When it works, we can do this:
1056 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1058 -----------------------------------------------------------------------------
1059 -- Setting the module context
1062 | all sensible mods = fn mods
1063 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1065 (fn, mods) = case str of
1066 '+':stuff -> (addToContext, words stuff)
1067 '-':stuff -> (removeFromContext, words stuff)
1068 stuff -> (newContext, words stuff)
1070 sensible ('*':m) = looksLikeModuleName m
1071 sensible m = looksLikeModuleName m
1073 separate :: Session -> [String] -> [Module] -> [Module]
1074 -> GHCi ([Module],[Module])
1075 separate session [] as bs = return (as,bs)
1076 separate session (('*':str):ms) as bs = do
1077 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1078 b <- io $ GHC.moduleIsInterpreted session m
1079 if b then separate session ms (m:as) bs
1080 else throwDyn (CmdLineError ("module '"
1081 ++ GHC.moduleNameString (GHC.moduleName m)
1082 ++ "' is not interpreted"))
1083 separate session (str:ms) as bs = do
1084 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1085 separate session ms as (m:bs)
1087 newContext :: [String] -> GHCi ()
1088 newContext strs = do
1090 (as,bs) <- separate s strs [] []
1091 prel_mod <- getPrelude
1092 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1093 io $ GHC.setContext s as bs'
1096 addToContext :: [String] -> GHCi ()
1097 addToContext strs = do
1099 (as,bs) <- io $ GHC.getContext s
1101 (new_as,new_bs) <- separate s strs [] []
1103 let as_to_add = new_as \\ (as ++ bs)
1104 bs_to_add = new_bs \\ (as ++ bs)
1106 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1109 removeFromContext :: [String] -> GHCi ()
1110 removeFromContext strs = do
1112 (as,bs) <- io $ GHC.getContext s
1114 (as_to_remove,bs_to_remove) <- separate s strs [] []
1116 let as' = as \\ (as_to_remove ++ bs_to_remove)
1117 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1119 io $ GHC.setContext s as' bs'
1121 ----------------------------------------------------------------------------
1124 -- set options in the interpreter. Syntax is exactly the same as the
1125 -- ghc command line, except that certain options aren't available (-C,
1128 -- This is pretty fragile: most options won't work as expected. ToDo:
1129 -- figure out which ones & disallow them.
1131 setCmd :: String -> GHCi ()
1133 = do st <- getGHCiState
1134 let opts = options st
1135 io $ putStrLn (showSDoc (
1136 text "options currently set: " <>
1139 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1142 = case toArgs str of
1143 ("args":args) -> setArgs args
1144 ("prog":prog) -> setProg prog
1145 ("prompt":prompt) -> setPrompt (after 6)
1146 ("editor":cmd) -> setEditor (after 6)
1147 ("stop":cmd) -> setStop (after 4)
1148 wds -> setOptions wds
1149 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1153 setGHCiState st{ args = args }
1157 setGHCiState st{ progname = prog }
1159 io (hPutStrLn stderr "syntax: :set prog <progname>")
1163 setGHCiState st{ editor = cmd }
1165 setStop str@(c:_) | isDigit c
1166 = do let (nm_str,rest) = break (not.isDigit) str
1169 let old_breaks = breaks st
1170 if all ((/= nm) . fst) old_breaks
1171 then printForUser (text "Breakpoint" <+> ppr nm <+>
1172 text "does not exist")
1174 let new_breaks = map fn old_breaks
1175 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1176 | otherwise = (i,loc)
1177 setGHCiState st{ breaks = new_breaks }
1180 setGHCiState st{ stop = cmd }
1182 setPrompt value = do
1185 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1186 else setGHCiState st{ prompt = remQuotes value }
1188 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1192 do -- first, deal with the GHCi opts (+s, +t, etc.)
1193 let (plus_opts, minus_opts) = partition isPlus wds
1194 mapM_ setOpt plus_opts
1195 -- then, dynamic flags
1196 newDynFlags minus_opts
1198 newDynFlags minus_opts = do
1199 dflags <- getDynFlags
1200 let pkg_flags = packageFlags dflags
1201 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1203 if (not (null leftovers))
1204 then throwDyn (CmdLineError ("unrecognised flags: " ++
1208 new_pkgs <- setDynFlags dflags'
1210 -- if the package flags changed, we should reset the context
1211 -- and link the new packages.
1212 dflags <- getDynFlags
1213 when (packageFlags dflags /= pkg_flags) $ do
1214 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1215 session <- getSession
1216 io (GHC.setTargets session [])
1217 io (GHC.load session LoadAllTargets)
1218 io (linkPackages dflags new_pkgs)
1219 setContextAfterLoad session []
1223 unsetOptions :: String -> GHCi ()
1225 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1226 let opts = words str
1227 (minus_opts, rest1) = partition isMinus opts
1228 (plus_opts, rest2) = partition isPlus rest1
1230 if (not (null rest2))
1231 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1234 mapM_ unsetOpt plus_opts
1236 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1237 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1239 no_flags <- mapM no_flag minus_opts
1240 newDynFlags no_flags
1242 isMinus ('-':s) = True
1245 isPlus ('+':s) = True
1249 = case strToGHCiOpt str of
1250 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1251 Just o -> setOption o
1254 = case strToGHCiOpt str of
1255 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1256 Just o -> unsetOption o
1258 strToGHCiOpt :: String -> (Maybe GHCiOption)
1259 strToGHCiOpt "s" = Just ShowTiming
1260 strToGHCiOpt "t" = Just ShowType
1261 strToGHCiOpt "r" = Just RevertCAFs
1262 strToGHCiOpt _ = Nothing
1264 optToStr :: GHCiOption -> String
1265 optToStr ShowTiming = "s"
1266 optToStr ShowType = "t"
1267 optToStr RevertCAFs = "r"
1269 -- ---------------------------------------------------------------------------
1275 ["args"] -> io $ putStrLn (show (args st))
1276 ["prog"] -> io $ putStrLn (show (progname st))
1277 ["prompt"] -> io $ putStrLn (show (prompt st))
1278 ["editor"] -> io $ putStrLn (show (editor st))
1279 ["stop"] -> io $ putStrLn (show (stop st))
1280 ["modules" ] -> showModules
1281 ["bindings"] -> showBindings
1282 ["linker"] -> io showLinkerState
1283 ["breaks"] -> showBkptTable
1284 ["context"] -> showContext
1285 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1288 session <- getSession
1289 loaded_mods <- getLoadedModules session
1290 -- we want *loaded* modules only, see #1734
1291 let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m)
1292 mapM_ show_one loaded_mods
1294 getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary]
1295 getLoadedModules session = do
1296 graph <- io (GHC.getModuleGraph session)
1297 filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
1301 unqual <- io (GHC.getPrintUnqual s)
1302 bindings <- io (GHC.getBindings s)
1303 mapM_ printTyThing $ sortBy compareTyThings bindings
1306 compareTyThings :: TyThing -> TyThing -> Ordering
1307 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1309 printTyThing :: TyThing -> GHCi ()
1310 printTyThing tyth = do dflags <- getDynFlags
1311 let pefas = dopt Opt_PrintExplicitForalls dflags
1312 printForUser (pprTyThing pefas tyth)
1314 showBkptTable :: GHCi ()
1317 printForUser $ prettyLocations (breaks st)
1319 showContext :: GHCi ()
1321 session <- getSession
1322 resumes <- io $ GHC.getResumeContext session
1323 printForUser $ vcat (map pp_resume (reverse resumes))
1326 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1327 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1330 -- -----------------------------------------------------------------------------
1333 completeNone :: String -> IO [String]
1334 completeNone w = return []
1337 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1338 completeWord w start end = do
1339 line <- Readline.getLineBuffer
1340 let line_words = words (dropWhile isSpace line)
1342 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1344 | ((':':c) : _) <- line_words -> do
1345 maybe_cmd <- lookupCommand c
1346 let (n,w') = selectWord (words' 0 line)
1348 Nothing -> return Nothing
1349 Just (_,_,False,complete) -> wrapCompleter complete w
1350 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1351 return (map (drop n) rets)
1352 in wrapCompleter complete' w'
1353 | ("import" : _) <- line_words ->
1354 wrapCompleter completeModule w
1356 --printf "complete %s, start = %d, end = %d\n" w start end
1357 wrapCompleter completeIdentifier w
1358 where words' _ [] = []
1359 words' n str = let (w,r) = break isSpace str
1360 (s,r') = span isSpace r
1361 in (n,w):words' (n+length w+length s) r'
1362 -- In a Haskell expression we want to parse 'a-b' as three words
1363 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1364 -- only be a single word.
1365 selectWord [] = (0,w)
1366 selectWord ((offset,x):xs)
1367 | offset+length x >= start = (start-offset,take (end-offset) x)
1368 | otherwise = selectWord xs
1372 cmds <- readIORef commands
1373 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1375 completeMacro w = do
1376 cmds <- readIORef commands
1377 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1378 return (filter (w `isPrefixOf`) cmds')
1380 completeIdentifier w = do
1382 rdrs <- GHC.getRdrNamesInScope s
1383 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1385 completeModule w = do
1387 dflags <- GHC.getSessionDynFlags s
1388 let pkg_mods = allExposedModules dflags
1389 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1391 completeHomeModule w = do
1393 g <- GHC.getModuleGraph s
1394 let home_mods = map GHC.ms_mod_name g
1395 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1397 completeSetOptions w = do
1398 return (filter (w `isPrefixOf`) options)
1399 where options = "args":"prog":allFlags
1401 completeFilename = Readline.filenameCompletionFunction
1403 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1405 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1406 unionComplete f1 f2 w = do
1411 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1412 wrapCompleter fun w = do
1415 [] -> return Nothing
1416 [x] -> return (Just (x,[]))
1417 xs -> case getCommonPrefix xs of
1418 "" -> return (Just ("",xs))
1419 pref -> return (Just (pref,xs))
1421 getCommonPrefix :: [String] -> String
1422 getCommonPrefix [] = ""
1423 getCommonPrefix (s:ss) = foldl common s ss
1424 where common s "" = ""
1426 common (c:cs) (d:ds)
1427 | c == d = c : common cs ds
1430 allExposedModules :: DynFlags -> [ModuleName]
1431 allExposedModules dflags
1432 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1434 pkg_db = pkgIdMap (pkgState dflags)
1436 completeCmd = completeNone
1437 completeMacro = completeNone
1438 completeIdentifier = completeNone
1439 completeModule = completeNone
1440 completeHomeModule = completeNone
1441 completeSetOptions = completeNone
1442 completeFilename = completeNone
1443 completeHomeModuleOrFile=completeNone
1444 completeBkpt = completeNone
1447 -- ---------------------------------------------------------------------------
1448 -- User code exception handling
1450 -- This is the exception handler for exceptions generated by the
1451 -- user's code and exceptions coming from children sessions;
1452 -- it normally just prints out the exception. The
1453 -- handler must be recursive, in case showing the exception causes
1454 -- more exceptions to be raised.
1456 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1457 -- raising another exception. We therefore don't put the recursive
1458 -- handler arond the flushing operation, so if stderr is closed
1459 -- GHCi will just die gracefully rather than going into an infinite loop.
1460 handler :: Exception -> GHCi Bool
1462 handler exception = do
1464 io installSignalHandlers
1465 ghciHandle handler (showException exception >> return False)
1467 showException (DynException dyn) =
1468 case fromDynamic dyn of
1469 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1470 Just Interrupted -> io (putStrLn "Interrupted.")
1471 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1472 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1473 Just other_ghc_ex -> io (print other_ghc_ex)
1475 showException other_exception
1476 = io (putStrLn ("*** Exception: " ++ show other_exception))
1478 -----------------------------------------------------------------------------
1479 -- recursive exception handlers
1481 -- Don't forget to unblock async exceptions in the handler, or if we're
1482 -- in an exception loop (eg. let a = error a in a) the ^C exception
1483 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1485 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1486 ghciHandle h (GHCi m) = GHCi $ \s ->
1487 Exception.catch (m s)
1488 (\e -> unGHCi (ghciUnblock (h e)) s)
1490 ghciUnblock :: GHCi a -> GHCi a
1491 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1494 -- ----------------------------------------------------------------------------
1497 expandPath :: String -> GHCi String
1499 case dropWhile isSpace path of
1501 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1502 return (tilde ++ '/':d)
1506 wantInterpretedModule :: String -> GHCi Module
1507 wantInterpretedModule str = do
1508 session <- getSession
1509 modl <- lookupModule str
1510 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1511 when (not is_interpreted) $
1512 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1515 wantNameFromInterpretedModule noCanDo str and_then = do
1516 session <- getSession
1517 names <- io $ GHC.parseName session str
1521 let modl = GHC.nameModule n
1522 if not (GHC.isExternalName n)
1523 then noCanDo n $ ppr n <>
1524 text " is not defined in an interpreted module"
1526 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1527 if not is_interpreted
1528 then noCanDo n $ text "module " <> ppr modl <>
1529 text " is not interpreted"
1532 -- ----------------------------------------------------------------------------
1533 -- Windows console setup
1535 setUpConsole :: IO ()
1537 #ifdef mingw32_HOST_OS
1538 -- On Windows we need to set a known code page, otherwise the characters
1539 -- we read from the console will be be in some strange encoding, and
1540 -- similarly for characters we write to the console.
1542 -- At the moment, GHCi pretends all input is Latin-1. In the
1543 -- future we should support UTF-8, but for now we set the code
1544 -- pages to Latin-1. Doing it this way does lead to problems,
1545 -- however: see bug #1649.
1547 -- It seems you have to set the font in the console window to
1548 -- a Unicode font in order for output to work properly,
1549 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1550 -- (see MSDN for SetConsoleOutputCP()).
1552 -- This call has been known to hang on some machines, see bug #1483
1554 setConsoleCP 28591 -- ISO Latin-1
1555 setConsoleOutputCP 28591 -- ISO Latin-1
1559 -- -----------------------------------------------------------------------------
1560 -- commands for debugger
1562 sprintCmd = pprintCommand False False
1563 printCmd = pprintCommand True False
1564 forceCmd = pprintCommand False True
1566 pprintCommand bind force str = do
1567 session <- getSession
1568 io $ pprintClosureCommand session bind force str
1570 stepCmd :: String -> GHCi ()
1571 stepCmd [] = doContinue (const True) GHC.SingleStep
1572 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1574 stepLocalCmd :: String -> GHCi ()
1575 stepLocalCmd [] = do
1576 mb_span <- getCurrentBreakSpan
1578 Nothing -> stepCmd []
1580 Just mod <- getCurrentBreakModule
1581 current_toplevel_decl <- enclosingTickSpan mod loc
1582 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1584 stepLocalCmd expression = stepCmd expression
1586 stepModuleCmd :: String -> GHCi ()
1587 stepModuleCmd [] = do
1588 mb_span <- getCurrentBreakSpan
1590 Nothing -> stepCmd []
1592 Just span <- getCurrentBreakSpan
1593 let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
1594 doContinue f GHC.SingleStep
1596 stepModuleCmd expression = stepCmd expression
1598 -- | Returns the span of the largest tick containing the srcspan given
1599 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1600 enclosingTickSpan mod src = do
1601 ticks <- getTickArray mod
1602 let line = srcSpanStartLine src
1603 ASSERT (inRange (bounds ticks) line) do
1604 let enclosing_spans = [ span | (_,span) <- ticks ! line
1605 , srcSpanEnd span >= srcSpanEnd src]
1606 return . head . sortBy leftmost_largest $ enclosing_spans
1608 traceCmd :: String -> GHCi ()
1609 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1610 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1612 continueCmd :: String -> GHCi ()
1613 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1615 -- doContinue :: SingleStep -> GHCi ()
1616 doContinue pred step = do
1617 session <- getSession
1618 runResult <- io $ GHC.resume session step
1619 afterRunStmt pred runResult
1622 abandonCmd :: String -> GHCi ()
1623 abandonCmd = noArgs $ do
1625 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1626 when (not b) $ io $ putStrLn "There is no computation running."
1629 deleteCmd :: String -> GHCi ()
1630 deleteCmd argLine = do
1631 deleteSwitch $ words argLine
1633 deleteSwitch :: [String] -> GHCi ()
1635 io $ putStrLn "The delete command requires at least one argument."
1636 -- delete all break points
1637 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1638 deleteSwitch idents = do
1639 mapM_ deleteOneBreak idents
1641 deleteOneBreak :: String -> GHCi ()
1643 | all isDigit str = deleteBreak (read str)
1644 | otherwise = return ()
1646 historyCmd :: String -> GHCi ()
1648 | null arg = history 20
1649 | all isDigit arg = history (read arg)
1650 | otherwise = io $ putStrLn "Syntax: :history [num]"
1654 resumes <- io $ GHC.getResumeContext s
1656 [] -> io $ putStrLn "Not stopped at a breakpoint"
1658 let hist = GHC.resumeHistory r
1659 (took,rest) = splitAt num hist
1660 spans <- mapM (io . GHC.getHistorySpan s) took
1661 let nums = map (printf "-%-3d:") [(1::Int)..]
1662 let names = map GHC.historyEnclosingDecl took
1663 printForUser (vcat(zipWith3
1664 (\x y z -> x <+> y <+> z)
1666 (map (bold . ppr) names)
1667 (map (parens . ppr) spans)))
1668 io $ putStrLn $ if null rest then "<end of history>" else "..."
1670 bold c | do_bold = text start_bold <> c <> text end_bold
1673 backCmd :: String -> GHCi ()
1674 backCmd = noArgs $ do
1676 (names, ix, span) <- io $ GHC.back s
1677 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1678 printTypeOfNames s names
1679 -- run the command set with ":set stop <cmd>"
1681 enqueueCommands [stop st]
1683 forwardCmd :: String -> GHCi ()
1684 forwardCmd = noArgs $ do
1686 (names, ix, span) <- io $ GHC.forward s
1687 printForUser $ (if (ix == 0)
1688 then ptext SLIT("Stopped at")
1689 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1690 printTypeOfNames s names
1691 -- run the command set with ":set stop <cmd>"
1693 enqueueCommands [stop st]
1695 -- handle the "break" command
1696 breakCmd :: String -> GHCi ()
1697 breakCmd argLine = do
1698 session <- getSession
1699 breakSwitch session $ words argLine
1701 breakSwitch :: Session -> [String] -> GHCi ()
1702 breakSwitch _session [] = do
1703 io $ putStrLn "The break command requires at least one argument."
1704 breakSwitch session args@(arg1:rest)
1705 | looksLikeModuleName arg1 = do
1706 mod <- wantInterpretedModule arg1
1707 breakByModule session mod rest
1708 | all isDigit arg1 = do
1709 (toplevel, _) <- io $ GHC.getContext session
1711 (mod : _) -> breakByModuleLine mod (read arg1) rest
1713 io $ putStrLn "Cannot find default module for breakpoint."
1714 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1715 | otherwise = do -- try parsing it as an identifier
1716 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1717 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1718 if GHC.isGoodSrcLoc loc
1719 then findBreakAndSet (GHC.nameModule name) $
1720 findBreakByCoord (Just (GHC.srcLocFile loc))
1721 (GHC.srcLocLine loc,
1723 else noCanDo name $ text "can't find its location: " <> ppr loc
1725 noCanDo n why = printForUser $
1726 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1728 breakByModule :: Session -> Module -> [String] -> GHCi ()
1729 breakByModule session mod args@(arg1:rest)
1730 | all isDigit arg1 = do -- looks like a line number
1731 breakByModuleLine mod (read arg1) rest
1732 breakByModule session mod _
1735 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1736 breakByModuleLine mod line args
1737 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1738 | [col] <- args, all isDigit col =
1739 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1740 | otherwise = breakSyntax
1742 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1744 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1745 findBreakAndSet mod lookupTickTree = do
1746 tickArray <- getTickArray mod
1747 (breakArray, _) <- getModBreak mod
1748 case lookupTickTree tickArray of
1749 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1750 Just (tick, span) -> do
1751 success <- io $ setBreakFlag True breakArray tick
1752 session <- getSession
1756 recordBreak $ BreakLocation
1763 text "Breakpoint " <> ppr nm <>
1765 then text " was already set at " <> ppr span
1766 else text " activated at " <> ppr span
1768 printForUser $ text "Breakpoint could not be activated at"
1771 -- When a line number is specified, the current policy for choosing
1772 -- the best breakpoint is this:
1773 -- - the leftmost complete subexpression on the specified line, or
1774 -- - the leftmost subexpression starting on the specified line, or
1775 -- - the rightmost subexpression enclosing the specified line
1777 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1778 findBreakByLine line arr
1779 | not (inRange (bounds arr) line) = Nothing
1781 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
1782 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
1783 listToMaybe (sortBy (rightmost `on` snd) ticks)
1787 starts_here = [ tick | tick@(nm,span) <- ticks,
1788 GHC.srcSpanStartLine span == line ]
1790 (complete,incomplete) = partition ends_here starts_here
1791 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1793 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1794 -> Maybe (BreakIndex,SrcSpan)
1795 findBreakByCoord mb_file (line, col) arr
1796 | not (inRange (bounds arr) line) = Nothing
1798 listToMaybe (sortBy (rightmost `on` snd) contains ++
1799 sortBy (leftmost_smallest `on` snd) after_here)
1803 -- the ticks that span this coordinate
1804 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1805 is_correct_file span ]
1807 is_correct_file span
1808 | Just f <- mb_file = GHC.srcSpanFile span == f
1811 after_here = [ tick | tick@(nm,span) <- ticks,
1812 GHC.srcSpanStartLine span == line,
1813 GHC.srcSpanStartCol span >= col ]
1815 -- For now, use ANSI bold on terminals that we know support it.
1816 -- Otherwise, we add a line of carets under the active expression instead.
1817 -- In particular, on Windows and when running the testsuite (which sets
1818 -- TERM to vt100 for other reasons) we get carets.
1819 -- We really ought to use a proper termcap/terminfo library.
1821 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
1822 where mTerm = System.Environment.getEnv "TERM"
1823 `Exception.catch` \e -> return "TERM not set"
1825 start_bold :: String
1826 start_bold = "\ESC[1m"
1828 end_bold = "\ESC[0m"
1830 listCmd :: String -> GHCi ()
1832 mb_span <- getCurrentBreakSpan
1834 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1835 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1836 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
1837 listCmd str = list2 (words str)
1839 list2 [arg] | all isDigit arg = do
1840 session <- getSession
1841 (toplevel, _) <- io $ GHC.getContext session
1843 [] -> io $ putStrLn "No module to list"
1844 (mod : _) -> listModuleLine mod (read arg)
1845 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1846 mod <- wantInterpretedModule arg1
1847 listModuleLine mod (read arg2)
1849 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1850 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1851 if GHC.isGoodSrcLoc loc
1853 tickArray <- getTickArray (GHC.nameModule name)
1854 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1855 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1858 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1859 Just (_,span) -> io $ listAround span False
1861 noCanDo name $ text "can't find its location: " <>
1864 noCanDo n why = printForUser $
1865 text "cannot list source code for " <> ppr n <> text ": " <> why
1867 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1869 listModuleLine :: Module -> Int -> GHCi ()
1870 listModuleLine modl line = do
1871 session <- getSession
1872 graph <- io (GHC.getModuleGraph session)
1873 let this = filter ((== modl) . GHC.ms_mod) graph
1875 [] -> panic "listModuleLine"
1877 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1878 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1879 io $ listAround (GHC.srcLocSpan loc) False
1881 -- | list a section of a source file around a particular SrcSpan.
1882 -- If the highlight flag is True, also highlight the span using
1883 -- start_bold/end_bold.
1884 listAround span do_highlight = do
1885 contents <- BS.readFile (unpackFS file)
1887 lines = BS.split '\n' contents
1888 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1889 drop (line1 - 1 - pad_before) $ lines
1890 fst_line = max 1 (line1 - pad_before)
1891 line_nos = [ fst_line .. ]
1893 highlighted | do_highlight = zipWith highlight line_nos these_lines
1894 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
1896 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1897 prefixed = zipWith ($) highlighted bs_line_nos
1899 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1901 file = GHC.srcSpanFile span
1902 line1 = GHC.srcSpanStartLine span
1903 col1 = GHC.srcSpanStartCol span
1904 line2 = GHC.srcSpanEndLine span
1905 col2 = GHC.srcSpanEndCol span
1907 pad_before | line1 == 1 = 0
1911 highlight | do_bold = highlight_bold
1912 | otherwise = highlight_carets
1914 highlight_bold no line prefix
1915 | no == line1 && no == line2
1916 = let (a,r) = BS.splitAt col1 line
1917 (b,c) = BS.splitAt (col2-col1) r
1919 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
1921 = let (a,b) = BS.splitAt col1 line in
1922 BS.concat [prefix, a, BS.pack start_bold, b]
1924 = let (a,b) = BS.splitAt col2 line in
1925 BS.concat [prefix, a, BS.pack end_bold, b]
1926 | otherwise = BS.concat [prefix, line]
1928 highlight_carets no line prefix
1929 | no == line1 && no == line2
1930 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
1931 BS.replicate (col2-col1) '^']
1933 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
1936 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
1938 | otherwise = BS.concat [prefix, line]
1940 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
1941 nl = BS.singleton '\n'
1943 -- --------------------------------------------------------------------------
1946 getTickArray :: Module -> GHCi TickArray
1947 getTickArray modl = do
1949 let arrmap = tickarrays st
1950 case lookupModuleEnv arrmap modl of
1951 Just arr -> return arr
1953 (breakArray, ticks) <- getModBreak modl
1954 let arr = mkTickArray (assocs ticks)
1955 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1958 discardTickArrays :: GHCi ()
1959 discardTickArrays = do
1961 setGHCiState st{tickarrays = emptyModuleEnv}
1963 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1965 = accumArray (flip (:)) [] (1, max_line)
1966 [ (line, (nm,span)) | (nm,span) <- ticks,
1967 line <- srcSpanLines span ]
1969 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1970 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1971 GHC.srcSpanEndLine span ]
1973 lookupModule :: String -> GHCi Module
1974 lookupModule modName
1975 = do session <- getSession
1976 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1978 -- don't reset the counter back to zero?
1979 discardActiveBreakPoints :: GHCi ()
1980 discardActiveBreakPoints = do
1982 mapM (turnOffBreak.snd) (breaks st)
1983 setGHCiState $ st { breaks = [] }
1985 deleteBreak :: Int -> GHCi ()
1986 deleteBreak identity = do
1988 let oldLocations = breaks st
1989 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
1991 then printForUser (text "Breakpoint" <+> ppr identity <+>
1992 text "does not exist")
1994 mapM (turnOffBreak.snd) this
1995 setGHCiState $ st { breaks = rest }
1997 turnOffBreak loc = do
1998 (arr, _) <- getModBreak (breakModule loc)
1999 io $ setBreakFlag False arr (breakTick loc)
2001 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2002 getModBreak mod = do
2003 session <- getSession
2004 Just mod_info <- io $ GHC.getModuleInfo session mod
2005 let modBreaks = GHC.modInfoModBreaks mod_info
2006 let array = GHC.modBreaks_flags modBreaks
2007 let ticks = GHC.modBreaks_locs modBreaks
2008 return (array, ticks)
2010 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2011 setBreakFlag toggle array index
2012 | toggle = GHC.setBreakOn array index
2013 | otherwise = GHC.setBreakOff array index