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 graph <- io (GHC.getModuleGraph session)
937 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
938 setContextAfterLoad session graph'
939 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
941 setContextAfterLoad session [] = do
942 prel_mod <- getPrelude
943 io (GHC.setContext session [] [prel_mod])
944 setContextAfterLoad session ms = do
945 -- load a target if one is available, otherwise load the topmost module.
946 targets <- io (GHC.getTargets session)
947 case [ m | Just m <- map (findTarget ms) targets ] of
949 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
950 load_this (last graph')
955 = case filter (`matches` t) ms of
959 summary `matches` Target (TargetModule m) _
960 = GHC.ms_mod_name summary == m
961 summary `matches` Target (TargetFile f _) _
962 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
963 summary `matches` target
966 load_this summary | m <- GHC.ms_mod summary = do
967 b <- io (GHC.moduleIsInterpreted session m)
968 if b then io (GHC.setContext session [m] [])
970 prel_mod <- getPrelude
971 io (GHC.setContext session [] [prel_mod,m])
974 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
975 modulesLoadedMsg ok mods = do
976 dflags <- getDynFlags
977 when (verbosity dflags > 0) $ do
979 | null mods = text "none."
981 punctuate comma (map ppr mods)) <> text "."
984 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
986 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
989 typeOfExpr :: String -> GHCi ()
991 = do cms <- getSession
992 maybe_ty <- io (GHC.exprType cms str)
995 Just ty -> do dflags <- getDynFlags
996 let pefas = dopt Opt_PrintExplicitForalls dflags
997 printForUser $ text str <+> dcolon
998 <+> pprTypeForUser pefas ty
1000 kindOfType :: String -> GHCi ()
1002 = do cms <- getSession
1003 maybe_ty <- io (GHC.typeKind cms str)
1005 Nothing -> return ()
1006 Just ty -> printForUser $ text str <+> dcolon <+> ppr ty
1008 quit :: String -> GHCi Bool
1009 quit _ = return True
1011 shellEscape :: String -> GHCi Bool
1012 shellEscape str = io (system str >> return False)
1014 -----------------------------------------------------------------------------
1015 -- Browsing a module's contents
1017 browseCmd :: String -> GHCi ()
1020 ['*':m] | looksLikeModuleName m -> browseModule m False
1021 [m] | looksLikeModuleName m -> browseModule m True
1022 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1024 browseModule m exports_only = do
1026 modl <- if exports_only then lookupModule m
1027 else wantInterpretedModule m
1029 -- Temporarily set the context to the module we're interested in,
1030 -- just so we can get an appropriate PrintUnqualified
1031 (as,bs) <- io (GHC.getContext s)
1032 prel_mod <- getPrelude
1033 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1034 else GHC.setContext s [modl] [])
1035 unqual <- io (GHC.getPrintUnqual s)
1036 io (GHC.setContext s as bs)
1038 mb_mod_info <- io $ GHC.getModuleInfo s modl
1040 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1043 | exports_only = GHC.modInfoExports mod_info
1044 | otherwise = GHC.modInfoTopLevelScope mod_info
1047 mb_things <- io $ mapM (GHC.lookupName s) names
1048 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1050 dflags <- getDynFlags
1051 let pefas = dopt Opt_PrintExplicitForalls dflags
1052 io (putStrLn (showSDocForUser unqual (
1053 vcat (map (pprTyThingInContext pefas) filtered_things)
1055 -- ToDo: modInfoInstances currently throws an exception for
1056 -- package modules. When it works, we can do this:
1057 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1059 -----------------------------------------------------------------------------
1060 -- Setting the module context
1063 | all sensible mods = fn mods
1064 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1066 (fn, mods) = case str of
1067 '+':stuff -> (addToContext, words stuff)
1068 '-':stuff -> (removeFromContext, words stuff)
1069 stuff -> (newContext, words stuff)
1071 sensible ('*':m) = looksLikeModuleName m
1072 sensible m = looksLikeModuleName m
1074 separate :: Session -> [String] -> [Module] -> [Module]
1075 -> GHCi ([Module],[Module])
1076 separate session [] as bs = return (as,bs)
1077 separate session (('*':str):ms) as bs = do
1078 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1079 b <- io $ GHC.moduleIsInterpreted session m
1080 if b then separate session ms (m:as) bs
1081 else throwDyn (CmdLineError ("module '"
1082 ++ GHC.moduleNameString (GHC.moduleName m)
1083 ++ "' is not interpreted"))
1084 separate session (str:ms) as bs = do
1085 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1086 separate session ms as (m:bs)
1088 newContext :: [String] -> GHCi ()
1089 newContext strs = do
1091 (as,bs) <- separate s strs [] []
1092 prel_mod <- getPrelude
1093 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1094 io $ GHC.setContext s as bs'
1097 addToContext :: [String] -> GHCi ()
1098 addToContext strs = do
1100 (as,bs) <- io $ GHC.getContext s
1102 (new_as,new_bs) <- separate s strs [] []
1104 let as_to_add = new_as \\ (as ++ bs)
1105 bs_to_add = new_bs \\ (as ++ bs)
1107 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1110 removeFromContext :: [String] -> GHCi ()
1111 removeFromContext strs = do
1113 (as,bs) <- io $ GHC.getContext s
1115 (as_to_remove,bs_to_remove) <- separate s strs [] []
1117 let as' = as \\ (as_to_remove ++ bs_to_remove)
1118 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1120 io $ GHC.setContext s as' bs'
1122 ----------------------------------------------------------------------------
1125 -- set options in the interpreter. Syntax is exactly the same as the
1126 -- ghc command line, except that certain options aren't available (-C,
1129 -- This is pretty fragile: most options won't work as expected. ToDo:
1130 -- figure out which ones & disallow them.
1132 setCmd :: String -> GHCi ()
1134 = do st <- getGHCiState
1135 let opts = options st
1136 io $ putStrLn (showSDoc (
1137 text "options currently set: " <>
1140 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1143 = case toArgs str of
1144 ("args":args) -> setArgs args
1145 ("prog":prog) -> setProg prog
1146 ("prompt":prompt) -> setPrompt (after 6)
1147 ("editor":cmd) -> setEditor (after 6)
1148 ("stop":cmd) -> setStop (after 4)
1149 wds -> setOptions wds
1150 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1154 setGHCiState st{ args = args }
1158 setGHCiState st{ progname = prog }
1160 io (hPutStrLn stderr "syntax: :set prog <progname>")
1164 setGHCiState st{ editor = cmd }
1166 setStop str@(c:_) | isDigit c
1167 = do let (nm_str,rest) = break (not.isDigit) str
1170 let old_breaks = breaks st
1171 if all ((/= nm) . fst) old_breaks
1172 then printForUser (text "Breakpoint" <+> ppr nm <+>
1173 text "does not exist")
1175 let new_breaks = map fn old_breaks
1176 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1177 | otherwise = (i,loc)
1178 setGHCiState st{ breaks = new_breaks }
1181 setGHCiState st{ stop = cmd }
1183 setPrompt value = do
1186 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1187 else setGHCiState st{ prompt = remQuotes value }
1189 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1193 do -- first, deal with the GHCi opts (+s, +t, etc.)
1194 let (plus_opts, minus_opts) = partition isPlus wds
1195 mapM_ setOpt plus_opts
1196 -- then, dynamic flags
1197 newDynFlags minus_opts
1199 newDynFlags minus_opts = do
1200 dflags <- getDynFlags
1201 let pkg_flags = packageFlags dflags
1202 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1204 if (not (null leftovers))
1205 then throwDyn (CmdLineError ("unrecognised flags: " ++
1209 new_pkgs <- setDynFlags dflags'
1211 -- if the package flags changed, we should reset the context
1212 -- and link the new packages.
1213 dflags <- getDynFlags
1214 when (packageFlags dflags /= pkg_flags) $ do
1215 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1216 session <- getSession
1217 io (GHC.setTargets session [])
1218 io (GHC.load session LoadAllTargets)
1219 io (linkPackages dflags new_pkgs)
1220 setContextAfterLoad session []
1224 unsetOptions :: String -> GHCi ()
1226 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1227 let opts = words str
1228 (minus_opts, rest1) = partition isMinus opts
1229 (plus_opts, rest2) = partition isPlus rest1
1231 if (not (null rest2))
1232 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1235 mapM_ unsetOpt plus_opts
1237 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1238 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1240 no_flags <- mapM no_flag minus_opts
1241 newDynFlags no_flags
1243 isMinus ('-':s) = True
1246 isPlus ('+':s) = True
1250 = case strToGHCiOpt str of
1251 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1252 Just o -> setOption o
1255 = case strToGHCiOpt str of
1256 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1257 Just o -> unsetOption o
1259 strToGHCiOpt :: String -> (Maybe GHCiOption)
1260 strToGHCiOpt "s" = Just ShowTiming
1261 strToGHCiOpt "t" = Just ShowType
1262 strToGHCiOpt "r" = Just RevertCAFs
1263 strToGHCiOpt _ = Nothing
1265 optToStr :: GHCiOption -> String
1266 optToStr ShowTiming = "s"
1267 optToStr ShowType = "t"
1268 optToStr RevertCAFs = "r"
1270 -- ---------------------------------------------------------------------------
1276 ["args"] -> io $ putStrLn (show (args st))
1277 ["prog"] -> io $ putStrLn (show (progname st))
1278 ["prompt"] -> io $ putStrLn (show (prompt st))
1279 ["editor"] -> io $ putStrLn (show (editor st))
1280 ["stop"] -> io $ putStrLn (show (stop st))
1281 ["modules" ] -> showModules
1282 ["bindings"] -> showBindings
1283 ["linker"] -> io showLinkerState
1284 ["breaks"] -> showBkptTable
1285 ["context"] -> showContext
1286 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1289 session <- getSession
1290 let show_one ms = do m <- io (GHC.showModule session ms)
1292 graph <- io (GHC.getModuleGraph session)
1293 mapM_ show_one graph
1297 unqual <- io (GHC.getPrintUnqual s)
1298 bindings <- io (GHC.getBindings s)
1299 mapM_ printTyThing $ sortBy compareTyThings bindings
1302 compareTyThings :: TyThing -> TyThing -> Ordering
1303 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1305 printTyThing :: TyThing -> GHCi ()
1306 printTyThing tyth = do dflags <- getDynFlags
1307 let pefas = dopt Opt_PrintExplicitForalls dflags
1308 printForUser (pprTyThing pefas tyth)
1310 showBkptTable :: GHCi ()
1313 printForUser $ prettyLocations (breaks st)
1315 showContext :: GHCi ()
1317 session <- getSession
1318 resumes <- io $ GHC.getResumeContext session
1319 printForUser $ vcat (map pp_resume (reverse resumes))
1322 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1323 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1326 -- -----------------------------------------------------------------------------
1329 completeNone :: String -> IO [String]
1330 completeNone w = return []
1333 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1334 completeWord w start end = do
1335 line <- Readline.getLineBuffer
1336 let line_words = words (dropWhile isSpace line)
1338 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1340 | ((':':c) : _) <- line_words -> do
1341 maybe_cmd <- lookupCommand c
1342 let (n,w') = selectWord (words' 0 line)
1344 Nothing -> return Nothing
1345 Just (_,_,False,complete) -> wrapCompleter complete w
1346 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1347 return (map (drop n) rets)
1348 in wrapCompleter complete' w'
1349 | ("import" : _) <- line_words ->
1350 wrapCompleter completeModule w
1352 --printf "complete %s, start = %d, end = %d\n" w start end
1353 wrapCompleter completeIdentifier w
1354 where words' _ [] = []
1355 words' n str = let (w,r) = break isSpace str
1356 (s,r') = span isSpace r
1357 in (n,w):words' (n+length w+length s) r'
1358 -- In a Haskell expression we want to parse 'a-b' as three words
1359 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1360 -- only be a single word.
1361 selectWord [] = (0,w)
1362 selectWord ((offset,x):xs)
1363 | offset+length x >= start = (start-offset,take (end-offset) x)
1364 | otherwise = selectWord xs
1368 cmds <- readIORef commands
1369 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1371 completeMacro w = do
1372 cmds <- readIORef commands
1373 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1374 return (filter (w `isPrefixOf`) cmds')
1376 completeIdentifier w = do
1378 rdrs <- GHC.getRdrNamesInScope s
1379 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1381 completeModule w = do
1383 dflags <- GHC.getSessionDynFlags s
1384 let pkg_mods = allExposedModules dflags
1385 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1387 completeHomeModule w = do
1389 g <- GHC.getModuleGraph s
1390 let home_mods = map GHC.ms_mod_name g
1391 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1393 completeSetOptions w = do
1394 return (filter (w `isPrefixOf`) options)
1395 where options = "args":"prog":allFlags
1397 completeFilename = Readline.filenameCompletionFunction
1399 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1401 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1402 unionComplete f1 f2 w = do
1407 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1408 wrapCompleter fun w = do
1411 [] -> return Nothing
1412 [x] -> return (Just (x,[]))
1413 xs -> case getCommonPrefix xs of
1414 "" -> return (Just ("",xs))
1415 pref -> return (Just (pref,xs))
1417 getCommonPrefix :: [String] -> String
1418 getCommonPrefix [] = ""
1419 getCommonPrefix (s:ss) = foldl common s ss
1420 where common s "" = ""
1422 common (c:cs) (d:ds)
1423 | c == d = c : common cs ds
1426 allExposedModules :: DynFlags -> [ModuleName]
1427 allExposedModules dflags
1428 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1430 pkg_db = pkgIdMap (pkgState dflags)
1432 completeCmd = completeNone
1433 completeMacro = completeNone
1434 completeIdentifier = completeNone
1435 completeModule = completeNone
1436 completeHomeModule = completeNone
1437 completeSetOptions = completeNone
1438 completeFilename = completeNone
1439 completeHomeModuleOrFile=completeNone
1440 completeBkpt = completeNone
1443 -- ---------------------------------------------------------------------------
1444 -- User code exception handling
1446 -- This is the exception handler for exceptions generated by the
1447 -- user's code and exceptions coming from children sessions;
1448 -- it normally just prints out the exception. The
1449 -- handler must be recursive, in case showing the exception causes
1450 -- more exceptions to be raised.
1452 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1453 -- raising another exception. We therefore don't put the recursive
1454 -- handler arond the flushing operation, so if stderr is closed
1455 -- GHCi will just die gracefully rather than going into an infinite loop.
1456 handler :: Exception -> GHCi Bool
1458 handler exception = do
1460 io installSignalHandlers
1461 ghciHandle handler (showException exception >> return False)
1463 showException (DynException dyn) =
1464 case fromDynamic dyn of
1465 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1466 Just Interrupted -> io (putStrLn "Interrupted.")
1467 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1468 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1469 Just other_ghc_ex -> io (print other_ghc_ex)
1471 showException other_exception
1472 = io (putStrLn ("*** Exception: " ++ show other_exception))
1474 -----------------------------------------------------------------------------
1475 -- recursive exception handlers
1477 -- Don't forget to unblock async exceptions in the handler, or if we're
1478 -- in an exception loop (eg. let a = error a in a) the ^C exception
1479 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1481 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1482 ghciHandle h (GHCi m) = GHCi $ \s ->
1483 Exception.catch (m s)
1484 (\e -> unGHCi (ghciUnblock (h e)) s)
1486 ghciUnblock :: GHCi a -> GHCi a
1487 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1490 -- ----------------------------------------------------------------------------
1493 expandPath :: String -> GHCi String
1495 case dropWhile isSpace path of
1497 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1498 return (tilde ++ '/':d)
1502 wantInterpretedModule :: String -> GHCi Module
1503 wantInterpretedModule str = do
1504 session <- getSession
1505 modl <- lookupModule str
1506 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1507 when (not is_interpreted) $
1508 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1511 wantNameFromInterpretedModule noCanDo str and_then = do
1512 session <- getSession
1513 names <- io $ GHC.parseName session str
1517 let modl = GHC.nameModule n
1518 if not (GHC.isExternalName n)
1519 then noCanDo n $ ppr n <>
1520 text " is not defined in an interpreted module"
1522 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1523 if not is_interpreted
1524 then noCanDo n $ text "module " <> ppr modl <>
1525 text " is not interpreted"
1528 -- ----------------------------------------------------------------------------
1529 -- Windows console setup
1531 setUpConsole :: IO ()
1533 #ifdef mingw32_HOST_OS
1534 -- On Windows we need to set a known code page, otherwise the characters
1535 -- we read from the console will be be in some strange encoding, and
1536 -- similarly for characters we write to the console.
1538 -- At the moment, GHCi pretends all input is Latin-1. In the
1539 -- future we should support UTF-8, but for now we set the code
1540 -- pages to Latin-1. Doing it this way does lead to problems,
1541 -- however: see bug #1649.
1543 -- It seems you have to set the font in the console window to
1544 -- a Unicode font in order for output to work properly,
1545 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1546 -- (see MSDN for SetConsoleOutputCP()).
1548 -- This call has been known to hang on some machines, see bug #1483
1550 setConsoleCP 28591 -- ISO Latin-1
1551 setConsoleOutputCP 28591 -- ISO Latin-1
1555 -- -----------------------------------------------------------------------------
1556 -- commands for debugger
1558 sprintCmd = pprintCommand False False
1559 printCmd = pprintCommand True False
1560 forceCmd = pprintCommand False True
1562 pprintCommand bind force str = do
1563 session <- getSession
1564 io $ pprintClosureCommand session bind force str
1566 stepCmd :: String -> GHCi ()
1567 stepCmd [] = doContinue (const True) GHC.SingleStep
1568 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1570 stepLocalCmd :: String -> GHCi ()
1571 stepLocalCmd [] = do
1572 mb_span <- getCurrentBreakSpan
1574 Nothing -> stepCmd []
1576 Just mod <- getCurrentBreakModule
1577 current_toplevel_decl <- enclosingTickSpan mod loc
1578 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1580 stepLocalCmd expression = stepCmd expression
1582 stepModuleCmd :: String -> GHCi ()
1583 stepModuleCmd [] = do
1584 mb_span <- getCurrentBreakSpan
1586 Nothing -> stepCmd []
1588 Just span <- getCurrentBreakSpan
1589 let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
1590 doContinue f GHC.SingleStep
1592 stepModuleCmd expression = stepCmd expression
1594 -- | Returns the span of the largest tick containing the srcspan given
1595 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1596 enclosingTickSpan mod src = do
1597 ticks <- getTickArray mod
1598 let line = srcSpanStartLine src
1599 ASSERT (inRange (bounds ticks) line) do
1600 let enclosing_spans = [ span | (_,span) <- ticks ! line
1601 , srcSpanEnd span >= srcSpanEnd src]
1602 return . head . sortBy leftmost_largest $ enclosing_spans
1604 traceCmd :: String -> GHCi ()
1605 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1606 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1608 continueCmd :: String -> GHCi ()
1609 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1611 -- doContinue :: SingleStep -> GHCi ()
1612 doContinue pred step = do
1613 session <- getSession
1614 runResult <- io $ GHC.resume session step
1615 afterRunStmt pred runResult
1618 abandonCmd :: String -> GHCi ()
1619 abandonCmd = noArgs $ do
1621 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1622 when (not b) $ io $ putStrLn "There is no computation running."
1625 deleteCmd :: String -> GHCi ()
1626 deleteCmd argLine = do
1627 deleteSwitch $ words argLine
1629 deleteSwitch :: [String] -> GHCi ()
1631 io $ putStrLn "The delete command requires at least one argument."
1632 -- delete all break points
1633 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1634 deleteSwitch idents = do
1635 mapM_ deleteOneBreak idents
1637 deleteOneBreak :: String -> GHCi ()
1639 | all isDigit str = deleteBreak (read str)
1640 | otherwise = return ()
1642 historyCmd :: String -> GHCi ()
1644 | null arg = history 20
1645 | all isDigit arg = history (read arg)
1646 | otherwise = io $ putStrLn "Syntax: :history [num]"
1650 resumes <- io $ GHC.getResumeContext s
1652 [] -> io $ putStrLn "Not stopped at a breakpoint"
1654 let hist = GHC.resumeHistory r
1655 (took,rest) = splitAt num hist
1656 spans <- mapM (io . GHC.getHistorySpan s) took
1657 let nums = map (printf "-%-3d:") [(1::Int)..]
1658 let names = map GHC.historyEnclosingDecl took
1659 printForUser (vcat(zipWith3
1660 (\x y z -> x <+> y <+> z)
1662 (map (bold . ppr) names)
1663 (map (parens . ppr) spans)))
1664 io $ putStrLn $ if null rest then "<end of history>" else "..."
1666 bold c | do_bold = text start_bold <> c <> text end_bold
1669 backCmd :: String -> GHCi ()
1670 backCmd = noArgs $ do
1672 (names, ix, span) <- io $ GHC.back s
1673 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1674 printTypeOfNames s names
1675 -- run the command set with ":set stop <cmd>"
1677 enqueueCommands [stop st]
1679 forwardCmd :: String -> GHCi ()
1680 forwardCmd = noArgs $ do
1682 (names, ix, span) <- io $ GHC.forward s
1683 printForUser $ (if (ix == 0)
1684 then ptext SLIT("Stopped at")
1685 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1686 printTypeOfNames s names
1687 -- run the command set with ":set stop <cmd>"
1689 enqueueCommands [stop st]
1691 -- handle the "break" command
1692 breakCmd :: String -> GHCi ()
1693 breakCmd argLine = do
1694 session <- getSession
1695 breakSwitch session $ words argLine
1697 breakSwitch :: Session -> [String] -> GHCi ()
1698 breakSwitch _session [] = do
1699 io $ putStrLn "The break command requires at least one argument."
1700 breakSwitch session args@(arg1:rest)
1701 | looksLikeModuleName arg1 = do
1702 mod <- wantInterpretedModule arg1
1703 breakByModule session mod rest
1704 | all isDigit arg1 = do
1705 (toplevel, _) <- io $ GHC.getContext session
1707 (mod : _) -> breakByModuleLine mod (read arg1) rest
1709 io $ putStrLn "Cannot find default module for breakpoint."
1710 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1711 | otherwise = do -- try parsing it as an identifier
1712 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1713 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1714 if GHC.isGoodSrcLoc loc
1715 then findBreakAndSet (GHC.nameModule name) $
1716 findBreakByCoord (Just (GHC.srcLocFile loc))
1717 (GHC.srcLocLine loc,
1719 else noCanDo name $ text "can't find its location: " <> ppr loc
1721 noCanDo n why = printForUser $
1722 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1724 breakByModule :: Session -> Module -> [String] -> GHCi ()
1725 breakByModule session mod args@(arg1:rest)
1726 | all isDigit arg1 = do -- looks like a line number
1727 breakByModuleLine mod (read arg1) rest
1728 breakByModule session mod _
1731 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1732 breakByModuleLine mod line args
1733 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1734 | [col] <- args, all isDigit col =
1735 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1736 | otherwise = breakSyntax
1738 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1740 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1741 findBreakAndSet mod lookupTickTree = do
1742 tickArray <- getTickArray mod
1743 (breakArray, _) <- getModBreak mod
1744 case lookupTickTree tickArray of
1745 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1746 Just (tick, span) -> do
1747 success <- io $ setBreakFlag True breakArray tick
1748 session <- getSession
1752 recordBreak $ BreakLocation
1759 text "Breakpoint " <> ppr nm <>
1761 then text " was already set at " <> ppr span
1762 else text " activated at " <> ppr span
1764 printForUser $ text "Breakpoint could not be activated at"
1767 -- When a line number is specified, the current policy for choosing
1768 -- the best breakpoint is this:
1769 -- - the leftmost complete subexpression on the specified line, or
1770 -- - the leftmost subexpression starting on the specified line, or
1771 -- - the rightmost subexpression enclosing the specified line
1773 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1774 findBreakByLine line arr
1775 | not (inRange (bounds arr) line) = Nothing
1777 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
1778 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
1779 listToMaybe (sortBy (rightmost `on` snd) ticks)
1783 starts_here = [ tick | tick@(nm,span) <- ticks,
1784 GHC.srcSpanStartLine span == line ]
1786 (complete,incomplete) = partition ends_here starts_here
1787 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1789 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1790 -> Maybe (BreakIndex,SrcSpan)
1791 findBreakByCoord mb_file (line, col) arr
1792 | not (inRange (bounds arr) line) = Nothing
1794 listToMaybe (sortBy (rightmost `on` snd) contains ++
1795 sortBy (leftmost_smallest `on` snd) after_here)
1799 -- the ticks that span this coordinate
1800 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1801 is_correct_file span ]
1803 is_correct_file span
1804 | Just f <- mb_file = GHC.srcSpanFile span == f
1807 after_here = [ tick | tick@(nm,span) <- ticks,
1808 GHC.srcSpanStartLine span == line,
1809 GHC.srcSpanStartCol span >= col ]
1811 -- For now, use ANSI bold on terminals that we know support it.
1812 -- Otherwise, we add a line of carets under the active expression instead.
1813 -- In particular, on Windows and when running the testsuite (which sets
1814 -- TERM to vt100 for other reasons) we get carets.
1815 -- We really ought to use a proper termcap/terminfo library.
1817 do_bold = unsafePerformIO mTerm `elem` ["xterm", "linux"]
1818 where mTerm = System.Environment.getEnv "TERM"
1819 `Exception.catch` \e -> return "TERM not set"
1821 start_bold :: String
1822 start_bold = "\ESC[1m"
1824 end_bold = "\ESC[0m"
1826 listCmd :: String -> GHCi ()
1828 mb_span <- getCurrentBreakSpan
1830 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1831 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1832 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
1833 listCmd str = list2 (words str)
1835 list2 [arg] | all isDigit arg = do
1836 session <- getSession
1837 (toplevel, _) <- io $ GHC.getContext session
1839 [] -> io $ putStrLn "No module to list"
1840 (mod : _) -> listModuleLine mod (read arg)
1841 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1842 mod <- wantInterpretedModule arg1
1843 listModuleLine mod (read arg2)
1845 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1846 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1847 if GHC.isGoodSrcLoc loc
1849 tickArray <- getTickArray (GHC.nameModule name)
1850 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1851 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1854 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1855 Just (_,span) -> io $ listAround span False
1857 noCanDo name $ text "can't find its location: " <>
1860 noCanDo n why = printForUser $
1861 text "cannot list source code for " <> ppr n <> text ": " <> why
1863 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1865 listModuleLine :: Module -> Int -> GHCi ()
1866 listModuleLine modl line = do
1867 session <- getSession
1868 graph <- io (GHC.getModuleGraph session)
1869 let this = filter ((== modl) . GHC.ms_mod) graph
1871 [] -> panic "listModuleLine"
1873 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1874 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1875 io $ listAround (GHC.srcLocSpan loc) False
1877 -- | list a section of a source file around a particular SrcSpan.
1878 -- If the highlight flag is True, also highlight the span using
1879 -- start_bold/end_bold.
1880 listAround span do_highlight = do
1881 contents <- BS.readFile (unpackFS file)
1883 lines = BS.split '\n' contents
1884 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1885 drop (line1 - 1 - pad_before) $ lines
1886 fst_line = max 1 (line1 - pad_before)
1887 line_nos = [ fst_line .. ]
1889 highlighted | do_highlight = zipWith highlight line_nos these_lines
1890 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
1892 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1893 prefixed = zipWith ($) highlighted bs_line_nos
1895 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1897 file = GHC.srcSpanFile span
1898 line1 = GHC.srcSpanStartLine span
1899 col1 = GHC.srcSpanStartCol span
1900 line2 = GHC.srcSpanEndLine span
1901 col2 = GHC.srcSpanEndCol span
1903 pad_before | line1 == 1 = 0
1907 highlight | do_bold = highlight_bold
1908 | otherwise = highlight_carets
1910 highlight_bold no line prefix
1911 | no == line1 && no == line2
1912 = let (a,r) = BS.splitAt col1 line
1913 (b,c) = BS.splitAt (col2-col1) r
1915 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
1917 = let (a,b) = BS.splitAt col1 line in
1918 BS.concat [prefix, a, BS.pack start_bold, b]
1920 = let (a,b) = BS.splitAt col2 line in
1921 BS.concat [prefix, a, BS.pack end_bold, b]
1922 | otherwise = BS.concat [prefix, line]
1924 highlight_carets no line prefix
1925 | no == line1 && no == line2
1926 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
1927 BS.replicate (col2-col1) '^']
1929 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
1932 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
1934 | otherwise = BS.concat [prefix, line]
1936 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
1937 nl = BS.singleton '\n'
1939 -- --------------------------------------------------------------------------
1942 getTickArray :: Module -> GHCi TickArray
1943 getTickArray modl = do
1945 let arrmap = tickarrays st
1946 case lookupModuleEnv arrmap modl of
1947 Just arr -> return arr
1949 (breakArray, ticks) <- getModBreak modl
1950 let arr = mkTickArray (assocs ticks)
1951 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1954 discardTickArrays :: GHCi ()
1955 discardTickArrays = do
1957 setGHCiState st{tickarrays = emptyModuleEnv}
1959 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1961 = accumArray (flip (:)) [] (1, max_line)
1962 [ (line, (nm,span)) | (nm,span) <- ticks,
1963 line <- srcSpanLines span ]
1965 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1966 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1967 GHC.srcSpanEndLine span ]
1969 lookupModule :: String -> GHCi Module
1970 lookupModule modName
1971 = do session <- getSession
1972 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1974 -- don't reset the counter back to zero?
1975 discardActiveBreakPoints :: GHCi ()
1976 discardActiveBreakPoints = do
1978 mapM (turnOffBreak.snd) (breaks st)
1979 setGHCiState $ st { breaks = [] }
1981 deleteBreak :: Int -> GHCi ()
1982 deleteBreak identity = do
1984 let oldLocations = breaks st
1985 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
1987 then printForUser (text "Breakpoint" <+> ppr identity <+>
1988 text "does not exist")
1990 mapM (turnOffBreak.snd) this
1991 setGHCiState $ st { breaks = rest }
1993 turnOffBreak loc = do
1994 (arr, _) <- getModBreak (breakModule loc)
1995 io $ setBreakFlag False arr (breakTick loc)
1997 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1998 getModBreak mod = do
1999 session <- getSession
2000 Just mod_info <- io $ GHC.getModuleInfo session mod
2001 let modBreaks = GHC.modInfoModBreaks mod_info
2002 let array = GHC.modBreaks_flags modBreaks
2003 let ticks = GHC.modBreaks_locs modBreaks
2004 return (array, ticks)
2006 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2007 setBreakFlag toggle array index
2008 | toggle = GHC.setBreakOn array index
2009 | otherwise = GHC.setBreakOff array index