1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005-2006
8 -----------------------------------------------------------------------------
9 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
11 #include "HsVersions.h"
19 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
20 Type, Module, ModuleName, TyThing(..), Phase,
21 BreakIndex, SrcSpan, Resume, SingleStep )
26 import HscTypes ( implicitTyThings )
28 import Outputable hiding (printForUser)
29 import Module -- for ModuleEnv
33 -- Other random utilities
35 import BasicTypes hiding (isTopLevel)
36 import Panic hiding (showException)
42 import Maybes ( orElse )
45 #ifndef mingw32_HOST_OS
46 import System.Posix hiding (getEnv)
48 import GHC.ConsoleHandler ( flushConsole )
49 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
50 import qualified System.Win32
54 import Control.Concurrent ( yield ) -- Used in readline loop
55 import System.Console.Readline as Readline
60 import Control.Exception as Exception
61 -- import Control.Concurrent
63 import qualified Data.ByteString.Char8 as BS
67 import System.Environment
68 import System.Exit ( exitWith, ExitCode(..) )
69 import System.Directory
71 import System.IO.Error as IO
75 import Control.Monad as Monad
78 import Foreign.StablePtr ( newStablePtr )
79 import GHC.Exts ( unsafeCoerce# )
80 import GHC.IOBase ( IOErrorType(InvalidArgument) )
82 import Data.IORef ( IORef, readIORef, writeIORef )
84 import System.Posix.Internals ( setNonBlockingFD )
86 -----------------------------------------------------------------------------
88 ghciWelcomeMsg :: String
89 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
90 ": http://www.haskell.org/ghc/ :? for help"
92 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
95 GLOBAL_VAR(commands, builtin_commands, [Command])
97 builtin_commands :: [Command]
99 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
100 ("?", keepGoing help, False, completeNone),
101 ("add", keepGoingPaths addModule, False, completeFilename),
102 ("abandon", keepGoing abandonCmd, False, completeNone),
103 ("break", keepGoing breakCmd, False, completeIdentifier),
104 ("back", keepGoing backCmd, False, completeNone),
105 ("browse", keepGoing browseCmd, False, completeModule),
106 ("cd", keepGoing changeDirectory, False, completeFilename),
107 ("check", keepGoing checkModule, False, completeHomeModule),
108 ("continue", keepGoing continueCmd, False, completeNone),
109 ("cmd", keepGoing cmdCmd, False, completeIdentifier),
110 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
111 ("def", keepGoing defineMacro, False, completeIdentifier),
112 ("delete", keepGoing deleteCmd, False, completeNone),
113 ("e", keepGoing editFile, False, completeFilename),
114 ("edit", keepGoing editFile, False, completeFilename),
115 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
116 ("force", keepGoing forceCmd, False, completeIdentifier),
117 ("forward", keepGoing forwardCmd, False, completeNone),
118 ("help", keepGoing help, False, completeNone),
119 ("history", keepGoing historyCmd, False, completeNone),
120 ("info", keepGoing info, False, completeIdentifier),
121 ("kind", keepGoing kindOfType, False, completeIdentifier),
122 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
123 ("list", keepGoing listCmd, False, completeNone),
124 ("module", keepGoing setContext, False, completeModule),
125 ("main", keepGoing runMain, False, completeIdentifier),
126 ("print", keepGoing printCmd, False, completeIdentifier),
127 ("quit", quit, False, completeNone),
128 ("reload", keepGoing reloadModule, False, completeNone),
129 ("set", keepGoing setCmd, True, completeSetOptions),
130 ("show", keepGoing showCmd, False, completeNone),
131 ("sprint", keepGoing sprintCmd, False, completeIdentifier),
132 ("step", keepGoing stepCmd, False, completeIdentifier),
133 ("steplocal", keepGoing stepLocalCmd, False, completeIdentifier),
134 ("stepmodule",keepGoing stepModuleCmd, False, completeIdentifier),
135 ("type", keepGoing typeOfExpr, False, completeIdentifier),
136 ("trace", keepGoing traceCmd, False, completeIdentifier),
137 ("undef", keepGoing undefineMacro, False, completeMacro),
138 ("unset", keepGoing unsetOptions, True, completeSetOptions)
141 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
142 keepGoing a str = a str >> return False
144 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
145 keepGoingPaths a str = a (toArgs str) >> return False
147 shortHelpText = "use :? for help.\n"
150 " Commands available from the prompt:\n" ++
152 " <statement> evaluate/run <statement>\n" ++
153 " :add <filename> ... add module(s) to the current target set\n" ++
154 " :browse [*]<module> display the names defined by <module>\n" ++
155 " :cd <dir> change directory to <dir>\n" ++
156 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
157 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
158 " :def <cmd> <expr> define a command :<cmd>\n" ++
159 " :edit <file> edit file\n" ++
160 " :edit edit last module\n" ++
161 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
162 " :help, :? display this list of commands\n" ++
163 " :info [<name> ...] display information about the given names\n" ++
164 " :kind <type> show the kind of <type>\n" ++
165 " :load <filename> ... load module(s) and their dependents\n" ++
166 " :main [<arguments> ...] run the main function with the given arguments\n" ++
167 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
168 " :quit exit GHCi\n" ++
169 " :reload reload the current module set\n" ++
170 " :type <expr> show the type of <expr>\n" ++
171 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
172 " :!<command> run the shell command <command>\n" ++
174 " -- Commands for debugging:\n" ++
176 " :abandon at a breakpoint, abandon current computation\n" ++
177 " :back go back in the history (after :trace)\n" ++
178 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
179 " :break <name> set a breakpoint on the specified function\n" ++
180 " :continue resume after a breakpoint\n" ++
181 " :delete <number> delete the specified breakpoint\n" ++
182 " :delete * delete all breakpoints\n" ++
183 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
184 " :forward go forward in the history (after :back)\n" ++
185 " :history [<n>] show the last <n> items in the history (after :trace)\n" ++
186 " :print [<name> ...] prints a value without forcing its computation\n" ++
187 " :sprint [<name> ...] simplifed version of :print\n" ++
188 " :step single-step after stopping at a breakpoint\n"++
189 " :step <expr> single-step into <expr>\n"++
190 " :steplocal single-step restricted to the current top level decl.\n"++
191 " :stepmodule single-step restricted to the current module\n"++
192 " :trace trace after stopping at a breakpoint\n"++
193 " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
196 " -- Commands for changing settings:\n" ++
198 " :set <option> ... set options\n" ++
199 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
200 " :set prog <progname> set the value returned by System.getProgName\n" ++
201 " :set prompt <prompt> set the prompt used in GHCi\n" ++
202 " :set editor <cmd> set the command used for :edit\n" ++
203 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
204 " :unset <option> ... unset options\n" ++
206 " Options for ':set' and ':unset':\n" ++
208 " +r revert top-level expressions after each evaluation\n" ++
209 " +s print timing/memory stats after each evaluation\n" ++
210 " +t print type after evaluation\n" ++
211 " -<flags> most GHC command line flags can also be set here\n" ++
212 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
214 " -- Commands for displaying information:\n" ++
216 " :show bindings show the current bindings made at the prompt\n" ++
217 " :show breaks show the active breakpoints\n" ++
218 " :show context show the breakpoint context\n" ++
219 " :show modules show the currently loaded modules\n" ++
220 " :show <setting> show anything that can be set with :set (e.g. args)\n" ++
227 win <- System.Win32.getWindowsDirectory
228 return (win `joinFileName` "notepad.exe")
233 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
234 interactiveUI session srcs maybe_expr = do
235 -- HACK! If we happen to get into an infinite loop (eg the user
236 -- types 'let x=x in x' at the prompt), then the thread will block
237 -- on a blackhole, and become unreachable during GC. The GC will
238 -- detect that it is unreachable and send it the NonTermination
239 -- exception. However, since the thread is unreachable, everything
240 -- it refers to might be finalized, including the standard Handles.
241 -- This sounds like a bug, but we don't have a good solution right
247 -- Initialise buffering for the *interpreted* I/O system
248 initInterpBuffering session
250 when (isNothing maybe_expr) $ do
251 -- Only for GHCi (not runghc and ghc -e):
253 -- Turn buffering off for the compiled program's stdout/stderr
255 -- Turn buffering off for GHCi's stdout
257 hSetBuffering stdout NoBuffering
258 -- We don't want the cmd line to buffer any input that might be
259 -- intended for the program, so unbuffer stdin.
260 hSetBuffering stdin NoBuffering
262 -- initial context is just the Prelude
263 prel_mod <- GHC.findModule session prel_name (Just basePackageId)
264 GHC.setContext session [] [prel_mod]
268 Readline.setAttemptedCompletionFunction (Just completeWord)
269 --Readline.parseAndBind "set show-all-if-ambiguous 1"
271 let symbols = "!#$%&*+/<=>?@\\^|-~"
272 specials = "(),;[]`{}"
274 word_break_chars = spaces ++ specials ++ symbols
276 Readline.setBasicWordBreakCharacters word_break_chars
277 Readline.setCompleterWordBreakCharacters word_break_chars
280 default_editor <- findEditor
282 startGHCi (runGHCi srcs maybe_expr)
283 GHCiState{ progname = "<interactive>",
287 editor = default_editor,
293 tickarrays = emptyModuleEnv,
298 Readline.resetTerminal Nothing
303 prel_name = GHC.mkModuleName "Prelude"
305 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
306 runGHCi paths maybe_expr = do
307 let read_dot_files = not opt_IgnoreDotGhci
309 when (read_dot_files) $ do
312 exists <- io (doesFileExist file)
314 dir_ok <- io (checkPerms ".")
315 file_ok <- io (checkPerms file)
316 when (dir_ok && file_ok) $ do
317 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
320 Right hdl -> fileLoop hdl False
322 when (read_dot_files) $ do
323 -- Read in $HOME/.ghci
324 either_dir <- io (IO.try (getEnv "HOME"))
328 cwd <- io (getCurrentDirectory)
329 when (dir /= cwd) $ do
330 let file = dir ++ "/.ghci"
331 ok <- io (checkPerms file)
333 either_hdl <- io (IO.try (openFile file ReadMode))
336 Right hdl -> fileLoop hdl False
338 -- Perform a :load for files given on the GHCi command line
339 -- When in -e mode, if the load fails then we want to stop
340 -- immediately rather than going on to evaluate the expression.
341 when (not (null paths)) $ do
342 ok <- ghciHandle (\e -> do showException e; return Failed) $
344 when (isJust maybe_expr && failed ok) $
345 io (exitWith (ExitFailure 1))
347 -- if verbosity is greater than 0, or we are connected to a
348 -- terminal, display the prompt in the interactive loop.
349 is_tty <- io (hIsTerminalDevice stdin)
350 dflags <- getDynFlags
351 let show_prompt = verbosity dflags > 0 || is_tty
356 #if defined(mingw32_HOST_OS)
357 -- The win32 Console API mutates the first character of
358 -- type-ahead when reading from it in a non-buffered manner. Work
359 -- around this by flushing the input buffer of type-ahead characters,
360 -- but only if stdin is available.
361 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
363 Left err | isDoesNotExistError err -> return ()
364 | otherwise -> io (ioError err)
365 Right () -> return ()
367 -- initialise the console if necessary
370 -- enter the interactive loop
371 interactiveLoop is_tty show_prompt
373 -- just evaluate the expression we were given
378 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
381 interactiveLoop is_tty show_prompt =
382 -- Ignore ^C exceptions caught here
383 ghciHandleDyn (\e -> case e of
385 #if defined(mingw32_HOST_OS)
388 interactiveLoop is_tty show_prompt
389 _other -> return ()) $
391 ghciUnblock $ do -- unblock necessary if we recursed from the
392 -- exception handler above.
394 -- read commands from stdin
398 else fileLoop stdin show_prompt
400 fileLoop stdin show_prompt
404 -- NOTE: We only read .ghci files if they are owned by the current user,
405 -- and aren't world writable. Otherwise, we could be accidentally
406 -- running code planted by a malicious third party.
408 -- Furthermore, We only read ./.ghci if . is owned by the current user
409 -- and isn't writable by anyone else. I think this is sufficient: we
410 -- don't need to check .. and ../.. etc. because "." always refers to
411 -- the same directory while a process is running.
413 checkPerms :: String -> IO Bool
415 #ifdef mingw32_HOST_OS
418 Util.handle (\_ -> return False) $ do
419 st <- getFileStatus name
421 if fileOwner st /= me then do
422 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
425 let mode = fileMode st
426 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
427 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
429 putStrLn $ "*** WARNING: " ++ name ++
430 " is writable by someone else, IGNORING!"
435 fileLoop :: Handle -> Bool -> GHCi ()
436 fileLoop hdl show_prompt = do
437 when show_prompt $ do
440 l <- io (IO.try (hGetLine hdl))
442 Left e | isEOFError e -> return ()
443 | InvalidArgument <- etype -> return ()
444 | otherwise -> io (ioError e)
445 where etype = ioeGetErrorType e
446 -- treat InvalidArgument in the same way as EOF:
447 -- this can happen if the user closed stdin, or
448 -- perhaps did getContents which closes stdin at
451 case removeSpaces l of
452 "" -> fileLoop hdl show_prompt
453 l -> do quit <- runCommands l
454 if quit then return () else fileLoop hdl show_prompt
457 session <- getSession
458 (toplevs,exports) <- io (GHC.getContext session)
459 resumes <- io $ GHC.getResumeContext session
465 let ix = GHC.resumeHistoryIx r
467 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
469 let hist = GHC.resumeHistory r !! (ix-1)
470 span <- io$ GHC.getHistorySpan session hist
471 return (brackets (ppr (negate ix) <> char ':'
472 <+> ppr span) <> space)
474 dots | r:rs <- resumes, not (null rs) = text "... "
478 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
479 hsep (map (ppr . GHC.moduleName) exports)
481 deflt_prompt = dots <> context_bit <> modules_bit
483 f ('%':'s':xs) = deflt_prompt <> f xs
484 f ('%':'%':xs) = char '%' <> f xs
485 f (x:xs) = char x <> f xs
489 return (showSDoc (f (prompt st)))
493 readlineLoop :: GHCi ()
495 session <- getSession
496 (mod,imports) <- io (GHC.getContext session)
498 saveSession -- for use by completion
500 mb_span <- getCurrentBreakSpan
502 l <- io (readline prompt `finally` setNonBlockingFD 0)
503 -- readline sometimes puts stdin into blocking mode,
504 -- so we need to put it back for the IO library
509 case removeSpaces l of
513 quit <- runCommands l
514 if quit then return () else readlineLoop
517 runCommands :: String -> GHCi Bool
519 q <- ghciHandle handler (doCommand cmd)
520 if q then return True else runNext
526 c:cs -> do setGHCiState st{ cmdqueue = cs }
529 doCommand (':' : cmd) = specialCommand cmd
530 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
533 enqueueCommands :: [String] -> GHCi ()
534 enqueueCommands cmds = do
536 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
539 -- This version is for the GHC command-line option -e. The only difference
540 -- from runCommand is that it catches the ExitException exception and
541 -- exits, rather than printing out the exception.
542 runCommandEval c = ghciHandle handleEval (doCommand c)
544 handleEval (ExitException code) = io (exitWith code)
545 handleEval e = do handler e
546 io (exitWith (ExitFailure 1))
548 doCommand (':' : command) = specialCommand command
550 = do r <- runStmt stmt GHC.RunToCompletion
552 False -> io (exitWith (ExitFailure 1))
553 -- failure to run the command causes exit(1) for ghc -e.
556 runStmt :: String -> SingleStep -> GHCi Bool
558 | null (filter (not.isSpace) stmt) = return False
559 | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
561 = do st <- getGHCiState
562 session <- getSession
563 result <- io $ withProgName (progname st) $ withArgs (args st) $
564 GHC.runStmt session stmt step
565 afterRunStmt (const True) result
568 --afterRunStmt :: GHC.RunResult -> GHCi Bool
569 -- False <=> the statement failed to compile
570 afterRunStmt _ (GHC.RunException e) = throw e
571 afterRunStmt step_here run_result = do
572 session <- getSession
573 resumes <- io $ GHC.getResumeContext session
575 GHC.RunOk names -> do
576 show_types <- isOptionSet ShowType
577 when show_types $ printTypeOfNames session names
578 GHC.RunBreak _ names mb_info
579 | isNothing mb_info ||
580 step_here (GHC.resumeSpan $ head resumes) -> do
581 printForUser $ ptext SLIT("Stopped at") <+>
582 ppr (GHC.resumeSpan $ head resumes)
583 -- printTypeOfNames session names
584 printTypeAndContentOfNames session names
585 maybe (return ()) runBreakCmd mb_info
586 -- run the command set with ":set stop <cmd>"
588 enqueueCommands [stop st]
590 | otherwise -> io(GHC.resume session GHC.SingleStep) >>=
591 afterRunStmt step_here >> return ()
595 io installSignalHandlers
596 b <- isOptionSet RevertCAFs
597 io (when b revertCAFs)
599 return (case run_result of GHC.RunOk _ -> True; _ -> False)
601 where printTypeAndContentOfNames session names = do
602 let namesSorted = sortBy compareNames names
603 tythings <- catMaybes `liftM`
604 io (mapM (GHC.lookupName session) namesSorted)
605 docs_ty <- mapM showTyThing tythings
606 terms <- mapM (io . GHC.obtainTermB session 10 False)
607 [ id | (AnId id, Just _) <- zip tythings docs_ty]
608 docs_terms <- mapM (io . showTerm session) terms
609 printForUser $ vcat $ zipWith (\ty cts -> ty <> text " = " <> cts)
613 runBreakCmd :: GHC.BreakInfo -> GHCi ()
614 runBreakCmd info = do
615 let mod = GHC.breakInfo_module info
616 nm = GHC.breakInfo_number info
618 case [ loc | (i,loc) <- breaks st,
619 breakModule loc == mod, breakTick loc == nm ] of
621 loc:_ | null cmd -> return ()
622 | otherwise -> do enqueueCommands [cmd]; return ()
623 where cmd = onBreakCmd loc
625 printTypeOfNames :: Session -> [Name] -> GHCi ()
626 printTypeOfNames session names
627 = mapM_ (printTypeOfName session) $ sortBy compareNames names
629 compareNames :: Name -> Name -> Ordering
630 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
631 where compareWith n = (getOccString n, getSrcSpan n)
633 printTypeOfName :: Session -> Name -> GHCi ()
634 printTypeOfName session n
635 = do maybe_tything <- io (GHC.lookupName session n)
636 case maybe_tything of
638 Just thing -> printTyThing thing
640 specialCommand :: String -> GHCi Bool
641 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
642 specialCommand str = do
643 let (cmd,rest) = break isSpace str
644 maybe_cmd <- io (lookupCommand cmd)
646 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
647 ++ shortHelpText) >> return False)
648 Just (_,f,_,_) -> f (dropWhile isSpace rest)
650 lookupCommand :: String -> IO (Maybe Command)
651 lookupCommand str = do
652 cmds <- readIORef commands
653 -- look for exact match first, then the first prefix match
654 case [ c | c <- cmds, str == cmdName c ] of
655 c:_ -> return (Just c)
656 [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
658 c:_ -> return (Just c)
661 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
662 getCurrentBreakSpan = do
663 session <- getSession
664 resumes <- io $ GHC.getResumeContext session
668 let ix = GHC.resumeHistoryIx r
670 then return (Just (GHC.resumeSpan r))
672 let hist = GHC.resumeHistory r !! (ix-1)
673 span <- io $ GHC.getHistorySpan session hist
676 getCurrentBreakModule :: GHCi (Maybe Module)
677 getCurrentBreakModule = do
678 session <- getSession
679 resumes <- io $ GHC.getResumeContext session
683 let ix = GHC.resumeHistoryIx r
685 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
687 let hist = GHC.resumeHistory r !! (ix-1)
688 return $ Just $ GHC.getHistoryModule hist
690 -----------------------------------------------------------------------------
693 noArgs :: GHCi () -> String -> GHCi ()
695 noArgs m _ = io $ putStrLn "This command takes no arguments"
697 help :: String -> GHCi ()
698 help _ = io (putStr helpText)
700 info :: String -> GHCi ()
701 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
702 info s = do { let names = words s
703 ; session <- getSession
704 ; dflags <- getDynFlags
705 ; let pefas = dopt Opt_PrintExplicitForalls dflags
706 ; mapM_ (infoThing pefas session) names }
708 infoThing pefas session str = io $ do
709 names <- GHC.parseName session str
710 mb_stuffs <- mapM (GHC.getInfo session) names
711 let filtered = filterOutChildren (\(t,f,i) -> t) (catMaybes mb_stuffs)
712 unqual <- GHC.getPrintUnqual session
713 putStrLn (showSDocForUser unqual $
714 vcat (intersperse (text "") $
715 map (pprInfo pefas) filtered))
717 -- Filter out names whose parent is also there Good
718 -- example is '[]', which is both a type and data
719 -- constructor in the same type
720 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
721 filterOutChildren get_thing xs
722 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
724 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
726 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
727 pprInfo pefas (thing, fixity, insts)
728 = pprTyThingInContextLoc pefas thing
729 $$ show_fixity fixity
730 $$ vcat (map GHC.pprInstance insts)
733 | fix == GHC.defaultFixity = empty
734 | otherwise = ppr fix <+> ppr (GHC.getName thing)
736 runMain :: String -> GHCi ()
738 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
739 enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
741 addModule :: [FilePath] -> GHCi ()
743 io (revertCAFs) -- always revert CAFs on load/add.
744 files <- mapM expandPath files
745 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
746 session <- getSession
747 io (mapM_ (GHC.addTarget session) targets)
748 ok <- io (GHC.load session LoadAllTargets)
751 changeDirectory :: String -> GHCi ()
752 changeDirectory dir = do
753 session <- getSession
754 graph <- io (GHC.getModuleGraph session)
755 when (not (null graph)) $
756 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
757 io (GHC.setTargets session [])
758 io (GHC.load session LoadAllTargets)
759 setContextAfterLoad session []
760 io (GHC.workingDirectoryChanged session)
761 dir <- expandPath dir
762 io (setCurrentDirectory dir)
764 editFile :: String -> GHCi ()
766 do file <- if null str then chooseEditFile else return str
770 $ throwDyn (CmdLineError "editor not set, use :set editor")
771 io $ system (cmd ++ ' ':file)
774 -- The user didn't specify a file so we pick one for them.
775 -- Our strategy is to pick the first module that failed to load,
776 -- or otherwise the first target.
778 -- XXX: Can we figure out what happened if the depndecy analysis fails
779 -- (e.g., because the porgrammeer mistyped the name of a module)?
780 -- XXX: Can we figure out the location of an error to pass to the editor?
781 -- XXX: if we could figure out the list of errors that occured during the
782 -- last load/reaload, then we could start the editor focused on the first
784 chooseEditFile :: GHCi String
786 do session <- getSession
787 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
789 graph <- io (GHC.getModuleGraph session)
790 failed_graph <- filterM hasFailed graph
791 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
793 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
796 case pick (order failed_graph) of
797 Just file -> return file
799 do targets <- io (GHC.getTargets session)
800 case msum (map fromTarget targets) of
801 Just file -> return file
802 Nothing -> throwDyn (CmdLineError "No files to edit.")
804 where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
805 fromTarget _ = Nothing -- when would we get a module target?
807 defineMacro :: String -> GHCi ()
809 let (macro_name, definition) = break isSpace s
810 cmds <- io (readIORef commands)
812 then throwDyn (CmdLineError "invalid macro name")
814 if (macro_name `elem` map cmdName cmds)
815 then throwDyn (CmdLineError
816 ("command '" ++ macro_name ++ "' is already defined"))
819 -- give the expression a type signature, so we can be sure we're getting
820 -- something of the right type.
821 let new_expr = '(' : definition ++ ") :: String -> IO String"
823 -- compile the expression
825 maybe_hv <- io (GHC.compileExpr cms new_expr)
828 Just hv -> io (writeIORef commands --
829 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
831 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
833 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
834 enqueueCommands (lines str)
837 undefineMacro :: String -> GHCi ()
838 undefineMacro macro_name = do
839 cmds <- io (readIORef commands)
840 if (macro_name `elem` map cmdName builtin_commands)
841 then throwDyn (CmdLineError
842 ("command '" ++ macro_name ++ "' cannot be undefined"))
844 if (macro_name `notElem` map cmdName cmds)
845 then throwDyn (CmdLineError
846 ("command '" ++ macro_name ++ "' not defined"))
848 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
850 cmdCmd :: String -> GHCi ()
852 let expr = '(' : str ++ ") :: IO String"
853 session <- getSession
854 maybe_hv <- io (GHC.compileExpr session expr)
858 cmds <- io $ (unsafeCoerce# hv :: IO String)
859 enqueueCommands (lines cmds)
862 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
863 loadModule fs = timeIt (loadModule' fs)
865 loadModule_ :: [FilePath] -> GHCi ()
866 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
868 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
869 loadModule' files = do
870 session <- getSession
873 discardActiveBreakPoints
874 io (GHC.setTargets session [])
875 io (GHC.load session LoadAllTargets)
878 let (filenames, phases) = unzip files
879 exp_filenames <- mapM expandPath filenames
880 let files' = zip exp_filenames phases
881 targets <- io (mapM (uncurry GHC.guessTarget) files')
883 -- NOTE: we used to do the dependency anal first, so that if it
884 -- fails we didn't throw away the current set of modules. This would
885 -- require some re-working of the GHC interface, so we'll leave it
886 -- as a ToDo for now.
888 io (GHC.setTargets session targets)
889 doLoad session LoadAllTargets
891 checkModule :: String -> GHCi ()
893 let modl = GHC.mkModuleName m
894 session <- getSession
895 result <- io (GHC.checkModule session modl False)
897 Nothing -> io $ putStrLn "Nothing"
898 Just r -> io $ putStrLn (showSDoc (
899 case GHC.checkedModuleInfo r of
900 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
902 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
904 (text "global names: " <+> ppr global) $$
905 (text "local names: " <+> ppr local)
907 afterLoad (successIf (isJust result)) session
909 reloadModule :: String -> GHCi ()
911 session <- getSession
912 doLoad session $ if null m then LoadAllTargets
913 else LoadUpTo (GHC.mkModuleName m)
916 doLoad session howmuch = do
917 -- turn off breakpoints before we load: we can't turn them off later, because
918 -- the ModBreaks will have gone away.
919 discardActiveBreakPoints
920 ok <- io (GHC.load session howmuch)
924 afterLoad ok session = do
925 io (revertCAFs) -- always revert CAFs on load.
927 graph <- io (GHC.getModuleGraph session)
928 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
929 setContextAfterLoad session graph'
930 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
932 setContextAfterLoad session [] = do
933 prel_mod <- getPrelude
934 io (GHC.setContext session [] [prel_mod])
935 setContextAfterLoad session ms = do
936 -- load a target if one is available, otherwise load the topmost module.
937 targets <- io (GHC.getTargets session)
938 case [ m | Just m <- map (findTarget ms) targets ] of
940 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
941 load_this (last graph')
946 = case filter (`matches` t) ms of
950 summary `matches` Target (TargetModule m) _
951 = GHC.ms_mod_name summary == m
952 summary `matches` Target (TargetFile f _) _
953 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
954 summary `matches` target
957 load_this summary | m <- GHC.ms_mod summary = do
958 b <- io (GHC.moduleIsInterpreted session m)
959 if b then io (GHC.setContext session [m] [])
961 prel_mod <- getPrelude
962 io (GHC.setContext session [] [prel_mod,m])
965 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
966 modulesLoadedMsg ok mods = do
967 dflags <- getDynFlags
968 when (verbosity dflags > 0) $ do
970 | null mods = text "none."
972 punctuate comma (map ppr mods)) <> text "."
975 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
977 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
980 typeOfExpr :: String -> GHCi ()
982 = do cms <- getSession
983 maybe_ty <- io (GHC.exprType cms str)
986 Just ty -> do ty' <- cleanType ty
987 printForUser $ text str <> text " :: " <> ppr ty'
989 kindOfType :: String -> GHCi ()
991 = do cms <- getSession
992 maybe_ty <- io (GHC.typeKind cms str)
995 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
997 quit :: String -> GHCi Bool
1000 shellEscape :: String -> GHCi Bool
1001 shellEscape str = io (system str >> return False)
1003 -----------------------------------------------------------------------------
1004 -- Browsing a module's contents
1006 browseCmd :: String -> GHCi ()
1009 ['*':m] | looksLikeModuleName m -> browseModule m False
1010 [m] | looksLikeModuleName m -> browseModule m True
1011 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1013 browseModule m exports_only = do
1015 modl <- if exports_only then lookupModule m
1016 else wantInterpretedModule m
1018 -- Temporarily set the context to the module we're interested in,
1019 -- just so we can get an appropriate PrintUnqualified
1020 (as,bs) <- io (GHC.getContext s)
1021 prel_mod <- getPrelude
1022 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1023 else GHC.setContext s [modl] [])
1024 unqual <- io (GHC.getPrintUnqual s)
1025 io (GHC.setContext s as bs)
1027 mb_mod_info <- io $ GHC.getModuleInfo s modl
1029 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1032 | exports_only = GHC.modInfoExports mod_info
1033 | otherwise = GHC.modInfoTopLevelScope mod_info
1036 mb_things <- io $ mapM (GHC.lookupName s) names
1037 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1039 dflags <- getDynFlags
1040 let pefas = dopt Opt_PrintExplicitForalls dflags
1041 io (putStrLn (showSDocForUser unqual (
1042 vcat (map (pprTyThingInContext pefas) filtered_things)
1044 -- ToDo: modInfoInstances currently throws an exception for
1045 -- package modules. When it works, we can do this:
1046 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1048 -----------------------------------------------------------------------------
1049 -- Setting the module context
1052 | all sensible mods = fn mods
1053 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1055 (fn, mods) = case str of
1056 '+':stuff -> (addToContext, words stuff)
1057 '-':stuff -> (removeFromContext, words stuff)
1058 stuff -> (newContext, words stuff)
1060 sensible ('*':m) = looksLikeModuleName m
1061 sensible m = looksLikeModuleName m
1063 separate :: Session -> [String] -> [Module] -> [Module]
1064 -> GHCi ([Module],[Module])
1065 separate session [] as bs = return (as,bs)
1066 separate session (('*':str):ms) as bs = do
1067 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1068 b <- io $ GHC.moduleIsInterpreted session m
1069 if b then separate session ms (m:as) bs
1070 else throwDyn (CmdLineError ("module '"
1071 ++ GHC.moduleNameString (GHC.moduleName m)
1072 ++ "' is not interpreted"))
1073 separate session (str:ms) as bs = do
1074 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1075 separate session ms as (m:bs)
1077 newContext :: [String] -> GHCi ()
1078 newContext strs = do
1080 (as,bs) <- separate s strs [] []
1081 prel_mod <- getPrelude
1082 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1083 io $ GHC.setContext s as bs'
1086 addToContext :: [String] -> GHCi ()
1087 addToContext strs = do
1089 (as,bs) <- io $ GHC.getContext s
1091 (new_as,new_bs) <- separate s strs [] []
1093 let as_to_add = new_as \\ (as ++ bs)
1094 bs_to_add = new_bs \\ (as ++ bs)
1096 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1099 removeFromContext :: [String] -> GHCi ()
1100 removeFromContext strs = do
1102 (as,bs) <- io $ GHC.getContext s
1104 (as_to_remove,bs_to_remove) <- separate s strs [] []
1106 let as' = as \\ (as_to_remove ++ bs_to_remove)
1107 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1109 io $ GHC.setContext s as' bs'
1111 ----------------------------------------------------------------------------
1114 -- set options in the interpreter. Syntax is exactly the same as the
1115 -- ghc command line, except that certain options aren't available (-C,
1118 -- This is pretty fragile: most options won't work as expected. ToDo:
1119 -- figure out which ones & disallow them.
1121 setCmd :: String -> GHCi ()
1123 = do st <- getGHCiState
1124 let opts = options st
1125 io $ putStrLn (showSDoc (
1126 text "options currently set: " <>
1129 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1132 = case toArgs str of
1133 ("args":args) -> setArgs args
1134 ("prog":prog) -> setProg prog
1135 ("prompt":prompt) -> setPrompt (after 6)
1136 ("editor":cmd) -> setEditor (after 6)
1137 ("stop":cmd) -> setStop (after 4)
1138 wds -> setOptions wds
1139 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1143 setGHCiState st{ args = args }
1147 setGHCiState st{ progname = prog }
1149 io (hPutStrLn stderr "syntax: :set prog <progname>")
1153 setGHCiState st{ editor = cmd }
1155 setStop str@(c:_) | isDigit c
1156 = do let (nm_str,rest) = break (not.isDigit) str
1159 let old_breaks = breaks st
1160 if all ((/= nm) . fst) old_breaks
1161 then printForUser (text "Breakpoint" <+> ppr nm <+>
1162 text "does not exist")
1164 let new_breaks = map fn old_breaks
1165 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1166 | otherwise = (i,loc)
1167 setGHCiState st{ breaks = new_breaks }
1170 setGHCiState st{ stop = cmd }
1172 setPrompt value = do
1175 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1176 else setGHCiState st{ prompt = remQuotes value }
1178 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1182 do -- first, deal with the GHCi opts (+s, +t, etc.)
1183 let (plus_opts, minus_opts) = partition isPlus wds
1184 mapM_ setOpt plus_opts
1185 -- then, dynamic flags
1186 newDynFlags minus_opts
1188 newDynFlags minus_opts = do
1189 dflags <- getDynFlags
1190 let pkg_flags = packageFlags dflags
1191 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1193 if (not (null leftovers))
1194 then throwDyn (CmdLineError ("unrecognised flags: " ++
1198 new_pkgs <- setDynFlags dflags'
1200 -- if the package flags changed, we should reset the context
1201 -- and link the new packages.
1202 dflags <- getDynFlags
1203 when (packageFlags dflags /= pkg_flags) $ do
1204 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1205 session <- getSession
1206 io (GHC.setTargets session [])
1207 io (GHC.load session LoadAllTargets)
1208 io (linkPackages dflags new_pkgs)
1209 setContextAfterLoad session []
1213 unsetOptions :: String -> GHCi ()
1215 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1216 let opts = words str
1217 (minus_opts, rest1) = partition isMinus opts
1218 (plus_opts, rest2) = partition isPlus rest1
1220 if (not (null rest2))
1221 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1224 mapM_ unsetOpt plus_opts
1226 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1227 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1229 no_flags <- mapM no_flag minus_opts
1230 newDynFlags no_flags
1232 isMinus ('-':s) = True
1235 isPlus ('+':s) = True
1239 = case strToGHCiOpt str of
1240 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1241 Just o -> setOption o
1244 = case strToGHCiOpt str of
1245 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1246 Just o -> unsetOption o
1248 strToGHCiOpt :: String -> (Maybe GHCiOption)
1249 strToGHCiOpt "s" = Just ShowTiming
1250 strToGHCiOpt "t" = Just ShowType
1251 strToGHCiOpt "r" = Just RevertCAFs
1252 strToGHCiOpt _ = Nothing
1254 optToStr :: GHCiOption -> String
1255 optToStr ShowTiming = "s"
1256 optToStr ShowType = "t"
1257 optToStr RevertCAFs = "r"
1259 -- ---------------------------------------------------------------------------
1265 ["args"] -> io $ putStrLn (show (args st))
1266 ["prog"] -> io $ putStrLn (show (progname st))
1267 ["prompt"] -> io $ putStrLn (show (prompt st))
1268 ["editor"] -> io $ putStrLn (show (editor st))
1269 ["stop"] -> io $ putStrLn (show (stop st))
1270 ["modules" ] -> showModules
1271 ["bindings"] -> showBindings
1272 ["linker"] -> io showLinkerState
1273 ["breaks"] -> showBkptTable
1274 ["context"] -> showContext
1275 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1278 session <- getSession
1279 let show_one ms = do m <- io (GHC.showModule session ms)
1281 graph <- io (GHC.getModuleGraph session)
1282 mapM_ show_one graph
1286 unqual <- io (GHC.getPrintUnqual s)
1287 bindings <- io (GHC.getBindings s)
1288 mapM_ printTyThing $ sortBy compareTyThings bindings
1291 compareTyThings :: TyThing -> TyThing -> Ordering
1292 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1294 showTyThing :: TyThing -> GHCi (Maybe SDoc)
1295 showTyThing (AnId id) = do
1296 ty' <- cleanType (GHC.idType id)
1297 return $ Just $ ppr id <> text " :: " <> ppr ty'
1298 showTyThing _ = return Nothing
1300 printTyThing :: TyThing -> GHCi ()
1301 printTyThing tyth = do
1302 mb_x <- showTyThing tyth
1304 Just x -> printForUser x
1305 Nothing -> return ()
1307 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1308 cleanType :: Type -> GHCi Type
1310 dflags <- getDynFlags
1311 if dopt Opt_PrintExplicitForalls dflags
1313 else return $! GHC.dropForAlls ty
1315 showBkptTable :: GHCi ()
1318 printForUser $ prettyLocations (breaks st)
1320 showContext :: GHCi ()
1322 session <- getSession
1323 resumes <- io $ GHC.getResumeContext session
1324 printForUser $ vcat (map pp_resume (reverse resumes))
1327 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1328 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1331 -- -----------------------------------------------------------------------------
1334 completeNone :: String -> IO [String]
1335 completeNone w = return []
1338 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1339 completeWord w start end = do
1340 line <- Readline.getLineBuffer
1342 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1344 | Just c <- is_cmd line -> do
1345 maybe_cmd <- lookupCommand c
1346 let (n,w') = selectWord (words' 0 line)
1348 Nothing -> return Nothing
1349 Just (_,_,False,complete) -> wrapCompleter complete w
1350 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1351 return (map (drop n) rets)
1352 in wrapCompleter complete' w'
1354 --printf "complete %s, start = %d, end = %d\n" w start end
1355 wrapCompleter completeIdentifier w
1356 where words' _ [] = []
1357 words' n str = let (w,r) = break isSpace str
1358 (s,r') = span isSpace r
1359 in (n,w):words' (n+length w+length s) r'
1360 -- In a Haskell expression we want to parse 'a-b' as three words
1361 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1362 -- only be a single word.
1363 selectWord [] = (0,w)
1364 selectWord ((offset,x):xs)
1365 | offset+length x >= start = (start-offset,take (end-offset) x)
1366 | otherwise = selectWord xs
1369 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1370 | otherwise = Nothing
1373 cmds <- readIORef commands
1374 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1376 completeMacro w = do
1377 cmds <- readIORef commands
1378 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1379 return (filter (w `isPrefixOf`) cmds')
1381 completeIdentifier w = do
1383 rdrs <- GHC.getRdrNamesInScope s
1384 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1386 completeModule w = do
1388 dflags <- GHC.getSessionDynFlags s
1389 let pkg_mods = allExposedModules dflags
1390 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1392 completeHomeModule w = do
1394 g <- GHC.getModuleGraph s
1395 let home_mods = map GHC.ms_mod_name g
1396 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1398 completeSetOptions w = do
1399 return (filter (w `isPrefixOf`) options)
1400 where options = "args":"prog":allFlags
1402 completeFilename = Readline.filenameCompletionFunction
1404 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1406 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1407 unionComplete f1 f2 w = do
1412 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1413 wrapCompleter fun w = do
1416 [] -> return Nothing
1417 [x] -> return (Just (x,[]))
1418 xs -> case getCommonPrefix xs of
1419 "" -> return (Just ("",xs))
1420 pref -> return (Just (pref,xs))
1422 getCommonPrefix :: [String] -> String
1423 getCommonPrefix [] = ""
1424 getCommonPrefix (s:ss) = foldl common s ss
1425 where common s "" = ""
1427 common (c:cs) (d:ds)
1428 | c == d = c : common cs ds
1431 allExposedModules :: DynFlags -> [ModuleName]
1432 allExposedModules dflags
1433 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1435 pkg_db = pkgIdMap (pkgState dflags)
1437 completeCmd = completeNone
1438 completeMacro = completeNone
1439 completeIdentifier = completeNone
1440 completeModule = completeNone
1441 completeHomeModule = completeNone
1442 completeSetOptions = completeNone
1443 completeFilename = completeNone
1444 completeHomeModuleOrFile=completeNone
1445 completeBkpt = completeNone
1448 -- ---------------------------------------------------------------------------
1449 -- User code exception handling
1451 -- This is the exception handler for exceptions generated by the
1452 -- user's code and exceptions coming from children sessions;
1453 -- it normally just prints out the exception. The
1454 -- handler must be recursive, in case showing the exception causes
1455 -- more exceptions to be raised.
1457 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1458 -- raising another exception. We therefore don't put the recursive
1459 -- handler arond the flushing operation, so if stderr is closed
1460 -- GHCi will just die gracefully rather than going into an infinite loop.
1461 handler :: Exception -> GHCi Bool
1463 handler exception = do
1465 io installSignalHandlers
1466 ghciHandle handler (showException exception >> return False)
1468 showException (DynException dyn) =
1469 case fromDynamic dyn of
1470 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1471 Just Interrupted -> io (putStrLn "Interrupted.")
1472 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1473 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1474 Just other_ghc_ex -> io (print other_ghc_ex)
1476 showException other_exception
1477 = io (putStrLn ("*** Exception: " ++ show other_exception))
1479 -----------------------------------------------------------------------------
1480 -- recursive exception handlers
1482 -- Don't forget to unblock async exceptions in the handler, or if we're
1483 -- in an exception loop (eg. let a = error a in a) the ^C exception
1484 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1486 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1487 ghciHandle h (GHCi m) = GHCi $ \s ->
1488 Exception.catch (m s)
1489 (\e -> unGHCi (ghciUnblock (h e)) s)
1491 ghciUnblock :: GHCi a -> GHCi a
1492 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1495 -- ----------------------------------------------------------------------------
1498 expandPath :: String -> GHCi String
1500 case dropWhile isSpace path of
1502 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1503 return (tilde ++ '/':d)
1507 wantInterpretedModule :: String -> GHCi Module
1508 wantInterpretedModule str = do
1509 session <- getSession
1510 modl <- lookupModule str
1511 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1512 when (not is_interpreted) $
1513 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1516 wantNameFromInterpretedModule noCanDo str and_then = do
1517 session <- getSession
1518 names <- io $ GHC.parseName session str
1522 let modl = GHC.nameModule n
1523 if not (GHC.isExternalName n)
1524 then noCanDo n $ ppr n <>
1525 text " is not defined in an interpreted module"
1527 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1528 if not is_interpreted
1529 then noCanDo n $ text "module " <> ppr modl <>
1530 text " is not interpreted"
1533 -- ----------------------------------------------------------------------------
1534 -- Windows console setup
1536 setUpConsole :: IO ()
1538 #ifdef mingw32_HOST_OS
1539 -- On Windows we need to set a known code page, otherwise the characters
1540 -- we read from the console will be be in some strange encoding, and
1541 -- similarly for characters we write to the console.
1543 -- At the moment, GHCi pretends all input is Latin-1. In the
1544 -- future we should support UTF-8, but for now we set the code pages
1547 -- It seems you have to set the font in the console window to
1548 -- a Unicode font in order for output to work properly,
1549 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1550 -- (see MSDN for SetConsoleOutputCP()).
1552 setConsoleCP 28591 -- ISO Latin-1
1553 setConsoleOutputCP 28591 -- ISO Latin-1
1557 -- -----------------------------------------------------------------------------
1558 -- commands for debugger
1560 sprintCmd = pprintCommand False False
1561 printCmd = pprintCommand True False
1562 forceCmd = pprintCommand False True
1564 pprintCommand bind force str = do
1565 session <- getSession
1566 io $ pprintClosureCommand session bind force str
1568 stepCmd :: String -> GHCi ()
1569 stepCmd [] = doContinue (const True) GHC.SingleStep
1570 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1572 stepLocalCmd :: String -> GHCi ()
1573 stepLocalCmd [] = do
1574 mb_span <- getCurrentBreakSpan
1576 Nothing -> stepCmd []
1578 Just mod <- getCurrentBreakModule
1579 current_toplevel_decl <- enclosingTickSpan mod loc
1580 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1582 stepLocalCmd expression = stepCmd expression
1584 stepModuleCmd :: String -> GHCi ()
1585 stepModuleCmd [] = do
1586 mb_span <- getCurrentBreakSpan
1588 Nothing -> stepCmd []
1590 Just span <- getCurrentBreakSpan
1591 let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
1592 doContinue f GHC.SingleStep
1594 stepModuleCmd expression = stepCmd expression
1596 -- | Returns the span of the largest tick containing the srcspan given
1597 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1598 enclosingTickSpan mod src = do
1599 ticks <- getTickArray mod
1600 let line = srcSpanStartLine src
1601 ASSERT (inRange (bounds ticks) line) do
1602 let enclosing_spans = [ span | (_,span) <- ticks ! line
1603 , srcSpanEnd span >= srcSpanEnd src]
1604 return . head . sortBy leftmost_largest $ enclosing_spans
1606 traceCmd :: String -> GHCi ()
1607 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1608 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1610 continueCmd :: String -> GHCi ()
1611 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1613 -- doContinue :: SingleStep -> GHCi ()
1614 doContinue pred step = do
1615 session <- getSession
1616 runResult <- io $ GHC.resume session step
1617 afterRunStmt pred runResult
1620 abandonCmd :: String -> GHCi ()
1621 abandonCmd = noArgs $ do
1623 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1624 when (not b) $ io $ putStrLn "There is no computation running."
1627 deleteCmd :: String -> GHCi ()
1628 deleteCmd argLine = do
1629 deleteSwitch $ words argLine
1631 deleteSwitch :: [String] -> GHCi ()
1633 io $ putStrLn "The delete command requires at least one argument."
1634 -- delete all break points
1635 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1636 deleteSwitch idents = do
1637 mapM_ deleteOneBreak idents
1639 deleteOneBreak :: String -> GHCi ()
1641 | all isDigit str = deleteBreak (read str)
1642 | otherwise = return ()
1644 historyCmd :: String -> GHCi ()
1646 | null arg = history 20
1647 | all isDigit arg = history (read arg)
1648 | otherwise = io $ putStrLn "Syntax: :history [num]"
1652 resumes <- io $ GHC.getResumeContext s
1654 [] -> io $ putStrLn "Not stopped at a breakpoint"
1656 let hist = GHC.resumeHistory r
1657 (took,rest) = splitAt num hist
1658 spans <- mapM (io . GHC.getHistorySpan s) took
1659 let nums = map (printf "-%-3d:") [(1::Int)..]
1660 let names = map GHC.historyEnclosingDecl took
1661 printForUser (vcat(zipWith3
1662 (\x y z -> x <+> y <+> z)
1664 (map (bold . ppr) names)
1665 (map (parens . ppr) spans)))
1666 io $ putStrLn $ if null rest then "<end of history>" else "..."
1668 bold c | do_bold = text start_bold <> c <> text end_bold
1671 backCmd :: String -> GHCi ()
1672 backCmd = noArgs $ do
1674 (names, ix, span) <- io $ GHC.back s
1675 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1676 printTypeOfNames s names
1677 -- run the command set with ":set stop <cmd>"
1679 enqueueCommands [stop st]
1681 forwardCmd :: String -> GHCi ()
1682 forwardCmd = noArgs $ do
1684 (names, ix, span) <- io $ GHC.forward s
1685 printForUser $ (if (ix == 0)
1686 then ptext SLIT("Stopped at")
1687 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1688 printTypeOfNames s names
1689 -- run the command set with ":set stop <cmd>"
1691 enqueueCommands [stop st]
1693 -- handle the "break" command
1694 breakCmd :: String -> GHCi ()
1695 breakCmd argLine = do
1696 session <- getSession
1697 breakSwitch session $ words argLine
1699 breakSwitch :: Session -> [String] -> GHCi ()
1700 breakSwitch _session [] = do
1701 io $ putStrLn "The break command requires at least one argument."
1702 breakSwitch session args@(arg1:rest)
1703 | looksLikeModuleName arg1 = do
1704 mod <- wantInterpretedModule arg1
1705 breakByModule session mod rest
1706 | all isDigit arg1 = do
1707 (toplevel, _) <- io $ GHC.getContext session
1709 (mod : _) -> breakByModuleLine mod (read arg1) rest
1711 io $ putStrLn "Cannot find default module for breakpoint."
1712 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1713 | otherwise = do -- try parsing it as an identifier
1714 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1715 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1716 if GHC.isGoodSrcLoc loc
1717 then findBreakAndSet (GHC.nameModule name) $
1718 findBreakByCoord (Just (GHC.srcLocFile loc))
1719 (GHC.srcLocLine loc,
1721 else noCanDo name $ text "can't find its location: " <> ppr loc
1723 noCanDo n why = printForUser $
1724 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1726 breakByModule :: Session -> Module -> [String] -> GHCi ()
1727 breakByModule session mod args@(arg1:rest)
1728 | all isDigit arg1 = do -- looks like a line number
1729 breakByModuleLine mod (read arg1) rest
1730 breakByModule session mod _
1733 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1734 breakByModuleLine mod line args
1735 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1736 | [col] <- args, all isDigit col =
1737 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1738 | otherwise = breakSyntax
1740 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1742 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1743 findBreakAndSet mod lookupTickTree = do
1744 tickArray <- getTickArray mod
1745 (breakArray, _) <- getModBreak mod
1746 case lookupTickTree tickArray of
1747 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1748 Just (tick, span) -> do
1749 success <- io $ setBreakFlag True breakArray tick
1750 session <- getSession
1754 recordBreak $ BreakLocation
1761 text "Breakpoint " <> ppr nm <>
1763 then text " was already set at " <> ppr span
1764 else text " activated at " <> ppr span
1766 printForUser $ text "Breakpoint could not be activated at"
1769 -- When a line number is specified, the current policy for choosing
1770 -- the best breakpoint is this:
1771 -- - the leftmost complete subexpression on the specified line, or
1772 -- - the leftmost subexpression starting on the specified line, or
1773 -- - the rightmost subexpression enclosing the specified line
1775 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1776 findBreakByLine line arr
1777 | not (inRange (bounds arr) line) = Nothing
1779 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
1780 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
1781 listToMaybe (sortBy (rightmost `on` snd) ticks)
1785 starts_here = [ tick | tick@(nm,span) <- ticks,
1786 GHC.srcSpanStartLine span == line ]
1788 (complete,incomplete) = partition ends_here starts_here
1789 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1791 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1792 -> Maybe (BreakIndex,SrcSpan)
1793 findBreakByCoord mb_file (line, col) arr
1794 | not (inRange (bounds arr) line) = Nothing
1796 listToMaybe (sortBy (rightmost `on` snd) contains ++
1797 sortBy (leftmost_smallest `on` snd) after_here)
1801 -- the ticks that span this coordinate
1802 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1803 is_correct_file span ]
1805 is_correct_file span
1806 | Just f <- mb_file = GHC.srcSpanFile span == f
1809 after_here = [ tick | tick@(nm,span) <- ticks,
1810 GHC.srcSpanStartLine span == line,
1811 GHC.srcSpanStartCol span >= col ]
1813 -- for now, use ANSI bold on Unixy systems. On Windows, we add a line
1814 -- of carets under the active expression instead. The Windows console
1815 -- doesn't support ANSI escape sequences, and most Unix terminals
1816 -- (including xterm) do, so this is a reasonable guess until we have a
1817 -- proper termcap/terminfo library.
1818 #if !defined(mingw32_TARGET_OS)
1824 start_bold = "\ESC[1m"
1825 end_bold = "\ESC[0m"
1827 listCmd :: String -> GHCi ()
1829 mb_span <- getCurrentBreakSpan
1831 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1832 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1833 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
1834 listCmd str = list2 (words str)
1836 list2 [arg] | all isDigit arg = do
1837 session <- getSession
1838 (toplevel, _) <- io $ GHC.getContext session
1840 [] -> io $ putStrLn "No module to list"
1841 (mod : _) -> listModuleLine mod (read arg)
1842 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1843 mod <- wantInterpretedModule arg1
1844 listModuleLine mod (read arg2)
1846 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1847 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1848 if GHC.isGoodSrcLoc loc
1850 tickArray <- getTickArray (GHC.nameModule name)
1851 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1852 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1855 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1856 Just (_,span) -> io $ listAround span False
1858 noCanDo name $ text "can't find its location: " <>
1861 noCanDo n why = printForUser $
1862 text "cannot list source code for " <> ppr n <> text ": " <> why
1864 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1866 listModuleLine :: Module -> Int -> GHCi ()
1867 listModuleLine modl line = do
1868 session <- getSession
1869 graph <- io (GHC.getModuleGraph session)
1870 let this = filter ((== modl) . GHC.ms_mod) graph
1872 [] -> panic "listModuleLine"
1874 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1875 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1876 io $ listAround (GHC.srcLocSpan loc) False
1878 -- | list a section of a source file around a particular SrcSpan.
1879 -- If the highlight flag is True, also highlight the span using
1880 -- start_bold/end_bold.
1881 listAround span do_highlight = do
1882 contents <- BS.readFile (unpackFS file)
1884 lines = BS.split '\n' contents
1885 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1886 drop (line1 - 1 - pad_before) $ lines
1887 fst_line = max 1 (line1 - pad_before)
1888 line_nos = [ fst_line .. ]
1890 highlighted | do_highlight = zipWith highlight line_nos these_lines
1891 | otherwise = these_lines
1893 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1894 prefixed = zipWith BS.append bs_line_nos highlighted
1896 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1898 file = GHC.srcSpanFile span
1899 line1 = GHC.srcSpanStartLine span
1900 col1 = GHC.srcSpanStartCol span
1901 line2 = GHC.srcSpanEndLine span
1902 col2 = GHC.srcSpanEndCol span
1904 pad_before | line1 == 1 = 0
1908 highlight | do_bold = highlight_bold
1909 | otherwise = highlight_carets
1911 highlight_bold no line
1912 | no == line1 && no == line2
1913 = let (a,r) = BS.splitAt col1 line
1914 (b,c) = BS.splitAt (col2-col1) r
1916 BS.concat [a,BS.pack start_bold,b,BS.pack end_bold,c]
1918 = let (a,b) = BS.splitAt col1 line in
1919 BS.concat [a, BS.pack start_bold, b]
1921 = let (a,b) = BS.splitAt col2 line in
1922 BS.concat [a, BS.pack end_bold, b]
1925 highlight_carets no line
1926 | no == line1 && no == line2
1927 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1928 BS.replicate (col2-col1) '^']
1930 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1931 BS.replicate (BS.length line-col1) '^']
1933 = BS.concat [line, nl, indent, BS.replicate col2 '^']
1936 indent = BS.pack " "
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