1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005-2006
8 -----------------------------------------------------------------------------
15 #include "HsVersions.h"
23 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
24 Type, Module, ModuleName, TyThing(..), Phase,
25 BreakIndex, Name, SrcSpan, Resume, SingleStep )
31 import Outputable hiding (printForUser)
32 import Module -- for ModuleEnv
34 -- Other random utilities
36 import BasicTypes hiding (isTopLevel)
37 import Panic hiding (showException)
44 #ifndef mingw32_HOST_OS
45 import System.Posix hiding (getEnv)
47 import GHC.ConsoleHandler ( flushConsole )
48 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
49 import qualified System.Win32
53 import Control.Concurrent ( yield ) -- Used in readline loop
54 import System.Console.Readline as Readline
59 import Control.Exception as Exception
60 -- import Control.Concurrent
62 import qualified Data.ByteString.Char8 as BS
66 import System.Environment
67 import System.Exit ( exitWith, ExitCode(..) )
68 import System.Directory
70 import System.IO.Error as IO
74 import Control.Monad as Monad
77 import Foreign.StablePtr ( newStablePtr )
78 import GHC.Exts ( unsafeCoerce# )
79 import GHC.IOBase ( IOErrorType(InvalidArgument) )
81 import Data.IORef ( IORef, readIORef, writeIORef )
83 import System.Posix.Internals ( setNonBlockingFD )
85 -----------------------------------------------------------------------------
89 " / _ \\ /\\ /\\/ __(_)\n"++
90 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
91 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
92 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
95 "GHCi, version " ++ cProjectVersion ++
96 ": http://www.haskell.org/ghc/ :? for help"
98 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
101 GLOBAL_VAR(commands, builtin_commands, [Command])
103 builtin_commands :: [Command]
105 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
106 ("?", keepGoing help, False, completeNone),
107 ("add", keepGoingPaths addModule, False, completeFilename),
108 ("abandon", keepGoing abandonCmd, False, completeNone),
109 ("break", keepGoing breakCmd, False, completeIdentifier),
110 ("back", keepGoing backCmd, False, completeNone),
111 ("browse", keepGoing browseCmd, False, completeModule),
112 ("cd", keepGoing changeDirectory, False, completeFilename),
113 ("check", keepGoing checkModule, False, completeHomeModule),
114 ("continue", keepGoing continueCmd, False, completeNone),
115 ("cmd", keepGoing cmdCmd, False, completeIdentifier),
116 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
117 ("def", keepGoing defineMacro, False, completeIdentifier),
118 ("delete", keepGoing deleteCmd, False, completeNone),
119 ("e", keepGoing editFile, False, completeFilename),
120 ("edit", keepGoing editFile, False, completeFilename),
121 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
122 ("force", keepGoing forceCmd, False, completeIdentifier),
123 ("forward", keepGoing forwardCmd, False, completeNone),
124 ("help", keepGoing help, False, completeNone),
125 ("history", keepGoing historyCmd, False, completeNone),
126 ("info", keepGoing info, False, completeIdentifier),
127 ("kind", keepGoing kindOfType, False, completeIdentifier),
128 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
129 ("list", keepGoing listCmd, False, completeNone),
130 ("module", keepGoing setContext, False, completeModule),
131 ("main", keepGoing runMain, False, completeIdentifier),
132 ("print", keepGoing printCmd, False, completeIdentifier),
133 ("quit", quit, False, completeNone),
134 ("reload", keepGoing reloadModule, False, completeNone),
135 ("set", keepGoing setCmd, True, completeSetOptions),
136 ("show", keepGoing showCmd, False, completeNone),
137 ("sprint", keepGoing sprintCmd, False, completeIdentifier),
138 ("step", keepGoing stepCmd, False, completeIdentifier),
139 ("type", keepGoing typeOfExpr, False, completeIdentifier),
140 ("trace", keepGoing traceCmd, False, completeIdentifier),
141 ("undef", keepGoing undefineMacro, False, completeMacro),
142 ("unset", keepGoing unsetOptions, True, completeSetOptions)
145 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
146 keepGoing a str = a str >> return False
148 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
149 keepGoingPaths a str = a (toArgs str) >> return False
151 shortHelpText = "use :? for help.\n"
154 " Commands available from the prompt:\n" ++
156 " <statement> evaluate/run <statement>\n" ++
157 " :add <filename> ... add module(s) to the current target set\n" ++
158 " :browse [*]<module> display the names defined by <module>\n" ++
159 " :cd <dir> change directory to <dir>\n" ++
160 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
161 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
162 " :def <cmd> <expr> define a command :<cmd>\n" ++
163 " :edit <file> edit file\n" ++
164 " :edit edit last module\n" ++
165 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
166 " :help, :? display this list of commands\n" ++
167 " :info [<name> ...] display information about the given names\n" ++
168 " :kind <type> show the kind of <type>\n" ++
169 " :load <filename> ... load module(s) and their dependents\n" ++
170 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
171 " :main [<arguments> ...] run the main function with the given arguments\n" ++
172 " :quit exit GHCi\n" ++
173 " :reload reload the current module set\n" ++
174 " :type <expr> show the type of <expr>\n" ++
175 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
176 " :!<command> run the shell command <command>\n" ++
178 " -- Commands for debugging:\n" ++
180 " :abandon at a breakpoint, abandon current computation\n" ++
181 " :back go back in the history (after :trace)\n" ++
182 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
183 " :break <name> set a breakpoint on the specified function\n" ++
184 " :continue resume after a breakpoint\n" ++
185 " :delete <number> delete the specified breakpoint\n" ++
186 " :delete * delete all breakpoints\n" ++
187 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
188 " :forward go forward in the history (after :back)\n" ++
189 " :history [<n>] show the last <n> items in the history (after :trace)\n" ++
190 " :print [<name> ...] prints a value without forcing its computation\n" ++
191 " :sprint [<name> ...] simplifed version of :print\n" ++
192 " :step single-step after stopping at a breakpoint\n"++
193 " :step <expr> single-step into <expr>\n"++
194 " :trace trace after stopping at a breakpoint\n"++
195 " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
198 " -- Commands for changing settings:\n" ++
200 " :set <option> ... set options\n" ++
201 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
202 " :set prog <progname> set the value returned by System.getProgName\n" ++
203 " :set prompt <prompt> set the prompt used in GHCi\n" ++
204 " :set editor <cmd> set the command used for :edit\n" ++
205 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
206 " :unset <option> ... unset options\n" ++
208 " Options for ':set' and ':unset':\n" ++
210 " +r revert top-level expressions after each evaluation\n" ++
211 " +s print timing/memory stats after each evaluation\n" ++
212 " +t print type after evaluation\n" ++
213 " -<flags> most GHC command line flags can also be set here\n" ++
214 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
216 " -- Commands for displaying information:\n" ++
218 " :show bindings show the current bindings made at the prompt\n" ++
219 " :show breaks show the active breakpoints\n" ++
220 " :show context show the breakpoint context\n" ++
221 " :show modules show the currently loaded modules\n" ++
222 " :show <setting> show anything that can be set with :set (e.g. args)\n" ++
229 win <- System.Win32.getWindowsDirectory
230 return (win `joinFileName` "notepad.exe")
235 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
236 interactiveUI session srcs maybe_expr = do
237 -- HACK! If we happen to get into an infinite loop (eg the user
238 -- types 'let x=x in x' at the prompt), then the thread will block
239 -- on a blackhole, and become unreachable during GC. The GC will
240 -- detect that it is unreachable and send it the NonTermination
241 -- exception. However, since the thread is unreachable, everything
242 -- it refers to might be finalized, including the standard Handles.
243 -- This sounds like a bug, but we don't have a good solution right
249 -- Initialise buffering for the *interpreted* I/O system
250 initInterpBuffering session
252 when (isNothing maybe_expr) $ do
253 -- Only for GHCi (not runghc and ghc -e):
254 -- Turn buffering off for the compiled program's stdout/stderr
256 -- Turn buffering off for GHCi's stdout
258 hSetBuffering stdout NoBuffering
259 -- We don't want the cmd line to buffer any input that might be
260 -- intended for the program, so unbuffer stdin.
261 hSetBuffering stdin NoBuffering
263 -- initial context is just the Prelude
264 prel_mod <- GHC.findModule session prel_name (Just basePackageId)
265 GHC.setContext session [] [prel_mod]
269 Readline.setAttemptedCompletionFunction (Just completeWord)
270 --Readline.parseAndBind "set show-all-if-ambiguous 1"
272 let symbols = "!#$%&*+/<=>?@\\^|-~"
273 specials = "(),;[]`{}"
275 word_break_chars = spaces ++ specials ++ symbols
277 Readline.setBasicWordBreakCharacters word_break_chars
278 Readline.setCompleterWordBreakCharacters word_break_chars
281 default_editor <- findEditor
283 startGHCi (runGHCi srcs maybe_expr)
284 GHCiState{ progname = "<interactive>",
288 editor = default_editor,
294 tickarrays = emptyModuleEnv,
299 Readline.resetTerminal Nothing
304 prel_name = GHC.mkModuleName "Prelude"
306 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
307 runGHCi paths maybe_expr = do
308 let read_dot_files = not opt_IgnoreDotGhci
310 when (read_dot_files) $ do
313 exists <- io (doesFileExist file)
315 dir_ok <- io (checkPerms ".")
316 file_ok <- io (checkPerms file)
317 when (dir_ok && file_ok) $ do
318 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
321 Right hdl -> fileLoop hdl False
323 when (read_dot_files) $ do
324 -- Read in $HOME/.ghci
325 either_dir <- io (IO.try (getEnv "HOME"))
329 cwd <- io (getCurrentDirectory)
330 when (dir /= cwd) $ do
331 let file = dir ++ "/.ghci"
332 ok <- io (checkPerms file)
334 either_hdl <- io (IO.try (openFile file ReadMode))
337 Right hdl -> fileLoop hdl False
339 -- Perform a :load for files given on the GHCi command line
340 -- When in -e mode, if the load fails then we want to stop
341 -- immediately rather than going on to evaluate the expression.
342 when (not (null paths)) $ do
343 ok <- ghciHandle (\e -> do showException e; return Failed) $
345 when (isJust maybe_expr && failed ok) $
346 io (exitWith (ExitFailure 1))
348 -- if verbosity is greater than 0, or we are connected to a
349 -- terminal, display the prompt in the interactive loop.
350 is_tty <- io (hIsTerminalDevice stdin)
351 dflags <- getDynFlags
352 let show_prompt = verbosity dflags > 0 || is_tty
357 #if defined(mingw32_HOST_OS)
358 -- The win32 Console API mutates the first character of
359 -- type-ahead when reading from it in a non-buffered manner. Work
360 -- around this by flushing the input buffer of type-ahead characters,
361 -- but only if stdin is available.
362 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
364 Left err | isDoesNotExistError err -> return ()
365 | otherwise -> io (ioError err)
366 Right () -> return ()
368 -- initialise the console if necessary
371 -- enter the interactive loop
372 interactiveLoop is_tty show_prompt
374 -- just evaluate the expression we were given
379 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
382 interactiveLoop is_tty show_prompt =
383 -- Ignore ^C exceptions caught here
384 ghciHandleDyn (\e -> case e of
386 #if defined(mingw32_HOST_OS)
389 interactiveLoop is_tty show_prompt
390 _other -> return ()) $
392 ghciUnblock $ do -- unblock necessary if we recursed from the
393 -- exception handler above.
395 -- read commands from stdin
399 else fileLoop stdin show_prompt
401 fileLoop stdin show_prompt
405 -- NOTE: We only read .ghci files if they are owned by the current user,
406 -- and aren't world writable. Otherwise, we could be accidentally
407 -- running code planted by a malicious third party.
409 -- Furthermore, We only read ./.ghci if . is owned by the current user
410 -- and isn't writable by anyone else. I think this is sufficient: we
411 -- don't need to check .. and ../.. etc. because "." always refers to
412 -- the same directory while a process is running.
414 checkPerms :: String -> IO Bool
416 #ifdef mingw32_HOST_OS
419 Util.handle (\_ -> return False) $ do
420 st <- getFileStatus name
422 if fileOwner st /= me then do
423 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
426 let mode = fileMode st
427 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
428 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
430 putStrLn $ "*** WARNING: " ++ name ++
431 " is writable by someone else, IGNORING!"
436 fileLoop :: Handle -> Bool -> GHCi ()
437 fileLoop hdl show_prompt = do
438 when show_prompt $ do
441 l <- io (IO.try (hGetLine hdl))
443 Left e | isEOFError e -> return ()
444 | InvalidArgument <- etype -> return ()
445 | otherwise -> io (ioError e)
446 where etype = ioeGetErrorType e
447 -- treat InvalidArgument in the same way as EOF:
448 -- this can happen if the user closed stdin, or
449 -- perhaps did getContents which closes stdin at
452 case removeSpaces l of
453 "" -> fileLoop hdl show_prompt
454 l -> do quit <- runCommands l
455 if quit then return () else fileLoop hdl show_prompt
458 session <- getSession
459 (toplevs,exports) <- io (GHC.getContext session)
460 resumes <- io $ GHC.getResumeContext session
466 let ix = GHC.resumeHistoryIx r
468 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
470 let hist = GHC.resumeHistory r !! (ix-1)
471 span <- io $ GHC.getHistorySpan session hist
472 return (brackets (ppr (negate ix) <> char ':'
473 <+> ppr span) <> space)
475 dots | r:rs <- resumes, not (null rs) = text "... "
479 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
480 hsep (map (ppr . GHC.moduleName) exports)
482 deflt_prompt = dots <> context_bit <> modules_bit
484 f ('%':'s':xs) = deflt_prompt <> f xs
485 f ('%':'%':xs) = char '%' <> f xs
486 f (x:xs) = char x <> f xs
490 return (showSDoc (f (prompt st)))
494 readlineLoop :: GHCi ()
496 session <- getSession
497 (mod,imports) <- io (GHC.getContext session)
499 saveSession -- for use by completion
501 mb_span <- getCurrentBreakSpan
503 l <- io (readline prompt `finally` setNonBlockingFD 0)
504 -- readline sometimes puts stdin into blocking mode,
505 -- so we need to put it back for the IO library
510 case removeSpaces l of
514 quit <- runCommands l
515 if quit then return () else readlineLoop
518 runCommands :: String -> GHCi Bool
520 q <- ghciHandle handler (doCommand cmd)
521 if q then return True else runNext
527 c:cs -> do setGHCiState st{ cmdqueue = cs }
530 doCommand (':' : cmd) = specialCommand cmd
531 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
534 enqueueCommands :: [String] -> GHCi ()
535 enqueueCommands cmds = do
537 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
540 -- This version is for the GHC command-line option -e. The only difference
541 -- from runCommand is that it catches the ExitException exception and
542 -- exits, rather than printing out the exception.
543 runCommandEval c = ghciHandle handleEval (doCommand c)
545 handleEval (ExitException code) = io (exitWith code)
546 handleEval e = do handler e
547 io (exitWith (ExitFailure 1))
549 doCommand (':' : command) = specialCommand command
551 = do r <- runStmt stmt GHC.RunToCompletion
553 False -> io (exitWith (ExitFailure 1))
554 -- failure to run the command causes exit(1) for ghc -e.
557 runStmt :: String -> SingleStep -> GHCi Bool
559 | null (filter (not.isSpace) stmt) = return False
560 | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
562 = do st <- getGHCiState
563 session <- getSession
564 result <- io $ withProgName (progname st) $ withArgs (args st) $
565 GHC.runStmt session stmt step
569 afterRunStmt :: GHC.RunResult -> GHCi Bool
570 -- False <=> the statement failed to compile
571 afterRunStmt (GHC.RunException e) = throw e
572 afterRunStmt run_result = do
573 session <- getSession
575 GHC.RunOk names -> do
576 show_types <- isOptionSet ShowType
577 when show_types $ mapM_ (showTypeOfName session) names
578 GHC.RunBreak _ names mb_info -> do
579 resumes <- io $ GHC.getResumeContext session
580 printForUser $ ptext SLIT("Stopped at") <+>
581 ppr (GHC.resumeSpan (head resumes))
582 mapM_ (showTypeOfName session) names
583 maybe (return ()) runBreakCmd mb_info
584 -- run the command set with ":set stop <cmd>"
586 enqueueCommands [stop st]
591 io installSignalHandlers
592 b <- isOptionSet RevertCAFs
593 io (when b revertCAFs)
595 return (case run_result of GHC.RunOk _ -> True; _ -> False)
597 runBreakCmd :: GHC.BreakInfo -> GHCi ()
598 runBreakCmd info = do
599 let mod = GHC.breakInfo_module info
600 nm = GHC.breakInfo_number info
602 case [ loc | (i,loc) <- breaks st,
603 breakModule loc == mod, breakTick loc == nm ] of
605 loc:_ | null cmd -> return ()
606 | otherwise -> do enqueueCommands [cmd]; return ()
607 where cmd = onBreakCmd loc
609 showTypeOfName :: Session -> Name -> GHCi ()
610 showTypeOfName session n
611 = do maybe_tything <- io (GHC.lookupName session n)
612 case maybe_tything of
614 Just thing -> showTyThing thing
616 specialCommand :: String -> GHCi Bool
617 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
618 specialCommand str = do
619 let (cmd,rest) = break isSpace str
620 maybe_cmd <- io (lookupCommand cmd)
622 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
623 ++ shortHelpText) >> return False)
624 Just (_,f,_,_) -> f (dropWhile isSpace rest)
626 lookupCommand :: String -> IO (Maybe Command)
627 lookupCommand str = do
628 cmds <- readIORef commands
629 -- look for exact match first, then the first prefix match
630 case [ c | c <- cmds, str == cmdName c ] of
631 c:_ -> return (Just c)
632 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
634 c:_ -> return (Just c)
637 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
638 getCurrentBreakSpan = do
639 session <- getSession
640 resumes <- io $ GHC.getResumeContext session
644 let ix = GHC.resumeHistoryIx r
646 then return (Just (GHC.resumeSpan r))
648 let hist = GHC.resumeHistory r !! (ix-1)
649 span <- io $ GHC.getHistorySpan session hist
652 -----------------------------------------------------------------------------
655 noArgs :: GHCi () -> String -> GHCi ()
657 noArgs m _ = io $ putStrLn "This command takes no arguments"
659 help :: String -> GHCi ()
660 help _ = io (putStr helpText)
662 info :: String -> GHCi ()
663 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
664 info s = do { let names = words s
665 ; session <- getSession
666 ; dflags <- getDynFlags
667 ; let exts = dopt Opt_GlasgowExts dflags
668 ; mapM_ (infoThing exts session) names }
670 infoThing exts session str = io $ do
671 names <- GHC.parseName session str
672 let filtered = filterOutChildren names
673 mb_stuffs <- mapM (GHC.getInfo session) filtered
674 unqual <- GHC.getPrintUnqual session
675 putStrLn (showSDocForUser unqual $
676 vcat (intersperse (text "") $
677 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
679 -- Filter out names whose parent is also there Good
680 -- example is '[]', which is both a type and data
681 -- constructor in the same type
682 filterOutChildren :: [Name] -> [Name]
683 filterOutChildren names = filter (not . parent_is_there) names
684 where parent_is_there n
685 -- | Just p <- GHC.nameParent_maybe n = p `elem` names
689 pprInfo exts (thing, fixity, insts)
690 = pprTyThingInContextLoc exts thing
691 $$ show_fixity fixity
692 $$ vcat (map GHC.pprInstance insts)
695 | fix == GHC.defaultFixity = empty
696 | otherwise = ppr fix <+> ppr (GHC.getName thing)
698 runMain :: String -> GHCi ()
700 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
701 enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
703 addModule :: [FilePath] -> GHCi ()
705 io (revertCAFs) -- always revert CAFs on load/add.
706 files <- mapM expandPath files
707 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
708 session <- getSession
709 io (mapM_ (GHC.addTarget session) targets)
710 ok <- io (GHC.load session LoadAllTargets)
713 changeDirectory :: String -> GHCi ()
714 changeDirectory dir = do
715 session <- getSession
716 graph <- io (GHC.getModuleGraph session)
717 when (not (null graph)) $
718 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
719 io (GHC.setTargets session [])
720 io (GHC.load session LoadAllTargets)
721 setContextAfterLoad session []
722 io (GHC.workingDirectoryChanged session)
723 dir <- expandPath dir
724 io (setCurrentDirectory dir)
726 editFile :: String -> GHCi ()
728 do file <- if null str then chooseEditFile else return str
732 $ throwDyn (CmdLineError "editor not set, use :set editor")
733 io $ system (cmd ++ ' ':file)
736 -- The user didn't specify a file so we pick one for them.
737 -- Our strategy is to pick the first module that failed to load,
738 -- or otherwise the first target.
740 -- XXX: Can we figure out what happened if the depndecy analysis fails
741 -- (e.g., because the porgrammeer mistyped the name of a module)?
742 -- XXX: Can we figure out the location of an error to pass to the editor?
743 -- XXX: if we could figure out the list of errors that occured during the
744 -- last load/reaload, then we could start the editor focused on the first
746 chooseEditFile :: GHCi String
748 do session <- getSession
749 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
751 graph <- io (GHC.getModuleGraph session)
752 failed_graph <- filterM hasFailed graph
753 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
755 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
758 case pick (order failed_graph) of
759 Just file -> return file
761 do targets <- io (GHC.getTargets session)
762 case msum (map fromTarget targets) of
763 Just file -> return file
764 Nothing -> throwDyn (CmdLineError "No files to edit.")
766 where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
767 fromTarget _ = Nothing -- when would we get a module target?
769 defineMacro :: String -> GHCi ()
771 let (macro_name, definition) = break isSpace s
772 cmds <- io (readIORef commands)
774 then throwDyn (CmdLineError "invalid macro name")
776 if (macro_name `elem` map cmdName cmds)
777 then throwDyn (CmdLineError
778 ("command '" ++ macro_name ++ "' is already defined"))
781 -- give the expression a type signature, so we can be sure we're getting
782 -- something of the right type.
783 let new_expr = '(' : definition ++ ") :: String -> IO String"
785 -- compile the expression
787 maybe_hv <- io (GHC.compileExpr cms new_expr)
790 Just hv -> io (writeIORef commands --
791 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
793 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
795 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
796 enqueueCommands (lines str)
799 undefineMacro :: String -> GHCi ()
800 undefineMacro macro_name = do
801 cmds <- io (readIORef commands)
802 if (macro_name `elem` map cmdName builtin_commands)
803 then throwDyn (CmdLineError
804 ("command '" ++ macro_name ++ "' cannot be undefined"))
806 if (macro_name `notElem` map cmdName cmds)
807 then throwDyn (CmdLineError
808 ("command '" ++ macro_name ++ "' not defined"))
810 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
812 cmdCmd :: String -> GHCi ()
814 let expr = '(' : str ++ ") :: IO String"
815 session <- getSession
816 maybe_hv <- io (GHC.compileExpr session expr)
820 cmds <- io $ (unsafeCoerce# hv :: IO String)
821 enqueueCommands (lines cmds)
824 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
825 loadModule fs = timeIt (loadModule' fs)
827 loadModule_ :: [FilePath] -> GHCi ()
828 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
830 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
831 loadModule' files = do
832 session <- getSession
835 discardActiveBreakPoints
836 io (GHC.setTargets session [])
837 io (GHC.load session LoadAllTargets)
840 let (filenames, phases) = unzip files
841 exp_filenames <- mapM expandPath filenames
842 let files' = zip exp_filenames phases
843 targets <- io (mapM (uncurry GHC.guessTarget) files')
845 -- NOTE: we used to do the dependency anal first, so that if it
846 -- fails we didn't throw away the current set of modules. This would
847 -- require some re-working of the GHC interface, so we'll leave it
848 -- as a ToDo for now.
850 io (GHC.setTargets session targets)
851 doLoad session LoadAllTargets
853 checkModule :: String -> GHCi ()
855 let modl = GHC.mkModuleName m
856 session <- getSession
857 result <- io (GHC.checkModule session modl)
859 Nothing -> io $ putStrLn "Nothing"
860 Just r -> io $ putStrLn (showSDoc (
861 case GHC.checkedModuleInfo r of
862 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
864 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
866 (text "global names: " <+> ppr global) $$
867 (text "local names: " <+> ppr local)
869 afterLoad (successIf (isJust result)) session
871 reloadModule :: String -> GHCi ()
873 io (revertCAFs) -- always revert CAFs on reload.
874 discardActiveBreakPoints
875 session <- getSession
876 doLoad session $ if null m then LoadAllTargets
877 else LoadUpTo (GHC.mkModuleName m)
880 doLoad session howmuch = do
881 -- turn off breakpoints before we load: we can't turn them off later, because
882 -- the ModBreaks will have gone away.
883 discardActiveBreakPoints
884 ok <- io (GHC.load session howmuch)
888 afterLoad ok session = do
889 io (revertCAFs) -- always revert CAFs on load.
891 graph <- io (GHC.getModuleGraph session)
892 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
893 setContextAfterLoad session graph'
894 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
896 setContextAfterLoad session [] = do
897 prel_mod <- getPrelude
898 io (GHC.setContext session [] [prel_mod])
899 setContextAfterLoad session ms = do
900 -- load a target if one is available, otherwise load the topmost module.
901 targets <- io (GHC.getTargets session)
902 case [ m | Just m <- map (findTarget ms) targets ] of
904 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
905 load_this (last graph')
910 = case filter (`matches` t) ms of
914 summary `matches` Target (TargetModule m) _
915 = GHC.ms_mod_name summary == m
916 summary `matches` Target (TargetFile f _) _
917 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
918 summary `matches` target
921 load_this summary | m <- GHC.ms_mod summary = do
922 b <- io (GHC.moduleIsInterpreted session m)
923 if b then io (GHC.setContext session [m] [])
925 prel_mod <- getPrelude
926 io (GHC.setContext session [] [prel_mod,m])
929 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
930 modulesLoadedMsg ok mods = do
931 dflags <- getDynFlags
932 when (verbosity dflags > 0) $ do
934 | null mods = text "none."
936 punctuate comma (map ppr mods)) <> text "."
939 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
941 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
944 typeOfExpr :: String -> GHCi ()
946 = do cms <- getSession
947 maybe_ty <- io (GHC.exprType cms str)
950 Just ty -> do ty' <- cleanType ty
951 printForUser $ text str <> text " :: " <> ppr ty'
953 kindOfType :: String -> GHCi ()
955 = do cms <- getSession
956 maybe_ty <- io (GHC.typeKind cms str)
959 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
961 quit :: String -> GHCi Bool
964 shellEscape :: String -> GHCi Bool
965 shellEscape str = io (system str >> return False)
967 -----------------------------------------------------------------------------
968 -- Browsing a module's contents
970 browseCmd :: String -> GHCi ()
973 ['*':m] | looksLikeModuleName m -> browseModule m False
974 [m] | looksLikeModuleName m -> browseModule m True
975 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
977 browseModule m exports_only = do
979 modl <- if exports_only then lookupModule m
980 else wantInterpretedModule m
982 -- Temporarily set the context to the module we're interested in,
983 -- just so we can get an appropriate PrintUnqualified
984 (as,bs) <- io (GHC.getContext s)
985 prel_mod <- getPrelude
986 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
987 else GHC.setContext s [modl] [])
988 unqual <- io (GHC.getPrintUnqual s)
989 io (GHC.setContext s as bs)
991 mb_mod_info <- io $ GHC.getModuleInfo s modl
993 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
996 | exports_only = GHC.modInfoExports mod_info
997 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
999 filtered = filterOutChildren names
1001 things <- io $ mapM (GHC.lookupName s) filtered
1003 dflags <- getDynFlags
1004 let exts = dopt Opt_GlasgowExts dflags
1005 io (putStrLn (showSDocForUser unqual (
1006 vcat (map (pprTyThingInContext exts) (catMaybes things))
1008 -- ToDo: modInfoInstances currently throws an exception for
1009 -- package modules. When it works, we can do this:
1010 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1012 -----------------------------------------------------------------------------
1013 -- Setting the module context
1016 | all sensible mods = fn mods
1017 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1019 (fn, mods) = case str of
1020 '+':stuff -> (addToContext, words stuff)
1021 '-':stuff -> (removeFromContext, words stuff)
1022 stuff -> (newContext, words stuff)
1024 sensible ('*':m) = looksLikeModuleName m
1025 sensible m = looksLikeModuleName m
1027 separate :: Session -> [String] -> [Module] -> [Module]
1028 -> GHCi ([Module],[Module])
1029 separate session [] as bs = return (as,bs)
1030 separate session (('*':str):ms) as bs = do
1031 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1032 b <- io $ GHC.moduleIsInterpreted session m
1033 if b then separate session ms (m:as) bs
1034 else throwDyn (CmdLineError ("module '"
1035 ++ GHC.moduleNameString (GHC.moduleName m)
1036 ++ "' is not interpreted"))
1037 separate session (str:ms) as bs = do
1038 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1039 separate session ms as (m:bs)
1041 newContext :: [String] -> GHCi ()
1042 newContext strs = do
1044 (as,bs) <- separate s strs [] []
1045 prel_mod <- getPrelude
1046 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1047 io $ GHC.setContext s as bs'
1050 addToContext :: [String] -> GHCi ()
1051 addToContext strs = do
1053 (as,bs) <- io $ GHC.getContext s
1055 (new_as,new_bs) <- separate s strs [] []
1057 let as_to_add = new_as \\ (as ++ bs)
1058 bs_to_add = new_bs \\ (as ++ bs)
1060 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1063 removeFromContext :: [String] -> GHCi ()
1064 removeFromContext strs = do
1066 (as,bs) <- io $ GHC.getContext s
1068 (as_to_remove,bs_to_remove) <- separate s strs [] []
1070 let as' = as \\ (as_to_remove ++ bs_to_remove)
1071 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1073 io $ GHC.setContext s as' bs'
1075 ----------------------------------------------------------------------------
1078 -- set options in the interpreter. Syntax is exactly the same as the
1079 -- ghc command line, except that certain options aren't available (-C,
1082 -- This is pretty fragile: most options won't work as expected. ToDo:
1083 -- figure out which ones & disallow them.
1085 setCmd :: String -> GHCi ()
1087 = do st <- getGHCiState
1088 let opts = options st
1089 io $ putStrLn (showSDoc (
1090 text "options currently set: " <>
1093 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1096 = case toArgs str of
1097 ("args":args) -> setArgs args
1098 ("prog":prog) -> setProg prog
1099 ("prompt":prompt) -> setPrompt (after 6)
1100 ("editor":cmd) -> setEditor (after 6)
1101 ("stop":cmd) -> setStop (after 4)
1102 wds -> setOptions wds
1103 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1107 setGHCiState st{ args = args }
1111 setGHCiState st{ progname = prog }
1113 io (hPutStrLn stderr "syntax: :set prog <progname>")
1117 setGHCiState st{ editor = cmd }
1119 setStop str@(c:_) | isDigit c
1120 = do let (nm_str,rest) = break (not.isDigit) str
1123 let old_breaks = breaks st
1124 if all ((/= nm) . fst) old_breaks
1125 then printForUser (text "Breakpoint" <+> ppr nm <+>
1126 text "does not exist")
1128 let new_breaks = map fn old_breaks
1129 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1130 | otherwise = (i,loc)
1131 setGHCiState st{ breaks = new_breaks }
1134 setGHCiState st{ stop = cmd }
1136 setPrompt value = do
1139 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1140 else setGHCiState st{ prompt = remQuotes value }
1142 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1146 do -- first, deal with the GHCi opts (+s, +t, etc.)
1147 let (plus_opts, minus_opts) = partition isPlus wds
1148 mapM_ setOpt plus_opts
1149 -- then, dynamic flags
1150 newDynFlags minus_opts
1152 newDynFlags minus_opts = do
1153 dflags <- getDynFlags
1154 let pkg_flags = packageFlags dflags
1155 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1157 if (not (null leftovers))
1158 then throwDyn (CmdLineError ("unrecognised flags: " ++
1162 new_pkgs <- setDynFlags dflags'
1164 -- if the package flags changed, we should reset the context
1165 -- and link the new packages.
1166 dflags <- getDynFlags
1167 when (packageFlags dflags /= pkg_flags) $ do
1168 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1169 session <- getSession
1170 io (GHC.setTargets session [])
1171 io (GHC.load session LoadAllTargets)
1172 io (linkPackages dflags new_pkgs)
1173 setContextAfterLoad session []
1177 unsetOptions :: String -> GHCi ()
1179 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1180 let opts = words str
1181 (minus_opts, rest1) = partition isMinus opts
1182 (plus_opts, rest2) = partition isPlus rest1
1184 if (not (null rest2))
1185 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1188 mapM_ unsetOpt plus_opts
1190 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1191 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1193 no_flags <- mapM no_flag minus_opts
1194 newDynFlags no_flags
1196 isMinus ('-':s) = True
1199 isPlus ('+':s) = True
1203 = case strToGHCiOpt str of
1204 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1205 Just o -> setOption o
1208 = case strToGHCiOpt str of
1209 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1210 Just o -> unsetOption o
1212 strToGHCiOpt :: String -> (Maybe GHCiOption)
1213 strToGHCiOpt "s" = Just ShowTiming
1214 strToGHCiOpt "t" = Just ShowType
1215 strToGHCiOpt "r" = Just RevertCAFs
1216 strToGHCiOpt _ = Nothing
1218 optToStr :: GHCiOption -> String
1219 optToStr ShowTiming = "s"
1220 optToStr ShowType = "t"
1221 optToStr RevertCAFs = "r"
1223 -- ---------------------------------------------------------------------------
1229 ["args"] -> io $ putStrLn (show (args st))
1230 ["prog"] -> io $ putStrLn (show (progname st))
1231 ["prompt"] -> io $ putStrLn (show (prompt st))
1232 ["editor"] -> io $ putStrLn (show (editor st))
1233 ["stop"] -> io $ putStrLn (show (stop st))
1234 ["modules" ] -> showModules
1235 ["bindings"] -> showBindings
1236 ["linker"] -> io showLinkerState
1237 ["breaks"] -> showBkptTable
1238 ["context"] -> showContext
1239 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1242 session <- getSession
1243 let show_one ms = do m <- io (GHC.showModule session ms)
1245 graph <- io (GHC.getModuleGraph session)
1246 mapM_ show_one graph
1250 unqual <- io (GHC.getPrintUnqual s)
1251 bindings <- io (GHC.getBindings s)
1252 mapM_ showTyThing bindings
1255 showTyThing (AnId id) = do
1256 ty' <- cleanType (GHC.idType id)
1257 printForUser $ ppr id <> text " :: " <> ppr ty'
1258 showTyThing _ = return ()
1260 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1261 cleanType :: Type -> GHCi Type
1263 dflags <- getDynFlags
1264 if dopt Opt_GlasgowExts dflags
1266 else return $! GHC.dropForAlls ty
1268 showBkptTable :: GHCi ()
1271 printForUser $ prettyLocations (breaks st)
1273 showContext :: GHCi ()
1275 session <- getSession
1276 resumes <- io $ GHC.getResumeContext session
1277 printForUser $ vcat (map pp_resume (reverse resumes))
1280 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1281 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1284 -- -----------------------------------------------------------------------------
1287 completeNone :: String -> IO [String]
1288 completeNone w = return []
1291 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1292 completeWord w start end = do
1293 line <- Readline.getLineBuffer
1295 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1297 | Just c <- is_cmd line -> do
1298 maybe_cmd <- lookupCommand c
1299 let (n,w') = selectWord (words' 0 line)
1301 Nothing -> return Nothing
1302 Just (_,_,False,complete) -> wrapCompleter complete w
1303 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1304 return (map (drop n) rets)
1305 in wrapCompleter complete' w'
1307 --printf "complete %s, start = %d, end = %d\n" w start end
1308 wrapCompleter completeIdentifier w
1309 where words' _ [] = []
1310 words' n str = let (w,r) = break isSpace str
1311 (s,r') = span isSpace r
1312 in (n,w):words' (n+length w+length s) r'
1313 -- In a Haskell expression we want to parse 'a-b' as three words
1314 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1315 -- only be a single word.
1316 selectWord [] = (0,w)
1317 selectWord ((offset,x):xs)
1318 | offset+length x >= start = (start-offset,take (end-offset) x)
1319 | otherwise = selectWord xs
1322 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1323 | otherwise = Nothing
1326 cmds <- readIORef commands
1327 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1329 completeMacro w = do
1330 cmds <- readIORef commands
1331 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1332 return (filter (w `isPrefixOf`) cmds')
1334 completeIdentifier w = do
1336 rdrs <- GHC.getRdrNamesInScope s
1337 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1339 completeModule w = do
1341 dflags <- GHC.getSessionDynFlags s
1342 let pkg_mods = allExposedModules dflags
1343 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1345 completeHomeModule w = do
1347 g <- GHC.getModuleGraph s
1348 let home_mods = map GHC.ms_mod_name g
1349 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1351 completeSetOptions w = do
1352 return (filter (w `isPrefixOf`) options)
1353 where options = "args":"prog":allFlags
1355 completeFilename = Readline.filenameCompletionFunction
1357 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1359 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1360 unionComplete f1 f2 w = do
1365 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1366 wrapCompleter fun w = do
1369 [] -> return Nothing
1370 [x] -> return (Just (x,[]))
1371 xs -> case getCommonPrefix xs of
1372 "" -> return (Just ("",xs))
1373 pref -> return (Just (pref,xs))
1375 getCommonPrefix :: [String] -> String
1376 getCommonPrefix [] = ""
1377 getCommonPrefix (s:ss) = foldl common s ss
1378 where common s "" = ""
1380 common (c:cs) (d:ds)
1381 | c == d = c : common cs ds
1384 allExposedModules :: DynFlags -> [ModuleName]
1385 allExposedModules dflags
1386 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1388 pkg_db = pkgIdMap (pkgState dflags)
1390 completeCmd = completeNone
1391 completeMacro = completeNone
1392 completeIdentifier = completeNone
1393 completeModule = completeNone
1394 completeHomeModule = completeNone
1395 completeSetOptions = completeNone
1396 completeFilename = completeNone
1397 completeHomeModuleOrFile=completeNone
1398 completeBkpt = completeNone
1401 -- ---------------------------------------------------------------------------
1402 -- User code exception handling
1404 -- This is the exception handler for exceptions generated by the
1405 -- user's code and exceptions coming from children sessions;
1406 -- it normally just prints out the exception. The
1407 -- handler must be recursive, in case showing the exception causes
1408 -- more exceptions to be raised.
1410 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1411 -- raising another exception. We therefore don't put the recursive
1412 -- handler arond the flushing operation, so if stderr is closed
1413 -- GHCi will just die gracefully rather than going into an infinite loop.
1414 handler :: Exception -> GHCi Bool
1416 handler exception = do
1418 io installSignalHandlers
1419 ghciHandle handler (showException exception >> return False)
1421 showException (DynException dyn) =
1422 case fromDynamic dyn of
1423 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1424 Just Interrupted -> io (putStrLn "Interrupted.")
1425 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1426 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1427 Just other_ghc_ex -> io (print other_ghc_ex)
1429 showException other_exception
1430 = io (putStrLn ("*** Exception: " ++ show other_exception))
1432 -----------------------------------------------------------------------------
1433 -- recursive exception handlers
1435 -- Don't forget to unblock async exceptions in the handler, or if we're
1436 -- in an exception loop (eg. let a = error a in a) the ^C exception
1437 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1439 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1440 ghciHandle h (GHCi m) = GHCi $ \s ->
1441 Exception.catch (m s)
1442 (\e -> unGHCi (ghciUnblock (h e)) s)
1444 ghciUnblock :: GHCi a -> GHCi a
1445 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1448 -- ----------------------------------------------------------------------------
1451 expandPath :: String -> GHCi String
1453 case dropWhile isSpace path of
1455 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1456 return (tilde ++ '/':d)
1460 wantInterpretedModule :: String -> GHCi Module
1461 wantInterpretedModule str = do
1462 session <- getSession
1463 modl <- lookupModule str
1464 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1465 when (not is_interpreted) $
1466 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1469 wantNameFromInterpretedModule noCanDo str and_then = do
1470 session <- getSession
1471 names <- io $ GHC.parseName session str
1475 let modl = GHC.nameModule n
1476 if not (GHC.isExternalName n)
1477 then noCanDo n $ ppr n <>
1478 text " is not defined in an interpreted module"
1480 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1481 if not is_interpreted
1482 then noCanDo n $ text "module " <> ppr modl <>
1483 text " is not interpreted"
1486 -- ----------------------------------------------------------------------------
1487 -- Windows console setup
1489 setUpConsole :: IO ()
1491 #ifdef mingw32_HOST_OS
1492 -- On Windows we need to set a known code page, otherwise the characters
1493 -- we read from the console will be be in some strange encoding, and
1494 -- similarly for characters we write to the console.
1496 -- At the moment, GHCi pretends all input is Latin-1. In the
1497 -- future we should support UTF-8, but for now we set the code pages
1500 -- It seems you have to set the font in the console window to
1501 -- a Unicode font in order for output to work properly,
1502 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1503 -- (see MSDN for SetConsoleOutputCP()).
1505 setConsoleCP 28591 -- ISO Latin-1
1506 setConsoleOutputCP 28591 -- ISO Latin-1
1510 -- -----------------------------------------------------------------------------
1511 -- commands for debugger
1513 sprintCmd = pprintCommand False False
1514 printCmd = pprintCommand True False
1515 forceCmd = pprintCommand False True
1517 pprintCommand bind force str = do
1518 session <- getSession
1519 io $ pprintClosureCommand session bind force str
1521 stepCmd :: String -> GHCi ()
1522 stepCmd [] = doContinue GHC.SingleStep
1523 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1525 traceCmd :: String -> GHCi ()
1526 traceCmd [] = doContinue GHC.RunAndLogSteps
1527 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1529 continueCmd :: String -> GHCi ()
1530 continueCmd = noArgs $ doContinue GHC.RunToCompletion
1532 doContinue :: SingleStep -> GHCi ()
1533 doContinue step = do
1534 session <- getSession
1535 runResult <- io $ GHC.resume session step
1536 afterRunStmt runResult
1539 abandonCmd :: String -> GHCi ()
1540 abandonCmd = noArgs $ do
1542 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1543 when (not b) $ io $ putStrLn "There is no computation running."
1546 deleteCmd :: String -> GHCi ()
1547 deleteCmd argLine = do
1548 deleteSwitch $ words argLine
1550 deleteSwitch :: [String] -> GHCi ()
1552 io $ putStrLn "The delete command requires at least one argument."
1553 -- delete all break points
1554 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1555 deleteSwitch idents = do
1556 mapM_ deleteOneBreak idents
1558 deleteOneBreak :: String -> GHCi ()
1560 | all isDigit str = deleteBreak (read str)
1561 | otherwise = return ()
1563 historyCmd :: String -> GHCi ()
1565 | null arg = history 20
1566 | all isDigit arg = history (read arg)
1567 | otherwise = io $ putStrLn "Syntax: :history [num]"
1571 resumes <- io $ GHC.getResumeContext s
1573 [] -> io $ putStrLn "Not stopped at a breakpoint"
1575 let hist = GHC.resumeHistory r
1576 (took,rest) = splitAt num hist
1577 spans <- mapM (io . GHC.getHistorySpan s) took
1578 let nums = map (printf "-%-3d:") [(1::Int)..]
1579 printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans)))
1580 io $ putStrLn $ if null rest then "<end of history>" else "..."
1582 backCmd :: String -> GHCi ()
1583 backCmd = noArgs $ do
1585 (names, ix, span) <- io $ GHC.back s
1586 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1587 mapM_ (showTypeOfName s) names
1588 -- run the command set with ":set stop <cmd>"
1590 enqueueCommands [stop st]
1592 forwardCmd :: String -> GHCi ()
1593 forwardCmd = noArgs $ do
1595 (names, ix, span) <- io $ GHC.forward s
1596 printForUser $ (if (ix == 0)
1597 then ptext SLIT("Stopped at")
1598 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1599 mapM_ (showTypeOfName s) names
1600 -- run the command set with ":set stop <cmd>"
1602 enqueueCommands [stop st]
1604 -- handle the "break" command
1605 breakCmd :: String -> GHCi ()
1606 breakCmd argLine = do
1607 session <- getSession
1608 breakSwitch session $ words argLine
1610 breakSwitch :: Session -> [String] -> GHCi ()
1611 breakSwitch _session [] = do
1612 io $ putStrLn "The break command requires at least one argument."
1613 breakSwitch session args@(arg1:rest)
1614 | looksLikeModuleName arg1 = do
1615 mod <- wantInterpretedModule arg1
1616 breakByModule session mod rest
1617 | all isDigit arg1 = do
1618 (toplevel, _) <- io $ GHC.getContext session
1620 (mod : _) -> breakByModuleLine mod (read arg1) rest
1622 io $ putStrLn "Cannot find default module for breakpoint."
1623 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1624 | otherwise = do -- try parsing it as an identifier
1625 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1626 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1627 if GHC.isGoodSrcLoc loc
1628 then findBreakAndSet (GHC.nameModule name) $
1629 findBreakByCoord (Just (GHC.srcLocFile loc))
1630 (GHC.srcLocLine loc,
1632 else noCanDo name $ text "can't find its location: " <> ppr loc
1634 noCanDo n why = printForUser $
1635 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1637 breakByModule :: Session -> Module -> [String] -> GHCi ()
1638 breakByModule session mod args@(arg1:rest)
1639 | all isDigit arg1 = do -- looks like a line number
1640 breakByModuleLine mod (read arg1) rest
1641 | otherwise = io $ putStrLn "Invalid arguments to :break"
1643 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1644 breakByModuleLine mod line args
1645 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1646 | [col] <- args, all isDigit col =
1647 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1648 | otherwise = io $ putStrLn "Invalid arguments to :break"
1650 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1651 findBreakAndSet mod lookupTickTree = do
1652 tickArray <- getTickArray mod
1653 (breakArray, _) <- getModBreak mod
1654 case lookupTickTree tickArray of
1655 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1656 Just (tick, span) -> do
1657 success <- io $ setBreakFlag True breakArray tick
1658 session <- getSession
1662 recordBreak $ BreakLocation
1669 text "Breakpoint " <> ppr nm <>
1671 then text " was already set at " <> ppr span
1672 else text " activated at " <> ppr span
1674 printForUser $ text "Breakpoint could not be activated at"
1677 -- When a line number is specified, the current policy for choosing
1678 -- the best breakpoint is this:
1679 -- - the leftmost complete subexpression on the specified line, or
1680 -- - the leftmost subexpression starting on the specified line, or
1681 -- - the rightmost subexpression enclosing the specified line
1683 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1684 findBreakByLine line arr
1685 | not (inRange (bounds arr) line) = Nothing
1687 listToMaybe (sortBy leftmost_largest complete) `mplus`
1688 listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1689 listToMaybe (sortBy rightmost ticks)
1693 starts_here = [ tick | tick@(nm,span) <- ticks,
1694 GHC.srcSpanStartLine span == line ]
1696 (complete,incomplete) = partition ends_here starts_here
1697 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1699 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1700 -> Maybe (BreakIndex,SrcSpan)
1701 findBreakByCoord mb_file (line, col) arr
1702 | not (inRange (bounds arr) line) = Nothing
1704 listToMaybe (sortBy rightmost contains) `mplus`
1705 listToMaybe (sortBy leftmost_smallest after_here)
1709 -- the ticks that span this coordinate
1710 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1711 is_correct_file span ]
1713 is_correct_file span
1714 | Just f <- mb_file = GHC.srcSpanFile span == f
1717 after_here = [ tick | tick@(nm,span) <- ticks,
1718 GHC.srcSpanStartLine span == line,
1719 GHC.srcSpanStartCol span >= col ]
1722 leftmost_smallest (_,a) (_,b) = a `compare` b
1723 leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1725 (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1726 rightmost (_,a) (_,b) = b `compare` a
1728 spans :: SrcSpan -> (Int,Int) -> Bool
1729 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1730 where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1732 -- for now, use ANSI bold on Unixy systems. On Windows, we add a line
1733 -- of carets under the active expression instead. The Windows console
1734 -- doesn't support ANSI escape sequences, and most Unix terminals
1735 -- (including xterm) do, so this is a reasonable guess until we have a
1736 -- proper termcap/terminfo library.
1737 #if !defined(mingw32_TARGET_OS)
1743 start_bold = BS.pack "\ESC[1m"
1744 end_bold = BS.pack "\ESC[0m"
1746 listCmd :: String -> GHCi ()
1748 mb_span <- getCurrentBreakSpan
1750 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1751 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1752 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
1753 listCmd str = list2 (words str)
1755 list2 [arg] | all isDigit arg = do
1756 session <- getSession
1757 (toplevel, _) <- io $ GHC.getContext session
1759 [] -> io $ putStrLn "No module to list"
1760 (mod : _) -> listModuleLine mod (read arg)
1761 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1762 mod <- wantInterpretedModule arg1
1763 listModuleLine mod (read arg2)
1765 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1766 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1767 if GHC.isGoodSrcLoc loc
1769 tickArray <- getTickArray (GHC.nameModule name)
1770 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1771 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1774 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1775 Just (_,span) -> io $ listAround span False
1777 noCanDo name $ text "can't find its location: " <>
1780 noCanDo n why = printForUser $
1781 text "cannot list source code for " <> ppr n <> text ": " <> why
1783 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1785 listModuleLine :: Module -> Int -> GHCi ()
1786 listModuleLine modl line = do
1787 session <- getSession
1788 graph <- io (GHC.getModuleGraph session)
1789 let this = filter ((== modl) . GHC.ms_mod) graph
1791 [] -> panic "listModuleLine"
1793 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1794 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1795 io $ listAround (GHC.srcLocSpan loc) False
1797 -- | list a section of a source file around a particular SrcSpan.
1798 -- If the highlight flag is True, also highlight the span using
1799 -- start_bold/end_bold.
1800 listAround span do_highlight = do
1802 contents <- BS.readFile (pwd `joinFileName` unpackFS file)
1804 lines = BS.split '\n' contents
1805 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1806 drop (line1 - 1 - pad_before) $ lines
1807 fst_line = max 1 (line1 - pad_before)
1808 line_nos = [ fst_line .. ]
1810 highlighted | do_highlight = zipWith highlight line_nos these_lines
1811 | otherwise = these_lines
1813 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1814 prefixed = zipWith BS.append bs_line_nos highlighted
1816 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1818 file = GHC.srcSpanFile span
1819 line1 = GHC.srcSpanStartLine span
1820 col1 = GHC.srcSpanStartCol span
1821 line2 = GHC.srcSpanEndLine span
1822 col2 = GHC.srcSpanEndCol span
1824 pad_before | line1 == 1 = 0
1828 highlight | do_bold = highlight_bold
1829 | otherwise = highlight_carets
1831 highlight_bold no line
1832 | no == line1 && no == line2
1833 = let (a,r) = BS.splitAt col1 line
1834 (b,c) = BS.splitAt (col2-col1) r
1836 BS.concat [a,start_bold,b,end_bold,c]
1838 = let (a,b) = BS.splitAt col1 line in
1839 BS.concat [a, start_bold, b]
1841 = let (a,b) = BS.splitAt col2 line in
1842 BS.concat [a, end_bold, b]
1845 highlight_carets no line
1846 | no == line1 && no == line2
1847 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1848 BS.replicate (col2-col1) '^']
1850 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1851 BS.replicate (BS.length line-col1) '^']
1853 = BS.concat [line, nl, indent, BS.replicate col2 '^']
1856 indent = BS.pack " "
1857 nl = BS.singleton '\n'
1859 -- --------------------------------------------------------------------------
1862 getTickArray :: Module -> GHCi TickArray
1863 getTickArray modl = do
1865 let arrmap = tickarrays st
1866 case lookupModuleEnv arrmap modl of
1867 Just arr -> return arr
1869 (breakArray, ticks) <- getModBreak modl
1870 let arr = mkTickArray (assocs ticks)
1871 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1874 discardTickArrays :: GHCi ()
1875 discardTickArrays = do
1877 setGHCiState st{tickarrays = emptyModuleEnv}
1879 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1881 = accumArray (flip (:)) [] (1, max_line)
1882 [ (line, (nm,span)) | (nm,span) <- ticks,
1883 line <- srcSpanLines span ]
1885 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1886 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1887 GHC.srcSpanEndLine span ]
1889 lookupModule :: String -> GHCi Module
1890 lookupModule modName
1891 = do session <- getSession
1892 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1894 -- don't reset the counter back to zero?
1895 discardActiveBreakPoints :: GHCi ()
1896 discardActiveBreakPoints = do
1898 mapM (turnOffBreak.snd) (breaks st)
1899 setGHCiState $ st { breaks = [] }
1901 deleteBreak :: Int -> GHCi ()
1902 deleteBreak identity = do
1904 let oldLocations = breaks st
1905 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
1907 then printForUser (text "Breakpoint" <+> ppr identity <+>
1908 text "does not exist")
1910 mapM (turnOffBreak.snd) this
1911 setGHCiState $ st { breaks = rest }
1913 turnOffBreak loc = do
1914 (arr, _) <- getModBreak (breakModule loc)
1915 io $ setBreakFlag False arr (breakTick loc)
1917 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1918 getModBreak mod = do
1919 session <- getSession
1920 Just mod_info <- io $ GHC.getModuleInfo session mod
1921 let modBreaks = GHC.modInfoModBreaks mod_info
1922 let array = GHC.modBreaks_flags modBreaks
1923 let ticks = GHC.modBreaks_locs modBreaks
1924 return (array, ticks)
1926 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1927 setBreakFlag toggle array index
1928 | toggle = GHC.setBreakOn array index
1929 | otherwise = GHC.setBreakOff array index