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 pages
1542 -- It seems you have to set the font in the console window to
1543 -- a Unicode font in order for output to work properly,
1544 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1545 -- (see MSDN for SetConsoleOutputCP()).
1547 setConsoleCP 28591 -- ISO Latin-1
1548 setConsoleOutputCP 28591 -- ISO Latin-1
1552 -- -----------------------------------------------------------------------------
1553 -- commands for debugger
1555 sprintCmd = pprintCommand False False
1556 printCmd = pprintCommand True False
1557 forceCmd = pprintCommand False True
1559 pprintCommand bind force str = do
1560 session <- getSession
1561 io $ pprintClosureCommand session bind force str
1563 stepCmd :: String -> GHCi ()
1564 stepCmd [] = doContinue (const True) GHC.SingleStep
1565 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1567 stepLocalCmd :: String -> GHCi ()
1568 stepLocalCmd [] = do
1569 mb_span <- getCurrentBreakSpan
1571 Nothing -> stepCmd []
1573 Just mod <- getCurrentBreakModule
1574 current_toplevel_decl <- enclosingTickSpan mod loc
1575 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1577 stepLocalCmd expression = stepCmd expression
1579 stepModuleCmd :: String -> GHCi ()
1580 stepModuleCmd [] = do
1581 mb_span <- getCurrentBreakSpan
1583 Nothing -> stepCmd []
1585 Just span <- getCurrentBreakSpan
1586 let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
1587 doContinue f GHC.SingleStep
1589 stepModuleCmd expression = stepCmd expression
1591 -- | Returns the span of the largest tick containing the srcspan given
1592 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1593 enclosingTickSpan mod src = do
1594 ticks <- getTickArray mod
1595 let line = srcSpanStartLine src
1596 ASSERT (inRange (bounds ticks) line) do
1597 let enclosing_spans = [ span | (_,span) <- ticks ! line
1598 , srcSpanEnd span >= srcSpanEnd src]
1599 return . head . sortBy leftmost_largest $ enclosing_spans
1601 traceCmd :: String -> GHCi ()
1602 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1603 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1605 continueCmd :: String -> GHCi ()
1606 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1608 -- doContinue :: SingleStep -> GHCi ()
1609 doContinue pred step = do
1610 session <- getSession
1611 runResult <- io $ GHC.resume session step
1612 afterRunStmt pred runResult
1615 abandonCmd :: String -> GHCi ()
1616 abandonCmd = noArgs $ do
1618 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1619 when (not b) $ io $ putStrLn "There is no computation running."
1622 deleteCmd :: String -> GHCi ()
1623 deleteCmd argLine = do
1624 deleteSwitch $ words argLine
1626 deleteSwitch :: [String] -> GHCi ()
1628 io $ putStrLn "The delete command requires at least one argument."
1629 -- delete all break points
1630 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1631 deleteSwitch idents = do
1632 mapM_ deleteOneBreak idents
1634 deleteOneBreak :: String -> GHCi ()
1636 | all isDigit str = deleteBreak (read str)
1637 | otherwise = return ()
1639 historyCmd :: String -> GHCi ()
1641 | null arg = history 20
1642 | all isDigit arg = history (read arg)
1643 | otherwise = io $ putStrLn "Syntax: :history [num]"
1647 resumes <- io $ GHC.getResumeContext s
1649 [] -> io $ putStrLn "Not stopped at a breakpoint"
1651 let hist = GHC.resumeHistory r
1652 (took,rest) = splitAt num hist
1653 spans <- mapM (io . GHC.getHistorySpan s) took
1654 let nums = map (printf "-%-3d:") [(1::Int)..]
1655 let names = map GHC.historyEnclosingDecl took
1656 printForUser (vcat(zipWith3
1657 (\x y z -> x <+> y <+> z)
1659 (map (bold . ppr) names)
1660 (map (parens . ppr) spans)))
1661 io $ putStrLn $ if null rest then "<end of history>" else "..."
1663 bold c | do_bold = text start_bold <> c <> text end_bold
1666 backCmd :: String -> GHCi ()
1667 backCmd = noArgs $ do
1669 (names, ix, span) <- io $ GHC.back s
1670 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1671 printTypeOfNames s names
1672 -- run the command set with ":set stop <cmd>"
1674 enqueueCommands [stop st]
1676 forwardCmd :: String -> GHCi ()
1677 forwardCmd = noArgs $ do
1679 (names, ix, span) <- io $ GHC.forward s
1680 printForUser $ (if (ix == 0)
1681 then ptext SLIT("Stopped at")
1682 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1683 printTypeOfNames s names
1684 -- run the command set with ":set stop <cmd>"
1686 enqueueCommands [stop st]
1688 -- handle the "break" command
1689 breakCmd :: String -> GHCi ()
1690 breakCmd argLine = do
1691 session <- getSession
1692 breakSwitch session $ words argLine
1694 breakSwitch :: Session -> [String] -> GHCi ()
1695 breakSwitch _session [] = do
1696 io $ putStrLn "The break command requires at least one argument."
1697 breakSwitch session args@(arg1:rest)
1698 | looksLikeModuleName arg1 = do
1699 mod <- wantInterpretedModule arg1
1700 breakByModule session mod rest
1701 | all isDigit arg1 = do
1702 (toplevel, _) <- io $ GHC.getContext session
1704 (mod : _) -> breakByModuleLine mod (read arg1) rest
1706 io $ putStrLn "Cannot find default module for breakpoint."
1707 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1708 | otherwise = do -- try parsing it as an identifier
1709 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1710 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1711 if GHC.isGoodSrcLoc loc
1712 then findBreakAndSet (GHC.nameModule name) $
1713 findBreakByCoord (Just (GHC.srcLocFile loc))
1714 (GHC.srcLocLine loc,
1716 else noCanDo name $ text "can't find its location: " <> ppr loc
1718 noCanDo n why = printForUser $
1719 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1721 breakByModule :: Session -> Module -> [String] -> GHCi ()
1722 breakByModule session mod args@(arg1:rest)
1723 | all isDigit arg1 = do -- looks like a line number
1724 breakByModuleLine mod (read arg1) rest
1725 breakByModule session mod _
1728 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1729 breakByModuleLine mod line args
1730 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1731 | [col] <- args, all isDigit col =
1732 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1733 | otherwise = breakSyntax
1735 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1737 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1738 findBreakAndSet mod lookupTickTree = do
1739 tickArray <- getTickArray mod
1740 (breakArray, _) <- getModBreak mod
1741 case lookupTickTree tickArray of
1742 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1743 Just (tick, span) -> do
1744 success <- io $ setBreakFlag True breakArray tick
1745 session <- getSession
1749 recordBreak $ BreakLocation
1756 text "Breakpoint " <> ppr nm <>
1758 then text " was already set at " <> ppr span
1759 else text " activated at " <> ppr span
1761 printForUser $ text "Breakpoint could not be activated at"
1764 -- When a line number is specified, the current policy for choosing
1765 -- the best breakpoint is this:
1766 -- - the leftmost complete subexpression on the specified line, or
1767 -- - the leftmost subexpression starting on the specified line, or
1768 -- - the rightmost subexpression enclosing the specified line
1770 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1771 findBreakByLine line arr
1772 | not (inRange (bounds arr) line) = Nothing
1774 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
1775 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
1776 listToMaybe (sortBy (rightmost `on` snd) ticks)
1780 starts_here = [ tick | tick@(nm,span) <- ticks,
1781 GHC.srcSpanStartLine span == line ]
1783 (complete,incomplete) = partition ends_here starts_here
1784 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1786 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1787 -> Maybe (BreakIndex,SrcSpan)
1788 findBreakByCoord mb_file (line, col) arr
1789 | not (inRange (bounds arr) line) = Nothing
1791 listToMaybe (sortBy (rightmost `on` snd) contains ++
1792 sortBy (leftmost_smallest `on` snd) after_here)
1796 -- the ticks that span this coordinate
1797 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1798 is_correct_file span ]
1800 is_correct_file span
1801 | Just f <- mb_file = GHC.srcSpanFile span == f
1804 after_here = [ tick | tick@(nm,span) <- ticks,
1805 GHC.srcSpanStartLine span == line,
1806 GHC.srcSpanStartCol span >= col ]
1808 -- For now, use ANSI bold on terminals that we know support it.
1809 -- Otherwise, we add a line of carets under the active expression instead.
1810 -- In particular, on Windows and when running the testsuite (which sets
1811 -- TERM to vt100 for other reasons) we get carets.
1812 -- We really ought to use a proper termcap/terminfo library.
1814 do_bold = unsafePerformIO (System.Environment.getEnv "TERM") `elem`
1817 start_bold :: String
1818 start_bold = "\ESC[1m"
1820 end_bold = "\ESC[0m"
1822 listCmd :: String -> GHCi ()
1824 mb_span <- getCurrentBreakSpan
1826 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1827 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1828 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
1829 listCmd str = list2 (words str)
1831 list2 [arg] | all isDigit arg = do
1832 session <- getSession
1833 (toplevel, _) <- io $ GHC.getContext session
1835 [] -> io $ putStrLn "No module to list"
1836 (mod : _) -> listModuleLine mod (read arg)
1837 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1838 mod <- wantInterpretedModule arg1
1839 listModuleLine mod (read arg2)
1841 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1842 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1843 if GHC.isGoodSrcLoc loc
1845 tickArray <- getTickArray (GHC.nameModule name)
1846 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1847 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1850 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1851 Just (_,span) -> io $ listAround span False
1853 noCanDo name $ text "can't find its location: " <>
1856 noCanDo n why = printForUser $
1857 text "cannot list source code for " <> ppr n <> text ": " <> why
1859 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1861 listModuleLine :: Module -> Int -> GHCi ()
1862 listModuleLine modl line = do
1863 session <- getSession
1864 graph <- io (GHC.getModuleGraph session)
1865 let this = filter ((== modl) . GHC.ms_mod) graph
1867 [] -> panic "listModuleLine"
1869 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1870 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1871 io $ listAround (GHC.srcLocSpan loc) False
1873 -- | list a section of a source file around a particular SrcSpan.
1874 -- If the highlight flag is True, also highlight the span using
1875 -- start_bold/end_bold.
1876 listAround span do_highlight = do
1877 contents <- BS.readFile (unpackFS file)
1879 lines = BS.split '\n' contents
1880 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1881 drop (line1 - 1 - pad_before) $ lines
1882 fst_line = max 1 (line1 - pad_before)
1883 line_nos = [ fst_line .. ]
1885 highlighted | do_highlight = zipWith highlight line_nos these_lines
1886 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
1888 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1889 prefixed = zipWith ($) highlighted bs_line_nos
1891 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1893 file = GHC.srcSpanFile span
1894 line1 = GHC.srcSpanStartLine span
1895 col1 = GHC.srcSpanStartCol span
1896 line2 = GHC.srcSpanEndLine span
1897 col2 = GHC.srcSpanEndCol span
1899 pad_before | line1 == 1 = 0
1903 highlight | do_bold = highlight_bold
1904 | otherwise = highlight_carets
1906 highlight_bold no line prefix
1907 | no == line1 && no == line2
1908 = let (a,r) = BS.splitAt col1 line
1909 (b,c) = BS.splitAt (col2-col1) r
1911 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
1913 = let (a,b) = BS.splitAt col1 line in
1914 BS.concat [prefix, a, BS.pack start_bold, b]
1916 = let (a,b) = BS.splitAt col2 line in
1917 BS.concat [prefix, a, BS.pack end_bold, b]
1918 | otherwise = BS.concat [prefix, line]
1920 highlight_carets no line prefix
1921 | no == line1 && no == line2
1922 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
1923 BS.replicate (col2-col1) '^']
1925 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
1928 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
1930 | otherwise = BS.concat [prefix, line]
1932 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
1933 nl = BS.singleton '\n'
1935 -- --------------------------------------------------------------------------
1938 getTickArray :: Module -> GHCi TickArray
1939 getTickArray modl = do
1941 let arrmap = tickarrays st
1942 case lookupModuleEnv arrmap modl of
1943 Just arr -> return arr
1945 (breakArray, ticks) <- getModBreak modl
1946 let arr = mkTickArray (assocs ticks)
1947 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1950 discardTickArrays :: GHCi ()
1951 discardTickArrays = do
1953 setGHCiState st{tickarrays = emptyModuleEnv}
1955 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1957 = accumArray (flip (:)) [] (1, max_line)
1958 [ (line, (nm,span)) | (nm,span) <- ticks,
1959 line <- srcSpanLines span ]
1961 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1962 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1963 GHC.srcSpanEndLine span ]
1965 lookupModule :: String -> GHCi Module
1966 lookupModule modName
1967 = do session <- getSession
1968 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1970 -- don't reset the counter back to zero?
1971 discardActiveBreakPoints :: GHCi ()
1972 discardActiveBreakPoints = do
1974 mapM (turnOffBreak.snd) (breaks st)
1975 setGHCiState $ st { breaks = [] }
1977 deleteBreak :: Int -> GHCi ()
1978 deleteBreak identity = do
1980 let oldLocations = breaks st
1981 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
1983 then printForUser (text "Breakpoint" <+> ppr identity <+>
1984 text "does not exist")
1986 mapM (turnOffBreak.snd) this
1987 setGHCiState $ st { breaks = rest }
1989 turnOffBreak loc = do
1990 (arr, _) <- getModBreak (breakModule loc)
1991 io $ setBreakFlag False arr (breakTick loc)
1993 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1994 getModBreak mod = do
1995 session <- getSession
1996 Just mod_info <- io $ GHC.getModuleInfo session mod
1997 let modBreaks = GHC.modInfoModBreaks mod_info
1998 let array = GHC.modBreaks_flags modBreaks
1999 let ticks = GHC.modBreaks_locs modBreaks
2000 return (array, ticks)
2002 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2003 setBreakFlag toggle array index
2004 | toggle = GHC.setBreakOn array index
2005 | otherwise = GHC.setBreakOff array index