1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005-2006
8 -----------------------------------------------------------------------------
14 #include "HsVersions.h"
22 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
23 Type, Module, ModuleName, TyThing(..), Phase,
24 BreakIndex, Name, SrcSpan, Resume, SingleStep )
30 import Outputable hiding (printForUser)
31 import Module -- for ModuleEnv
33 -- Other random utilities
35 import BasicTypes hiding (isTopLevel)
36 import Panic hiding (showException)
43 #ifndef mingw32_HOST_OS
45 #if __GLASGOW_HASKELL__ > 504
49 import GHC.ConsoleHandler ( flushConsole )
50 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
51 import qualified System.Win32
55 import Control.Concurrent ( yield ) -- Used in readline loop
56 import System.Console.Readline as Readline
61 import Control.Exception as Exception
62 -- import Control.Concurrent
64 import qualified Data.ByteString.Char8 as BS
68 import System.Environment
69 import System.Exit ( exitWith, ExitCode(..) )
70 import System.Directory
72 import System.IO.Error as IO
73 import System.FilePath
77 import Control.Monad as Monad
80 import Foreign.StablePtr ( newStablePtr )
81 import GHC.Exts ( unsafeCoerce# )
82 import GHC.IOBase ( IOErrorType(InvalidArgument) )
84 import Data.IORef ( IORef, readIORef, writeIORef )
86 import System.Posix.Internals ( setNonBlockingFD )
88 -----------------------------------------------------------------------------
92 " / _ \\ /\\ /\\/ __(_)\n"++
93 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
94 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
95 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
97 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
100 GLOBAL_VAR(commands, builtin_commands, [Command])
102 builtin_commands :: [Command]
104 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
105 ("?", keepGoing help, False, completeNone),
106 ("add", keepGoingPaths addModule, False, completeFilename),
107 ("abandon", keepGoing abandonCmd, False, completeNone),
108 ("break", keepGoing breakCmd, False, completeIdentifier),
109 ("back", keepGoing backCmd, False, completeNone),
110 ("browse", keepGoing browseCmd, False, completeModule),
111 ("cd", keepGoing changeDirectory, False, completeFilename),
112 ("check", keepGoing checkModule, False, completeHomeModule),
113 ("continue", keepGoing continueCmd, False, completeNone),
114 ("cmd", keepGoing cmdCmd, False, completeIdentifier),
115 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
116 ("def", keepGoing defineMacro, False, completeIdentifier),
117 ("delete", keepGoing deleteCmd, False, completeNone),
118 ("e", keepGoing editFile, False, completeFilename),
119 ("edit", keepGoing editFile, False, completeFilename),
120 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
121 ("force", keepGoing forceCmd, False, completeIdentifier),
122 ("forward", keepGoing forwardCmd, False, completeNone),
123 ("help", keepGoing help, False, completeNone),
124 ("history", keepGoing historyCmd, False, completeNone),
125 ("info", keepGoing info, False, completeIdentifier),
126 ("kind", keepGoing kindOfType, False, completeIdentifier),
127 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
128 ("list", keepGoing listCmd, False, completeNone),
129 ("module", keepGoing setContext, False, completeModule),
130 ("main", keepGoing runMain, False, completeIdentifier),
131 ("print", keepGoing printCmd, False, completeIdentifier),
132 ("quit", quit, False, completeNone),
133 ("reload", keepGoing reloadModule, False, completeNone),
134 ("set", keepGoing setCmd, True, completeSetOptions),
135 ("show", keepGoing showCmd, False, completeNone),
136 ("sprint", keepGoing sprintCmd, False, completeIdentifier),
137 ("step", keepGoing stepCmd, False, completeIdentifier),
138 ("type", keepGoing typeOfExpr, False, completeIdentifier),
139 ("trace", keepGoing traceCmd, False, completeIdentifier),
140 ("undef", keepGoing undefineMacro, False, completeMacro),
141 ("unset", keepGoing unsetOptions, True, completeSetOptions)
144 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
145 keepGoing a str = a str >> return False
147 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
148 keepGoingPaths a str = a (toArgs str) >> return False
150 shortHelpText = "use :? for help.\n"
153 " Commands available from the prompt:\n" ++
155 " <statement> evaluate/run <statement>\n" ++
156 " :add <filename> ... add module(s) to the current target set\n" ++
157 " :browse [*]<module> display the names defined by <module>\n" ++
158 " :cd <dir> change directory to <dir>\n" ++
159 " :cmd <expr> run the commands returned by <expr>::IO String"++
160 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
161 " :def <cmd> <expr> define a command :<cmd>\n" ++
162 " :edit <file> edit file\n" ++
163 " :edit edit last module\n" ++
164 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
165 " :help, :? display this list of commands\n" ++
166 " :info [<name> ...] display information about the given names\n" ++
167 " :kind <type> show the kind of <type>\n" ++
168 " :load <filename> ... load module(s) and their dependents\n" ++
169 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
170 " :main [<arguments> ...] run the main function with the given arguments\n" ++
171 " :quit exit GHCi\n" ++
172 " :reload reload the current module set\n" ++
173 " :type <expr> show the type of <expr>\n" ++
174 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
175 " :!<command> run the shell command <command>\n" ++
177 " -- Commands for debugging:\n" ++
179 " :abandon at a breakpoint, abandon current computation\n" ++
180 " :back go back in the history (after :trace)\n" ++
181 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
182 " :break <name> set a breakpoint on the specified function\n" ++
183 " :continue resume after a breakpoint\n" ++
184 " :delete <number> delete the specified breakpoint\n" ++
185 " :delete * delete all breakpoints\n" ++
186 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
187 " :forward go forward in the history (after :back)\n" ++
188 " :history [<n>] show the last <n> items in the history (after :trace)\n" ++
189 " :print [<name> ...] prints a value without forcing its computation\n" ++
190 " :sprint [<name> ...] simplifed version of :print\n" ++
191 " :step single-step after stopping at a breakpoint\n"++
192 " :step <expr> single-step into <expr>\n"++
193 " :trace trace after stopping at a breakpoint\n"++
194 " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
197 " -- Commands for changing settings:\n" ++
199 " :set <option> ... set options\n" ++
200 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
201 " :set prog <progname> set the value returned by System.getProgName\n" ++
202 " :set prompt <prompt> set the prompt used in GHCi\n" ++
203 " :set editor <cmd> set the command used for :edit\n" ++
204 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
205 " :unset <option> ... unset options\n" ++
207 " Options for ':set' and ':unset':\n" ++
209 " +r revert top-level expressions after each evaluation\n" ++
210 " +s print timing/memory stats after each evaluation\n" ++
211 " +t print type after evaluation\n" ++
212 " -<flags> most GHC command line flags can also be set here\n" ++
213 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
215 " -- Commands for displaying information:\n" ++
217 " :show bindings show the current bindings made at the prompt\n" ++
218 " :show breaks show the active breakpoints\n" ++
219 " :show context show the breakpoint context\n" ++
220 " :show modules show the currently loaded modules\n" ++
221 " :show <setting> show anything that can be set with :set (e.g. args)\n" ++
228 win <- System.Win32.getWindowsDirectory
229 return (win `joinFileName` "notepad.exe")
234 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
235 interactiveUI session srcs maybe_expr = do
236 -- HACK! If we happen to get into an infinite loop (eg the user
237 -- types 'let x=x in x' at the prompt), then the thread will block
238 -- on a blackhole, and become unreachable during GC. The GC will
239 -- detect that it is unreachable and send it the NonTermination
240 -- exception. However, since the thread is unreachable, everything
241 -- it refers to might be finalized, including the standard Handles.
242 -- This sounds like a bug, but we don't have a good solution right
248 -- Initialise buffering for the *interpreted* I/O system
249 initInterpBuffering session
251 when (isNothing maybe_expr) $ do
252 -- 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
568 afterRunStmt :: GHC.RunResult -> GHCi Bool
569 -- False <=> the statement failed to compile
570 afterRunStmt (GHC.RunException e) = throw e
571 afterRunStmt run_result = do
572 session <- getSession
574 GHC.RunOk names -> do
575 show_types <- isOptionSet ShowType
576 when show_types $ mapM_ (showTypeOfName session) names
577 GHC.RunBreak _ names mb_info -> do
578 resumes <- io $ GHC.getResumeContext session
579 printForUser $ ptext SLIT("Stopped at") <+>
580 ppr (GHC.resumeSpan (head resumes))
581 mapM_ (showTypeOfName session) names
582 maybe (return ()) runBreakCmd mb_info
583 -- run the command set with ":set stop <cmd>"
585 enqueueCommands [stop st]
590 io installSignalHandlers
591 b <- isOptionSet RevertCAFs
592 io (when b revertCAFs)
594 return (case run_result of GHC.RunOk _ -> True; _ -> False)
596 runBreakCmd :: GHC.BreakInfo -> GHCi ()
597 runBreakCmd info = do
598 let mod = GHC.breakInfo_module info
599 nm = GHC.breakInfo_number info
601 case [ loc | (i,loc) <- breaks st,
602 breakModule loc == mod, breakTick loc == nm ] of
604 loc:_ | null cmd -> return ()
605 | otherwise -> do enqueueCommands [cmd]; return ()
606 where cmd = onBreakCmd loc
608 showTypeOfName :: Session -> Name -> GHCi ()
609 showTypeOfName session n
610 = do maybe_tything <- io (GHC.lookupName session n)
611 case maybe_tything of
613 Just thing -> showTyThing thing
615 specialCommand :: String -> GHCi Bool
616 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
617 specialCommand str = do
618 let (cmd,rest) = break isSpace str
619 maybe_cmd <- io (lookupCommand cmd)
621 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
622 ++ shortHelpText) >> return False)
623 Just (_,f,_,_) -> f (dropWhile isSpace rest)
625 lookupCommand :: String -> IO (Maybe Command)
626 lookupCommand str = do
627 cmds <- readIORef commands
628 -- look for exact match first, then the first prefix match
629 case [ c | c <- cmds, str == cmdName c ] of
630 c:_ -> return (Just c)
631 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
633 c:_ -> return (Just c)
636 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
637 getCurrentBreakSpan = do
638 session <- getSession
639 resumes <- io $ GHC.getResumeContext session
643 let ix = GHC.resumeHistoryIx r
645 then return (Just (GHC.resumeSpan r))
647 let hist = GHC.resumeHistory r !! (ix-1)
648 span <- io $ GHC.getHistorySpan session hist
651 -----------------------------------------------------------------------------
654 noArgs :: GHCi () -> String -> GHCi ()
656 noArgs m _ = io $ putStrLn "This command takes no arguments"
658 help :: String -> GHCi ()
659 help _ = io (putStr helpText)
661 info :: String -> GHCi ()
662 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
663 info s = do { let names = words s
664 ; session <- getSession
665 ; dflags <- getDynFlags
666 ; let exts = dopt Opt_GlasgowExts dflags
667 ; mapM_ (infoThing exts session) names }
669 infoThing exts session str = io $ do
670 names <- GHC.parseName session str
671 let filtered = filterOutChildren names
672 mb_stuffs <- mapM (GHC.getInfo session) filtered
673 unqual <- GHC.getPrintUnqual session
674 putStrLn (showSDocForUser unqual $
675 vcat (intersperse (text "") $
676 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
678 -- Filter out names whose parent is also there Good
679 -- example is '[]', which is both a type and data
680 -- constructor in the same type
681 filterOutChildren :: [Name] -> [Name]
682 filterOutChildren names = filter (not . parent_is_there) names
683 where parent_is_there n
684 -- | Just p <- GHC.nameParent_maybe n = p `elem` names
688 pprInfo exts (thing, fixity, insts)
689 = pprTyThingInContextLoc exts thing
690 $$ show_fixity fixity
691 $$ vcat (map GHC.pprInstance insts)
694 | fix == GHC.defaultFixity = empty
695 | otherwise = ppr fix <+> ppr (GHC.getName thing)
697 runMain :: String -> GHCi ()
699 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
700 enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
702 addModule :: [FilePath] -> GHCi ()
704 io (revertCAFs) -- always revert CAFs on load/add.
705 files <- mapM expandPath files
706 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
707 session <- getSession
708 io (mapM_ (GHC.addTarget session) targets)
709 ok <- io (GHC.load session LoadAllTargets)
712 changeDirectory :: String -> GHCi ()
713 changeDirectory dir = do
714 session <- getSession
715 graph <- io (GHC.getModuleGraph session)
716 when (not (null graph)) $
717 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
718 io (GHC.setTargets session [])
719 io (GHC.load session LoadAllTargets)
720 setContextAfterLoad session []
721 io (GHC.workingDirectoryChanged session)
722 dir <- expandPath dir
723 io (setCurrentDirectory dir)
725 editFile :: String -> GHCi ()
728 -- find the name of the "topmost" file loaded
729 session <- getSession
730 graph0 <- io (GHC.getModuleGraph session)
731 graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
732 let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
733 case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
734 Just file -> do_edit file
735 Nothing -> throwDyn (CmdLineError "unknown file name")
736 | otherwise = do_edit str
742 throwDyn (CmdLineError "editor not set, use :set editor")
743 io $ system (cmd ++ ' ':file)
746 defineMacro :: String -> GHCi ()
748 let (macro_name, definition) = break isSpace s
749 cmds <- io (readIORef commands)
751 then throwDyn (CmdLineError "invalid macro name")
753 if (macro_name `elem` map cmdName cmds)
754 then throwDyn (CmdLineError
755 ("command '" ++ macro_name ++ "' is already defined"))
758 -- give the expression a type signature, so we can be sure we're getting
759 -- something of the right type.
760 let new_expr = '(' : definition ++ ") :: String -> IO String"
762 -- compile the expression
764 maybe_hv <- io (GHC.compileExpr cms new_expr)
767 Just hv -> io (writeIORef commands --
768 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
770 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
772 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
773 enqueueCommands (lines str)
776 undefineMacro :: String -> GHCi ()
777 undefineMacro macro_name = do
778 cmds <- io (readIORef commands)
779 if (macro_name `elem` map cmdName builtin_commands)
780 then throwDyn (CmdLineError
781 ("command '" ++ macro_name ++ "' cannot be undefined"))
783 if (macro_name `notElem` map cmdName cmds)
784 then throwDyn (CmdLineError
785 ("command '" ++ macro_name ++ "' not defined"))
787 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
789 cmdCmd :: String -> GHCi ()
791 let expr = '(' : str ++ ") :: IO String"
792 session <- getSession
793 maybe_hv <- io (GHC.compileExpr session expr)
797 cmds <- io $ (unsafeCoerce# hv :: IO String)
798 enqueueCommands (lines cmds)
801 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
802 loadModule fs = timeIt (loadModule' fs)
804 loadModule_ :: [FilePath] -> GHCi ()
805 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
807 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
808 loadModule' files = do
809 session <- getSession
812 discardActiveBreakPoints
813 io (GHC.setTargets session [])
814 io (GHC.load session LoadAllTargets)
817 let (filenames, phases) = unzip files
818 exp_filenames <- mapM expandPath filenames
819 let files' = zip exp_filenames phases
820 targets <- io (mapM (uncurry GHC.guessTarget) files')
822 -- NOTE: we used to do the dependency anal first, so that if it
823 -- fails we didn't throw away the current set of modules. This would
824 -- require some re-working of the GHC interface, so we'll leave it
825 -- as a ToDo for now.
827 io (GHC.setTargets session targets)
828 doLoad session LoadAllTargets
830 checkModule :: String -> GHCi ()
832 let modl = GHC.mkModuleName m
833 session <- getSession
834 result <- io (GHC.checkModule session modl)
836 Nothing -> io $ putStrLn "Nothing"
837 Just r -> io $ putStrLn (showSDoc (
838 case GHC.checkedModuleInfo r of
839 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
841 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
843 (text "global names: " <+> ppr global) $$
844 (text "local names: " <+> ppr local)
846 afterLoad (successIf (isJust result)) session
848 reloadModule :: String -> GHCi ()
850 io (revertCAFs) -- always revert CAFs on reload.
851 discardActiveBreakPoints
852 session <- getSession
853 doLoad session LoadAllTargets
856 io (revertCAFs) -- always revert CAFs on reload.
857 discardActiveBreakPoints
858 session <- getSession
859 doLoad session (LoadUpTo (GHC.mkModuleName m))
862 doLoad session howmuch = do
863 -- turn off breakpoints before we load: we can't turn them off later, because
864 -- the ModBreaks will have gone away.
865 discardActiveBreakPoints
866 ok <- io (GHC.load session howmuch)
870 afterLoad ok session = do
871 io (revertCAFs) -- always revert CAFs on load.
873 graph <- io (GHC.getModuleGraph session)
874 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
875 setContextAfterLoad session graph'
876 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
878 setContextAfterLoad session [] = do
879 prel_mod <- getPrelude
880 io (GHC.setContext session [] [prel_mod])
881 setContextAfterLoad session ms = do
882 -- load a target if one is available, otherwise load the topmost module.
883 targets <- io (GHC.getTargets session)
884 case [ m | Just m <- map (findTarget ms) targets ] of
886 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
887 load_this (last graph')
892 = case filter (`matches` t) ms of
896 summary `matches` Target (TargetModule m) _
897 = GHC.ms_mod_name summary == m
898 summary `matches` Target (TargetFile f _) _
899 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
900 summary `matches` target
903 load_this summary | m <- GHC.ms_mod summary = do
904 b <- io (GHC.moduleIsInterpreted session m)
905 if b then io (GHC.setContext session [m] [])
907 prel_mod <- getPrelude
908 io (GHC.setContext session [] [prel_mod,m])
911 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
912 modulesLoadedMsg ok mods = do
913 dflags <- getDynFlags
914 when (verbosity dflags > 0) $ do
916 | null mods = text "none."
918 punctuate comma (map ppr mods)) <> text "."
921 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
923 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
926 typeOfExpr :: String -> GHCi ()
928 = do cms <- getSession
929 maybe_ty <- io (GHC.exprType cms str)
932 Just ty -> do ty' <- cleanType ty
933 printForUser $ text str <> text " :: " <> ppr ty'
935 kindOfType :: String -> GHCi ()
937 = do cms <- getSession
938 maybe_ty <- io (GHC.typeKind cms str)
941 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
943 quit :: String -> GHCi Bool
946 shellEscape :: String -> GHCi Bool
947 shellEscape str = io (system str >> return False)
949 -----------------------------------------------------------------------------
950 -- Browsing a module's contents
952 browseCmd :: String -> GHCi ()
955 ['*':m] | looksLikeModuleName m -> browseModule m False
956 [m] | looksLikeModuleName m -> browseModule m True
957 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
959 browseModule m exports_only = do
961 modl <- if exports_only then lookupModule m
962 else wantInterpretedModule m
964 -- Temporarily set the context to the module we're interested in,
965 -- just so we can get an appropriate PrintUnqualified
966 (as,bs) <- io (GHC.getContext s)
967 prel_mod <- getPrelude
968 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
969 else GHC.setContext s [modl] [])
970 unqual <- io (GHC.getPrintUnqual s)
971 io (GHC.setContext s as bs)
973 mb_mod_info <- io $ GHC.getModuleInfo s modl
975 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
978 | exports_only = GHC.modInfoExports mod_info
979 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
981 filtered = filterOutChildren names
983 things <- io $ mapM (GHC.lookupName s) filtered
985 dflags <- getDynFlags
986 let exts = dopt Opt_GlasgowExts dflags
987 io (putStrLn (showSDocForUser unqual (
988 vcat (map (pprTyThingInContext exts) (catMaybes things))
990 -- ToDo: modInfoInstances currently throws an exception for
991 -- package modules. When it works, we can do this:
992 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
994 -----------------------------------------------------------------------------
995 -- Setting the module context
998 | all sensible mods = fn mods
999 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1001 (fn, mods) = case str of
1002 '+':stuff -> (addToContext, words stuff)
1003 '-':stuff -> (removeFromContext, words stuff)
1004 stuff -> (newContext, words stuff)
1006 sensible ('*':m) = looksLikeModuleName m
1007 sensible m = looksLikeModuleName m
1009 separate :: Session -> [String] -> [Module] -> [Module]
1010 -> GHCi ([Module],[Module])
1011 separate session [] as bs = return (as,bs)
1012 separate session (('*':str):ms) as bs = do
1013 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1014 b <- io $ GHC.moduleIsInterpreted session m
1015 if b then separate session ms (m:as) bs
1016 else throwDyn (CmdLineError ("module '"
1017 ++ GHC.moduleNameString (GHC.moduleName m)
1018 ++ "' is not interpreted"))
1019 separate session (str:ms) as bs = do
1020 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1021 separate session ms as (m:bs)
1023 newContext :: [String] -> GHCi ()
1024 newContext strs = do
1026 (as,bs) <- separate s strs [] []
1027 prel_mod <- getPrelude
1028 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1029 io $ GHC.setContext s as bs'
1032 addToContext :: [String] -> GHCi ()
1033 addToContext strs = do
1035 (as,bs) <- io $ GHC.getContext s
1037 (new_as,new_bs) <- separate s strs [] []
1039 let as_to_add = new_as \\ (as ++ bs)
1040 bs_to_add = new_bs \\ (as ++ bs)
1042 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1045 removeFromContext :: [String] -> GHCi ()
1046 removeFromContext strs = do
1048 (as,bs) <- io $ GHC.getContext s
1050 (as_to_remove,bs_to_remove) <- separate s strs [] []
1052 let as' = as \\ (as_to_remove ++ bs_to_remove)
1053 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1055 io $ GHC.setContext s as' bs'
1057 ----------------------------------------------------------------------------
1060 -- set options in the interpreter. Syntax is exactly the same as the
1061 -- ghc command line, except that certain options aren't available (-C,
1064 -- This is pretty fragile: most options won't work as expected. ToDo:
1065 -- figure out which ones & disallow them.
1067 setCmd :: String -> GHCi ()
1069 = do st <- getGHCiState
1070 let opts = options st
1071 io $ putStrLn (showSDoc (
1072 text "options currently set: " <>
1075 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1078 = case toArgs str of
1079 ("args":args) -> setArgs args
1080 ("prog":prog) -> setProg prog
1081 ("prompt":prompt) -> setPrompt (after 6)
1082 ("editor":cmd) -> setEditor (after 6)
1083 ("stop":cmd) -> setStop (after 4)
1084 wds -> setOptions wds
1085 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1089 setGHCiState st{ args = args }
1093 setGHCiState st{ progname = prog }
1095 io (hPutStrLn stderr "syntax: :set prog <progname>")
1099 setGHCiState st{ editor = cmd }
1101 setStop str@(c:_) | isDigit c
1102 = do let (nm_str,rest) = break (not.isDigit) str
1105 let old_breaks = breaks st
1106 if all ((/= nm) . fst) old_breaks
1107 then printForUser (text "Breakpoint" <+> ppr nm <+>
1108 text "does not exist")
1110 let new_breaks = map fn old_breaks
1111 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1112 | otherwise = (i,loc)
1113 setGHCiState st{ breaks = new_breaks }
1116 setGHCiState st{ stop = cmd }
1118 setPrompt value = do
1121 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1122 else setGHCiState st{ prompt = remQuotes value }
1124 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1128 do -- first, deal with the GHCi opts (+s, +t, etc.)
1129 let (plus_opts, minus_opts) = partition isPlus wds
1130 mapM_ setOpt plus_opts
1131 -- then, dynamic flags
1132 newDynFlags minus_opts
1134 newDynFlags minus_opts = do
1135 dflags <- getDynFlags
1136 let pkg_flags = packageFlags dflags
1137 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1139 if (not (null leftovers))
1140 then throwDyn (CmdLineError ("unrecognised flags: " ++
1144 new_pkgs <- setDynFlags dflags'
1146 -- if the package flags changed, we should reset the context
1147 -- and link the new packages.
1148 dflags <- getDynFlags
1149 when (packageFlags dflags /= pkg_flags) $ do
1150 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1151 session <- getSession
1152 io (GHC.setTargets session [])
1153 io (GHC.load session LoadAllTargets)
1154 io (linkPackages dflags new_pkgs)
1155 setContextAfterLoad session []
1159 unsetOptions :: String -> GHCi ()
1161 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1162 let opts = words str
1163 (minus_opts, rest1) = partition isMinus opts
1164 (plus_opts, rest2) = partition isPlus rest1
1166 if (not (null rest2))
1167 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1170 mapM_ unsetOpt plus_opts
1172 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1173 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1175 no_flags <- mapM no_flag minus_opts
1176 newDynFlags no_flags
1178 isMinus ('-':s) = True
1181 isPlus ('+':s) = True
1185 = case strToGHCiOpt str of
1186 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1187 Just o -> setOption o
1190 = case strToGHCiOpt str of
1191 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1192 Just o -> unsetOption o
1194 strToGHCiOpt :: String -> (Maybe GHCiOption)
1195 strToGHCiOpt "s" = Just ShowTiming
1196 strToGHCiOpt "t" = Just ShowType
1197 strToGHCiOpt "r" = Just RevertCAFs
1198 strToGHCiOpt _ = Nothing
1200 optToStr :: GHCiOption -> String
1201 optToStr ShowTiming = "s"
1202 optToStr ShowType = "t"
1203 optToStr RevertCAFs = "r"
1205 -- ---------------------------------------------------------------------------
1211 ["args"] -> io $ putStrLn (show (args st))
1212 ["prog"] -> io $ putStrLn (show (progname st))
1213 ["prompt"] -> io $ putStrLn (show (prompt st))
1214 ["editor"] -> io $ putStrLn (show (editor st))
1215 ["stop"] -> io $ putStrLn (show (stop st))
1216 ["modules" ] -> showModules
1217 ["bindings"] -> showBindings
1218 ["linker"] -> io showLinkerState
1219 ["breaks"] -> showBkptTable
1220 ["context"] -> showContext
1221 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1224 session <- getSession
1225 let show_one ms = do m <- io (GHC.showModule session ms)
1227 graph <- io (GHC.getModuleGraph session)
1228 mapM_ show_one graph
1232 unqual <- io (GHC.getPrintUnqual s)
1233 bindings <- io (GHC.getBindings s)
1234 mapM_ showTyThing bindings
1237 showTyThing (AnId id) = do
1238 ty' <- cleanType (GHC.idType id)
1239 printForUser $ ppr id <> text " :: " <> ppr ty'
1240 showTyThing _ = return ()
1242 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1243 cleanType :: Type -> GHCi Type
1245 dflags <- getDynFlags
1246 if dopt Opt_GlasgowExts dflags
1248 else return $! GHC.dropForAlls ty
1250 showBkptTable :: GHCi ()
1253 printForUser $ prettyLocations (breaks st)
1255 showContext :: GHCi ()
1257 session <- getSession
1258 resumes <- io $ GHC.getResumeContext session
1259 printForUser $ vcat (map pp_resume (reverse resumes))
1262 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1263 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1266 -- -----------------------------------------------------------------------------
1269 completeNone :: String -> IO [String]
1270 completeNone w = return []
1273 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1274 completeWord w start end = do
1275 line <- Readline.getLineBuffer
1277 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1279 | Just c <- is_cmd line -> do
1280 maybe_cmd <- lookupCommand c
1281 let (n,w') = selectWord (words' 0 line)
1283 Nothing -> return Nothing
1284 Just (_,_,False,complete) -> wrapCompleter complete w
1285 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1286 return (map (drop n) rets)
1287 in wrapCompleter complete' w'
1289 --printf "complete %s, start = %d, end = %d\n" w start end
1290 wrapCompleter completeIdentifier w
1291 where words' _ [] = []
1292 words' n str = let (w,r) = break isSpace str
1293 (s,r') = span isSpace r
1294 in (n,w):words' (n+length w+length s) r'
1295 -- In a Haskell expression we want to parse 'a-b' as three words
1296 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1297 -- only be a single word.
1298 selectWord [] = (0,w)
1299 selectWord ((offset,x):xs)
1300 | offset+length x >= start = (start-offset,take (end-offset) x)
1301 | otherwise = selectWord xs
1304 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1305 | otherwise = Nothing
1308 cmds <- readIORef commands
1309 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1311 completeMacro w = do
1312 cmds <- readIORef commands
1313 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1314 return (filter (w `isPrefixOf`) cmds')
1316 completeIdentifier w = do
1318 rdrs <- GHC.getRdrNamesInScope s
1319 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1321 completeModule w = do
1323 dflags <- GHC.getSessionDynFlags s
1324 let pkg_mods = allExposedModules dflags
1325 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1327 completeHomeModule w = do
1329 g <- GHC.getModuleGraph s
1330 let home_mods = map GHC.ms_mod_name g
1331 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1333 completeSetOptions w = do
1334 return (filter (w `isPrefixOf`) options)
1335 where options = "args":"prog":allFlags
1337 completeFilename = Readline.filenameCompletionFunction
1339 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1341 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1342 unionComplete f1 f2 w = do
1347 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1348 wrapCompleter fun w = do
1351 [] -> return Nothing
1352 [x] -> return (Just (x,[]))
1353 xs -> case getCommonPrefix xs of
1354 "" -> return (Just ("",xs))
1355 pref -> return (Just (pref,xs))
1357 getCommonPrefix :: [String] -> String
1358 getCommonPrefix [] = ""
1359 getCommonPrefix (s:ss) = foldl common s ss
1360 where common s "" = ""
1362 common (c:cs) (d:ds)
1363 | c == d = c : common cs ds
1366 allExposedModules :: DynFlags -> [ModuleName]
1367 allExposedModules dflags
1368 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1370 pkg_db = pkgIdMap (pkgState dflags)
1372 completeCmd = completeNone
1373 completeMacro = completeNone
1374 completeIdentifier = completeNone
1375 completeModule = completeNone
1376 completeHomeModule = completeNone
1377 completeSetOptions = completeNone
1378 completeFilename = completeNone
1379 completeHomeModuleOrFile=completeNone
1380 completeBkpt = completeNone
1383 -- ---------------------------------------------------------------------------
1384 -- User code exception handling
1386 -- This is the exception handler for exceptions generated by the
1387 -- user's code and exceptions coming from children sessions;
1388 -- it normally just prints out the exception. The
1389 -- handler must be recursive, in case showing the exception causes
1390 -- more exceptions to be raised.
1392 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1393 -- raising another exception. We therefore don't put the recursive
1394 -- handler arond the flushing operation, so if stderr is closed
1395 -- GHCi will just die gracefully rather than going into an infinite loop.
1396 handler :: Exception -> GHCi Bool
1398 handler exception = do
1400 io installSignalHandlers
1401 ghciHandle handler (showException exception >> return False)
1403 showException (DynException dyn) =
1404 case fromDynamic dyn of
1405 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1406 Just Interrupted -> io (putStrLn "Interrupted.")
1407 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1408 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1409 Just other_ghc_ex -> io (print other_ghc_ex)
1411 showException other_exception
1412 = io (putStrLn ("*** Exception: " ++ show other_exception))
1414 -----------------------------------------------------------------------------
1415 -- recursive exception handlers
1417 -- Don't forget to unblock async exceptions in the handler, or if we're
1418 -- in an exception loop (eg. let a = error a in a) the ^C exception
1419 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1421 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1422 ghciHandle h (GHCi m) = GHCi $ \s ->
1423 Exception.catch (m s)
1424 (\e -> unGHCi (ghciUnblock (h e)) s)
1426 ghciUnblock :: GHCi a -> GHCi a
1427 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1430 -- ----------------------------------------------------------------------------
1433 expandPath :: String -> GHCi String
1435 case dropWhile isSpace path of
1437 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1438 return (tilde ++ '/':d)
1442 wantInterpretedModule :: String -> GHCi Module
1443 wantInterpretedModule str = do
1444 session <- getSession
1445 modl <- lookupModule str
1446 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1447 when (not is_interpreted) $
1448 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1451 wantNameFromInterpretedModule noCanDo str and_then = do
1452 session <- getSession
1453 names <- io $ GHC.parseName session str
1457 let modl = GHC.nameModule n
1458 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1459 if not is_interpreted
1460 then noCanDo n $ text "module " <> ppr modl <>
1461 text " is not interpreted"
1464 -- ----------------------------------------------------------------------------
1465 -- Windows console setup
1467 setUpConsole :: IO ()
1469 #ifdef mingw32_HOST_OS
1470 -- On Windows we need to set a known code page, otherwise the characters
1471 -- we read from the console will be be in some strange encoding, and
1472 -- similarly for characters we write to the console.
1474 -- At the moment, GHCi pretends all input is Latin-1. In the
1475 -- future we should support UTF-8, but for now we set the code pages
1478 -- It seems you have to set the font in the console window to
1479 -- a Unicode font in order for output to work properly,
1480 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1481 -- (see MSDN for SetConsoleOutputCP()).
1483 setConsoleCP 28591 -- ISO Latin-1
1484 setConsoleOutputCP 28591 -- ISO Latin-1
1488 -- -----------------------------------------------------------------------------
1489 -- commands for debugger
1491 sprintCmd = pprintCommand False False
1492 printCmd = pprintCommand True False
1493 forceCmd = pprintCommand False True
1495 pprintCommand bind force str = do
1496 session <- getSession
1497 io $ pprintClosureCommand session bind force str
1499 stepCmd :: String -> GHCi ()
1500 stepCmd [] = doContinue GHC.SingleStep
1501 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1503 traceCmd :: String -> GHCi ()
1504 traceCmd [] = doContinue GHC.RunAndLogSteps
1505 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1507 continueCmd :: String -> GHCi ()
1508 continueCmd = noArgs $ doContinue GHC.RunToCompletion
1510 doContinue :: SingleStep -> GHCi ()
1511 doContinue step = do
1512 session <- getSession
1513 runResult <- io $ GHC.resume session step
1514 afterRunStmt runResult
1517 abandonCmd :: String -> GHCi ()
1518 abandonCmd = noArgs $ do
1520 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1521 when (not b) $ io $ putStrLn "There is no computation running."
1524 deleteCmd :: String -> GHCi ()
1525 deleteCmd argLine = do
1526 deleteSwitch $ words argLine
1528 deleteSwitch :: [String] -> GHCi ()
1530 io $ putStrLn "The delete command requires at least one argument."
1531 -- delete all break points
1532 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1533 deleteSwitch idents = do
1534 mapM_ deleteOneBreak idents
1536 deleteOneBreak :: String -> GHCi ()
1538 | all isDigit str = deleteBreak (read str)
1539 | otherwise = return ()
1541 historyCmd :: String -> GHCi ()
1543 | null arg = history 20
1544 | all isDigit arg = history (read arg)
1545 | otherwise = io $ putStrLn "Syntax: :history [num]"
1549 resumes <- io $ GHC.getResumeContext s
1551 [] -> io $ putStrLn "Not stopped at a breakpoint"
1553 let hist = GHC.resumeHistory r
1554 (took,rest) = splitAt num hist
1555 spans <- mapM (io . GHC.getHistorySpan s) took
1556 let nums = map (printf "-%-3d:") [(1::Int)..]
1557 printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans)))
1558 io $ putStrLn $ if null rest then "<end of history>" else "..."
1560 backCmd :: String -> GHCi ()
1561 backCmd = noArgs $ do
1563 (names, ix, span) <- io $ GHC.back s
1564 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1565 mapM_ (showTypeOfName s) names
1566 -- run the command set with ":set stop <cmd>"
1568 enqueueCommands [stop st]
1570 forwardCmd :: String -> GHCi ()
1571 forwardCmd = noArgs $ do
1573 (names, ix, span) <- io $ GHC.forward s
1574 printForUser $ (if (ix == 0)
1575 then ptext SLIT("Stopped at")
1576 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1577 mapM_ (showTypeOfName s) names
1578 -- run the command set with ":set stop <cmd>"
1580 enqueueCommands [stop st]
1582 -- handle the "break" command
1583 breakCmd :: String -> GHCi ()
1584 breakCmd argLine = do
1585 session <- getSession
1586 breakSwitch session $ words argLine
1588 breakSwitch :: Session -> [String] -> GHCi ()
1589 breakSwitch _session [] = do
1590 io $ putStrLn "The break command requires at least one argument."
1591 breakSwitch session args@(arg1:rest)
1592 | looksLikeModuleName arg1 = do
1593 mod <- wantInterpretedModule arg1
1594 breakByModule session mod rest
1595 | all isDigit arg1 = do
1596 (toplevel, _) <- io $ GHC.getContext session
1598 (mod : _) -> breakByModuleLine mod (read arg1) rest
1600 io $ putStrLn "Cannot find default module for breakpoint."
1601 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1602 | otherwise = do -- try parsing it as an identifier
1603 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1604 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1605 if GHC.isGoodSrcLoc loc
1606 then findBreakAndSet (GHC.nameModule name) $
1607 findBreakByCoord (Just (GHC.srcLocFile loc))
1608 (GHC.srcLocLine loc,
1610 else noCanDo name $ text "can't find its location: " <> ppr loc
1612 noCanDo n why = printForUser $
1613 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1615 breakByModule :: Session -> Module -> [String] -> GHCi ()
1616 breakByModule session mod args@(arg1:rest)
1617 | all isDigit arg1 = do -- looks like a line number
1618 breakByModuleLine mod (read arg1) rest
1619 | otherwise = io $ putStrLn "Invalid arguments to :break"
1621 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1622 breakByModuleLine mod line args
1623 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1624 | [col] <- args, all isDigit col =
1625 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1626 | otherwise = io $ putStrLn "Invalid arguments to :break"
1628 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1629 findBreakAndSet mod lookupTickTree = do
1630 tickArray <- getTickArray mod
1631 (breakArray, _) <- getModBreak mod
1632 case lookupTickTree tickArray of
1633 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1634 Just (tick, span) -> do
1635 success <- io $ setBreakFlag True breakArray tick
1636 session <- getSession
1640 recordBreak $ BreakLocation
1647 text "Breakpoint " <> ppr nm <>
1649 then text " was already set at " <> ppr span
1650 else text " activated at " <> ppr span
1652 printForUser $ text "Breakpoint could not be activated at"
1655 -- When a line number is specified, the current policy for choosing
1656 -- the best breakpoint is this:
1657 -- - the leftmost complete subexpression on the specified line, or
1658 -- - the leftmost subexpression starting on the specified line, or
1659 -- - the rightmost subexpression enclosing the specified line
1661 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1662 findBreakByLine line arr
1663 | not (inRange (bounds arr) line) = Nothing
1665 listToMaybe (sortBy leftmost_largest complete) `mplus`
1666 listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1667 listToMaybe (sortBy rightmost ticks)
1671 starts_here = [ tick | tick@(nm,span) <- ticks,
1672 GHC.srcSpanStartLine span == line ]
1674 (complete,incomplete) = partition ends_here starts_here
1675 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1677 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1678 -> Maybe (BreakIndex,SrcSpan)
1679 findBreakByCoord mb_file (line, col) arr
1680 | not (inRange (bounds arr) line) = Nothing
1682 listToMaybe (sortBy rightmost contains) `mplus`
1683 listToMaybe (sortBy leftmost_smallest after_here)
1687 -- the ticks that span this coordinate
1688 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1689 is_correct_file span ]
1691 is_correct_file span
1692 | Just f <- mb_file = GHC.srcSpanFile span == f
1695 after_here = [ tick | tick@(nm,span) <- ticks,
1696 GHC.srcSpanStartLine span == line,
1697 GHC.srcSpanStartCol span >= col ]
1700 leftmost_smallest (_,a) (_,b) = a `compare` b
1701 leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1703 (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1704 rightmost (_,a) (_,b) = b `compare` a
1706 spans :: SrcSpan -> (Int,Int) -> Bool
1707 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1708 where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1710 -- for now, use ANSI bold on Unixy systems. On Windows, we add a line
1711 -- of carets under the active expression instead. The Windows console
1712 -- doesn't support ANSI escape sequences, and most Unix terminals
1713 -- (including xterm) do, so this is a reasonable guess until we have a
1714 -- proper termcap/terminfo library.
1715 #if !defined(mingw32_TARGET_OS)
1721 start_bold = BS.pack "\ESC[1m"
1722 end_bold = BS.pack "\ESC[0m"
1724 listCmd :: String -> GHCi ()
1726 mb_span <- getCurrentBreakSpan
1728 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1729 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1730 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
1731 listCmd str = list2 (words str)
1733 list2 [arg] | all isDigit arg = do
1734 session <- getSession
1735 (toplevel, _) <- io $ GHC.getContext session
1737 [] -> io $ putStrLn "No module to list"
1738 (mod : _) -> listModuleLine mod (read arg)
1739 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1740 mod <- wantInterpretedModule arg1
1741 listModuleLine mod (read arg2)
1743 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1744 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1745 if GHC.isGoodSrcLoc loc
1747 tickArray <- getTickArray (GHC.nameModule name)
1748 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1749 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1752 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1753 Just (_,span) -> io $ listAround span False
1755 noCanDo name $ text "can't find its location: " <>
1758 noCanDo n why = printForUser $
1759 text "cannot list source code for " <> ppr n <> text ": " <> why
1761 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1763 listModuleLine :: Module -> Int -> GHCi ()
1764 listModuleLine modl line = do
1765 session <- getSession
1766 graph <- io (GHC.getModuleGraph session)
1767 let this = filter ((== modl) . GHC.ms_mod) graph
1769 [] -> panic "listModuleLine"
1771 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1772 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1773 io $ listAround (GHC.srcLocSpan loc) False
1775 -- | list a section of a source file around a particular SrcSpan.
1776 -- If the highlight flag is True, also highlight the span using
1777 -- start_bold/end_bold.
1778 listAround span do_highlight = do
1780 contents <- BS.readFile (pwd </> unpackFS file)
1782 lines = BS.split '\n' contents
1783 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1784 drop (line1 - 1 - pad_before) $ lines
1785 fst_line = max 1 (line1 - pad_before)
1786 line_nos = [ fst_line .. ]
1788 highlighted | do_highlight = zipWith highlight line_nos these_lines
1789 | otherwise = these_lines
1791 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1792 prefixed = zipWith BS.append bs_line_nos highlighted
1794 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1796 file = GHC.srcSpanFile span
1797 line1 = GHC.srcSpanStartLine span
1798 col1 = GHC.srcSpanStartCol span
1799 line2 = GHC.srcSpanEndLine span
1800 col2 = GHC.srcSpanEndCol span
1802 pad_before | line1 == 1 = 0
1806 highlight | do_bold = highlight_bold
1807 | otherwise = highlight_carets
1809 highlight_bold no line
1810 | no == line1 && no == line2
1811 = let (a,r) = BS.splitAt col1 line
1812 (b,c) = BS.splitAt (col2-col1) r
1814 BS.concat [a,start_bold,b,end_bold,c]
1816 = let (a,b) = BS.splitAt col1 line in
1817 BS.concat [a, start_bold, b]
1819 = let (a,b) = BS.splitAt col2 line in
1820 BS.concat [a, end_bold, b]
1823 highlight_carets no line
1824 | no == line1 && no == line2
1825 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1826 BS.replicate (col2-col1) '^']
1828 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1829 BS.replicate (BS.length line-col1) '^']
1831 = BS.concat [line, nl, indent, BS.replicate col2 '^']
1834 indent = BS.pack " "
1835 nl = BS.singleton '\n'
1837 -- --------------------------------------------------------------------------
1840 getTickArray :: Module -> GHCi TickArray
1841 getTickArray modl = do
1843 let arrmap = tickarrays st
1844 case lookupModuleEnv arrmap modl of
1845 Just arr -> return arr
1847 (breakArray, ticks) <- getModBreak modl
1848 let arr = mkTickArray (assocs ticks)
1849 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1852 discardTickArrays :: GHCi ()
1853 discardTickArrays = do
1855 setGHCiState st{tickarrays = emptyModuleEnv}
1857 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1859 = accumArray (flip (:)) [] (1, max_line)
1860 [ (line, (nm,span)) | (nm,span) <- ticks,
1861 line <- srcSpanLines span ]
1863 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1864 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1865 GHC.srcSpanEndLine span ]
1867 lookupModule :: String -> GHCi Module
1868 lookupModule modName
1869 = do session <- getSession
1870 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1872 -- don't reset the counter back to zero?
1873 discardActiveBreakPoints :: GHCi ()
1874 discardActiveBreakPoints = do
1876 mapM (turnOffBreak.snd) (breaks st)
1877 setGHCiState $ st { breaks = [] }
1879 deleteBreak :: Int -> GHCi ()
1880 deleteBreak identity = do
1882 let oldLocations = breaks st
1883 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
1885 then printForUser (text "Breakpoint" <+> ppr identity <+>
1886 text "does not exist")
1888 mapM (turnOffBreak.snd) this
1889 setGHCiState $ st { breaks = rest }
1891 turnOffBreak loc = do
1892 (arr, _) <- getModBreak (breakModule loc)
1893 io $ setBreakFlag False arr (breakTick loc)
1895 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1896 getModBreak mod = do
1897 session <- getSession
1898 Just mod_info <- io $ GHC.getModuleInfo session mod
1899 let modBreaks = GHC.modInfoModBreaks mod_info
1900 let array = GHC.modBreaks_flags modBreaks
1901 let ticks = GHC.modBreaks_locs modBreaks
1902 return (array, ticks)
1904 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1905 setBreakFlag toggle array index
1906 | toggle = GHC.setBreakOn array index
1907 | otherwise = GHC.setBreakOff array index