1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005-2006
8 -----------------------------------------------------------------------------
9 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
11 #include "HsVersions.h"
19 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
20 Type, Module, ModuleName, TyThing(..), Phase,
21 BreakIndex, SrcSpan, Resume, SingleStep )
26 import HscTypes ( implicitTyThings )
28 import Outputable hiding (printForUser)
29 import Module -- for ModuleEnv
32 -- Other random utilities
34 import BasicTypes hiding (isTopLevel)
35 import Panic hiding (showException)
41 import Maybes ( orElse )
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 -----------------------------------------------------------------------------
87 ghciWelcomeMsg :: String
88 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
89 ": http://www.haskell.org/ghc/ :? for help"
91 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
94 GLOBAL_VAR(commands, builtin_commands, [Command])
96 builtin_commands :: [Command]
98 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
99 ("?", keepGoing help, False, completeNone),
100 ("add", keepGoingPaths addModule, False, completeFilename),
101 ("abandon", keepGoing abandonCmd, False, completeNone),
102 ("break", keepGoing breakCmd, False, completeIdentifier),
103 ("back", keepGoing backCmd, False, completeNone),
104 ("browse", keepGoing browseCmd, False, completeModule),
105 ("cd", keepGoing changeDirectory, False, completeFilename),
106 ("check", keepGoing checkModule, False, completeHomeModule),
107 ("continue", keepGoing continueCmd, False, completeNone),
108 ("cmd", keepGoing cmdCmd, False, completeIdentifier),
109 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
110 ("def", keepGoing defineMacro, False, completeIdentifier),
111 ("delete", keepGoing deleteCmd, False, completeNone),
112 ("e", keepGoing editFile, False, completeFilename),
113 ("edit", keepGoing editFile, False, completeFilename),
114 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
115 ("force", keepGoing forceCmd, False, completeIdentifier),
116 ("forward", keepGoing forwardCmd, False, completeNone),
117 ("help", keepGoing help, False, completeNone),
118 ("history", keepGoing historyCmd, False, completeNone),
119 ("info", keepGoing info, False, completeIdentifier),
120 ("kind", keepGoing kindOfType, False, completeIdentifier),
121 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
122 ("list", keepGoing listCmd, False, completeNone),
123 ("module", keepGoing setContext, False, completeModule),
124 ("main", keepGoing runMain, False, completeIdentifier),
125 ("print", keepGoing printCmd, False, completeIdentifier),
126 ("quit", quit, False, completeNone),
127 ("reload", keepGoing reloadModule, False, completeNone),
128 ("set", keepGoing setCmd, True, completeSetOptions),
129 ("show", keepGoing showCmd, False, completeNone),
130 ("sprint", keepGoing sprintCmd, False, completeIdentifier),
131 ("step", keepGoing stepCmd, False, completeIdentifier),
132 ("type", keepGoing typeOfExpr, False, completeIdentifier),
133 ("trace", keepGoing traceCmd, False, completeIdentifier),
134 ("undef", keepGoing undefineMacro, False, completeMacro),
135 ("unset", keepGoing unsetOptions, True, completeSetOptions)
138 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
139 keepGoing a str = a str >> return False
141 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
142 keepGoingPaths a str = a (toArgs str) >> return False
144 shortHelpText = "use :? for help.\n"
147 " Commands available from the prompt:\n" ++
149 " <statement> evaluate/run <statement>\n" ++
150 " :add <filename> ... add module(s) to the current target set\n" ++
151 " :browse [*]<module> display the names defined by <module>\n" ++
152 " :cd <dir> change directory to <dir>\n" ++
153 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
154 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
155 " :def <cmd> <expr> define a command :<cmd>\n" ++
156 " :edit <file> edit file\n" ++
157 " :edit edit last module\n" ++
158 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
159 " :help, :? display this list of commands\n" ++
160 " :info [<name> ...] display information about the given names\n" ++
161 " :kind <type> show the kind of <type>\n" ++
162 " :load <filename> ... load module(s) and their dependents\n" ++
163 " :main [<arguments> ...] run the main function with the given arguments\n" ++
164 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
165 " :quit exit GHCi\n" ++
166 " :reload reload the current module set\n" ++
167 " :type <expr> show the type of <expr>\n" ++
168 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
169 " :!<command> run the shell command <command>\n" ++
171 " -- Commands for debugging:\n" ++
173 " :abandon at a breakpoint, abandon current computation\n" ++
174 " :back go back in the history (after :trace)\n" ++
175 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
176 " :break <name> set a breakpoint on the specified function\n" ++
177 " :continue resume after a breakpoint\n" ++
178 " :delete <number> delete the specified breakpoint\n" ++
179 " :delete * delete all breakpoints\n" ++
180 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
181 " :forward go forward in the history (after :back)\n" ++
182 " :history [<n>] show the last <n> items in the history (after :trace)\n" ++
183 " :print [<name> ...] prints a value without forcing its computation\n" ++
184 " :sprint [<name> ...] simplifed version of :print\n" ++
185 " :step single-step after stopping at a breakpoint\n"++
186 " :step <expr> single-step into <expr>\n"++
187 " :trace trace after stopping at a breakpoint\n"++
188 " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
191 " -- Commands for changing settings:\n" ++
193 " :set <option> ... set options\n" ++
194 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
195 " :set prog <progname> set the value returned by System.getProgName\n" ++
196 " :set prompt <prompt> set the prompt used in GHCi\n" ++
197 " :set editor <cmd> set the command used for :edit\n" ++
198 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
199 " :unset <option> ... unset options\n" ++
201 " Options for ':set' and ':unset':\n" ++
203 " +r revert top-level expressions after each evaluation\n" ++
204 " +s print timing/memory stats after each evaluation\n" ++
205 " +t print type after evaluation\n" ++
206 " -<flags> most GHC command line flags can also be set here\n" ++
207 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
209 " -- Commands for displaying information:\n" ++
211 " :show bindings show the current bindings made at the prompt\n" ++
212 " :show breaks show the active breakpoints\n" ++
213 " :show context show the breakpoint context\n" ++
214 " :show modules show the currently loaded modules\n" ++
215 " :show <setting> show anything that can be set with :set (e.g. args)\n" ++
222 win <- System.Win32.getWindowsDirectory
223 return (win `joinFileName` "notepad.exe")
228 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
229 interactiveUI session srcs maybe_expr = do
230 -- HACK! If we happen to get into an infinite loop (eg the user
231 -- types 'let x=x in x' at the prompt), then the thread will block
232 -- on a blackhole, and become unreachable during GC. The GC will
233 -- detect that it is unreachable and send it the NonTermination
234 -- exception. However, since the thread is unreachable, everything
235 -- it refers to might be finalized, including the standard Handles.
236 -- This sounds like a bug, but we don't have a good solution right
242 -- Initialise buffering for the *interpreted* I/O system
243 initInterpBuffering session
245 when (isNothing maybe_expr) $ do
246 -- Only for GHCi (not runghc and ghc -e):
248 -- Turn buffering off for the compiled program's stdout/stderr
250 -- Turn buffering off for GHCi's stdout
252 hSetBuffering stdout NoBuffering
253 -- We don't want the cmd line to buffer any input that might be
254 -- intended for the program, so unbuffer stdin.
255 hSetBuffering stdin NoBuffering
257 -- initial context is just the Prelude
258 prel_mod <- GHC.findModule session prel_name (Just basePackageId)
259 GHC.setContext session [] [prel_mod]
263 Readline.setAttemptedCompletionFunction (Just completeWord)
264 --Readline.parseAndBind "set show-all-if-ambiguous 1"
266 let symbols = "!#$%&*+/<=>?@\\^|-~"
267 specials = "(),;[]`{}"
269 word_break_chars = spaces ++ specials ++ symbols
271 Readline.setBasicWordBreakCharacters word_break_chars
272 Readline.setCompleterWordBreakCharacters word_break_chars
275 default_editor <- findEditor
277 startGHCi (runGHCi srcs maybe_expr)
278 GHCiState{ progname = "<interactive>",
282 editor = default_editor,
288 tickarrays = emptyModuleEnv,
293 Readline.resetTerminal Nothing
298 prel_name = GHC.mkModuleName "Prelude"
300 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
301 runGHCi paths maybe_expr = do
302 let read_dot_files = not opt_IgnoreDotGhci
304 when (read_dot_files) $ do
307 exists <- io (doesFileExist file)
309 dir_ok <- io (checkPerms ".")
310 file_ok <- io (checkPerms file)
311 when (dir_ok && file_ok) $ do
312 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
315 Right hdl -> fileLoop hdl False
317 when (read_dot_files) $ do
318 -- Read in $HOME/.ghci
319 either_dir <- io (IO.try (getEnv "HOME"))
323 cwd <- io (getCurrentDirectory)
324 when (dir /= cwd) $ do
325 let file = dir ++ "/.ghci"
326 ok <- io (checkPerms file)
328 either_hdl <- io (IO.try (openFile file ReadMode))
331 Right hdl -> fileLoop hdl False
333 -- Perform a :load for files given on the GHCi command line
334 -- When in -e mode, if the load fails then we want to stop
335 -- immediately rather than going on to evaluate the expression.
336 when (not (null paths)) $ do
337 ok <- ghciHandle (\e -> do showException e; return Failed) $
339 when (isJust maybe_expr && failed ok) $
340 io (exitWith (ExitFailure 1))
342 -- if verbosity is greater than 0, or we are connected to a
343 -- terminal, display the prompt in the interactive loop.
344 is_tty <- io (hIsTerminalDevice stdin)
345 dflags <- getDynFlags
346 let show_prompt = verbosity dflags > 0 || is_tty
351 #if defined(mingw32_HOST_OS)
352 -- The win32 Console API mutates the first character of
353 -- type-ahead when reading from it in a non-buffered manner. Work
354 -- around this by flushing the input buffer of type-ahead characters,
355 -- but only if stdin is available.
356 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
358 Left err | isDoesNotExistError err -> return ()
359 | otherwise -> io (ioError err)
360 Right () -> return ()
362 -- initialise the console if necessary
365 -- enter the interactive loop
366 interactiveLoop is_tty show_prompt
368 -- just evaluate the expression we were given
373 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
376 interactiveLoop is_tty show_prompt =
377 -- Ignore ^C exceptions caught here
378 ghciHandleDyn (\e -> case e of
380 #if defined(mingw32_HOST_OS)
383 interactiveLoop is_tty show_prompt
384 _other -> return ()) $
386 ghciUnblock $ do -- unblock necessary if we recursed from the
387 -- exception handler above.
389 -- read commands from stdin
393 else fileLoop stdin show_prompt
395 fileLoop stdin show_prompt
399 -- NOTE: We only read .ghci files if they are owned by the current user,
400 -- and aren't world writable. Otherwise, we could be accidentally
401 -- running code planted by a malicious third party.
403 -- Furthermore, We only read ./.ghci if . is owned by the current user
404 -- and isn't writable by anyone else. I think this is sufficient: we
405 -- don't need to check .. and ../.. etc. because "." always refers to
406 -- the same directory while a process is running.
408 checkPerms :: String -> IO Bool
410 #ifdef mingw32_HOST_OS
413 Util.handle (\_ -> return False) $ do
414 st <- getFileStatus name
416 if fileOwner st /= me then do
417 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
420 let mode = fileMode st
421 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
422 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
424 putStrLn $ "*** WARNING: " ++ name ++
425 " is writable by someone else, IGNORING!"
430 fileLoop :: Handle -> Bool -> GHCi ()
431 fileLoop hdl show_prompt = do
432 when show_prompt $ do
435 l <- io (IO.try (hGetLine hdl))
437 Left e | isEOFError e -> return ()
438 | InvalidArgument <- etype -> return ()
439 | otherwise -> io (ioError e)
440 where etype = ioeGetErrorType e
441 -- treat InvalidArgument in the same way as EOF:
442 -- this can happen if the user closed stdin, or
443 -- perhaps did getContents which closes stdin at
446 case removeSpaces l of
447 "" -> fileLoop hdl show_prompt
448 l -> do quit <- runCommands l
449 if quit then return () else fileLoop hdl show_prompt
452 session <- getSession
453 (toplevs,exports) <- io (GHC.getContext session)
454 resumes <- io $ GHC.getResumeContext session
460 let ix = GHC.resumeHistoryIx r
462 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
464 let hist = GHC.resumeHistory r !! (ix-1)
465 span <- io $ GHC.getHistorySpan session hist
466 return (brackets (ppr (negate ix) <> char ':'
467 <+> ppr span) <> space)
469 dots | r:rs <- resumes, not (null rs) = text "... "
473 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
474 hsep (map (ppr . GHC.moduleName) exports)
476 deflt_prompt = dots <> context_bit <> modules_bit
478 f ('%':'s':xs) = deflt_prompt <> f xs
479 f ('%':'%':xs) = char '%' <> f xs
480 f (x:xs) = char x <> f xs
484 return (showSDoc (f (prompt st)))
488 readlineLoop :: GHCi ()
490 session <- getSession
491 (mod,imports) <- io (GHC.getContext session)
493 saveSession -- for use by completion
495 mb_span <- getCurrentBreakSpan
497 l <- io (readline prompt `finally` setNonBlockingFD 0)
498 -- readline sometimes puts stdin into blocking mode,
499 -- so we need to put it back for the IO library
504 case removeSpaces l of
508 quit <- runCommands l
509 if quit then return () else readlineLoop
512 runCommands :: String -> GHCi Bool
514 q <- ghciHandle handler (doCommand cmd)
515 if q then return True else runNext
521 c:cs -> do setGHCiState st{ cmdqueue = cs }
524 doCommand (':' : cmd) = specialCommand cmd
525 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
528 enqueueCommands :: [String] -> GHCi ()
529 enqueueCommands cmds = do
531 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
534 -- This version is for the GHC command-line option -e. The only difference
535 -- from runCommand is that it catches the ExitException exception and
536 -- exits, rather than printing out the exception.
537 runCommandEval c = ghciHandle handleEval (doCommand c)
539 handleEval (ExitException code) = io (exitWith code)
540 handleEval e = do handler e
541 io (exitWith (ExitFailure 1))
543 doCommand (':' : command) = specialCommand command
545 = do r <- runStmt stmt GHC.RunToCompletion
547 False -> io (exitWith (ExitFailure 1))
548 -- failure to run the command causes exit(1) for ghc -e.
551 runStmt :: String -> SingleStep -> GHCi Bool
553 | null (filter (not.isSpace) stmt) = return False
554 | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
556 = do st <- getGHCiState
557 session <- getSession
558 result <- io $ withProgName (progname st) $ withArgs (args st) $
559 GHC.runStmt session stmt step
563 afterRunStmt :: GHC.RunResult -> GHCi Bool
564 -- False <=> the statement failed to compile
565 afterRunStmt (GHC.RunException e) = throw e
566 afterRunStmt run_result = do
567 session <- getSession
569 GHC.RunOk names -> do
570 show_types <- isOptionSet ShowType
571 when show_types $ printTypeOfNames session names
572 GHC.RunBreak _ names mb_info -> do
573 resumes <- io $ GHC.getResumeContext session
574 printForUser $ ptext SLIT("Stopped at") <+>
575 ppr (GHC.resumeSpan (head resumes))
576 printTypeOfNames session names
577 maybe (return ()) runBreakCmd mb_info
578 -- run the command set with ":set stop <cmd>"
580 enqueueCommands [stop st]
585 io installSignalHandlers
586 b <- isOptionSet RevertCAFs
587 io (when b revertCAFs)
589 return (case run_result of GHC.RunOk _ -> True; _ -> False)
591 runBreakCmd :: GHC.BreakInfo -> GHCi ()
592 runBreakCmd info = do
593 let mod = GHC.breakInfo_module info
594 nm = GHC.breakInfo_number info
596 case [ loc | (i,loc) <- breaks st,
597 breakModule loc == mod, breakTick loc == nm ] of
599 loc:_ | null cmd -> return ()
600 | otherwise -> do enqueueCommands [cmd]; return ()
601 where cmd = onBreakCmd loc
603 printTypeOfNames :: Session -> [Name] -> GHCi ()
604 printTypeOfNames session names
605 = mapM_ (printTypeOfName session) $ sortBy compareNames names
607 compareNames :: Name -> Name -> Ordering
608 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
609 where compareWith n = (getOccString n, getSrcSpan n)
611 printTypeOfName :: Session -> Name -> GHCi ()
612 printTypeOfName session n
613 = do maybe_tything <- io (GHC.lookupName session n)
614 case maybe_tything of
616 Just thing -> printTyThing thing
618 specialCommand :: String -> GHCi Bool
619 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
620 specialCommand str = do
621 let (cmd,rest) = break isSpace str
622 maybe_cmd <- io (lookupCommand cmd)
624 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
625 ++ shortHelpText) >> return False)
626 Just (_,f,_,_) -> f (dropWhile isSpace rest)
628 lookupCommand :: String -> IO (Maybe Command)
629 lookupCommand str = do
630 cmds <- readIORef commands
631 -- look for exact match first, then the first prefix match
632 case [ c | c <- cmds, str == cmdName c ] of
633 c:_ -> return (Just c)
634 [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
636 c:_ -> return (Just c)
639 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
640 getCurrentBreakSpan = do
641 session <- getSession
642 resumes <- io $ GHC.getResumeContext session
646 let ix = GHC.resumeHistoryIx r
648 then return (Just (GHC.resumeSpan r))
650 let hist = GHC.resumeHistory r !! (ix-1)
651 span <- io $ GHC.getHistorySpan session hist
654 -----------------------------------------------------------------------------
657 noArgs :: GHCi () -> String -> GHCi ()
659 noArgs m _ = io $ putStrLn "This command takes no arguments"
661 help :: String -> GHCi ()
662 help _ = io (putStr helpText)
664 info :: String -> GHCi ()
665 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
666 info s = do { let names = words s
667 ; session <- getSession
668 ; dflags <- getDynFlags
669 ; let pefas = dopt Opt_PrintExplicitForalls dflags
670 ; mapM_ (infoThing pefas session) names }
672 infoThing pefas session str = io $ do
673 names <- GHC.parseName session str
674 mb_stuffs <- mapM (GHC.getInfo session) names
675 let filtered = filterOutChildren (\(t,f,i) -> t) (catMaybes mb_stuffs)
676 unqual <- GHC.getPrintUnqual session
677 putStrLn (showSDocForUser unqual $
678 vcat (intersperse (text "") $
679 map (pprInfo pefas) filtered))
681 -- Filter out names whose parent is also there Good
682 -- example is '[]', which is both a type and data
683 -- constructor in the same type
684 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
685 filterOutChildren get_thing xs
686 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
688 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
690 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
691 pprInfo pefas (thing, fixity, insts)
692 = pprTyThingInContextLoc pefas thing
693 $$ show_fixity fixity
694 $$ vcat (map GHC.pprInstance insts)
697 | fix == GHC.defaultFixity = empty
698 | otherwise = ppr fix <+> ppr (GHC.getName thing)
700 runMain :: String -> GHCi ()
702 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
703 enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
705 addModule :: [FilePath] -> GHCi ()
707 io (revertCAFs) -- always revert CAFs on load/add.
708 files <- mapM expandPath files
709 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
710 session <- getSession
711 io (mapM_ (GHC.addTarget session) targets)
712 ok <- io (GHC.load session LoadAllTargets)
715 changeDirectory :: String -> GHCi ()
716 changeDirectory dir = do
717 session <- getSession
718 graph <- io (GHC.getModuleGraph session)
719 when (not (null graph)) $
720 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
721 io (GHC.setTargets session [])
722 io (GHC.load session LoadAllTargets)
723 setContextAfterLoad session []
724 io (GHC.workingDirectoryChanged session)
725 dir <- expandPath dir
726 io (setCurrentDirectory dir)
728 editFile :: String -> GHCi ()
730 do file <- if null str then chooseEditFile else return str
734 $ throwDyn (CmdLineError "editor not set, use :set editor")
735 io $ system (cmd ++ ' ':file)
738 -- The user didn't specify a file so we pick one for them.
739 -- Our strategy is to pick the first module that failed to load,
740 -- or otherwise the first target.
742 -- XXX: Can we figure out what happened if the depndecy analysis fails
743 -- (e.g., because the porgrammeer mistyped the name of a module)?
744 -- XXX: Can we figure out the location of an error to pass to the editor?
745 -- XXX: if we could figure out the list of errors that occured during the
746 -- last load/reaload, then we could start the editor focused on the first
748 chooseEditFile :: GHCi String
750 do session <- getSession
751 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
753 graph <- io (GHC.getModuleGraph session)
754 failed_graph <- filterM hasFailed graph
755 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
757 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
760 case pick (order failed_graph) of
761 Just file -> return file
763 do targets <- io (GHC.getTargets session)
764 case msum (map fromTarget targets) of
765 Just file -> return file
766 Nothing -> throwDyn (CmdLineError "No files to edit.")
768 where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
769 fromTarget _ = Nothing -- when would we get a module target?
771 defineMacro :: String -> GHCi ()
773 let (macro_name, definition) = break isSpace s
774 cmds <- io (readIORef commands)
776 then throwDyn (CmdLineError "invalid macro name")
778 if (macro_name `elem` map cmdName cmds)
779 then throwDyn (CmdLineError
780 ("command '" ++ macro_name ++ "' is already defined"))
783 -- give the expression a type signature, so we can be sure we're getting
784 -- something of the right type.
785 let new_expr = '(' : definition ++ ") :: String -> IO String"
787 -- compile the expression
789 maybe_hv <- io (GHC.compileExpr cms new_expr)
792 Just hv -> io (writeIORef commands --
793 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
795 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
797 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
798 enqueueCommands (lines str)
801 undefineMacro :: String -> GHCi ()
802 undefineMacro macro_name = do
803 cmds <- io (readIORef commands)
804 if (macro_name `elem` map cmdName builtin_commands)
805 then throwDyn (CmdLineError
806 ("command '" ++ macro_name ++ "' cannot be undefined"))
808 if (macro_name `notElem` map cmdName cmds)
809 then throwDyn (CmdLineError
810 ("command '" ++ macro_name ++ "' not defined"))
812 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
814 cmdCmd :: String -> GHCi ()
816 let expr = '(' : str ++ ") :: IO String"
817 session <- getSession
818 maybe_hv <- io (GHC.compileExpr session expr)
822 cmds <- io $ (unsafeCoerce# hv :: IO String)
823 enqueueCommands (lines cmds)
826 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
827 loadModule fs = timeIt (loadModule' fs)
829 loadModule_ :: [FilePath] -> GHCi ()
830 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
832 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
833 loadModule' files = do
834 session <- getSession
837 discardActiveBreakPoints
838 io (GHC.setTargets session [])
839 io (GHC.load session LoadAllTargets)
842 let (filenames, phases) = unzip files
843 exp_filenames <- mapM expandPath filenames
844 let files' = zip exp_filenames phases
845 targets <- io (mapM (uncurry GHC.guessTarget) files')
847 -- NOTE: we used to do the dependency anal first, so that if it
848 -- fails we didn't throw away the current set of modules. This would
849 -- require some re-working of the GHC interface, so we'll leave it
850 -- as a ToDo for now.
852 io (GHC.setTargets session targets)
853 doLoad session LoadAllTargets
855 checkModule :: String -> GHCi ()
857 let modl = GHC.mkModuleName m
858 session <- getSession
859 result <- io (GHC.checkModule session modl False)
861 Nothing -> io $ putStrLn "Nothing"
862 Just r -> io $ putStrLn (showSDoc (
863 case GHC.checkedModuleInfo r of
864 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
866 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
868 (text "global names: " <+> ppr global) $$
869 (text "local names: " <+> ppr local)
871 afterLoad (successIf (isJust result)) session
873 reloadModule :: String -> GHCi ()
875 io (revertCAFs) -- always revert CAFs on reload.
876 discardActiveBreakPoints
877 session <- getSession
878 doLoad session $ if null m then LoadAllTargets
879 else LoadUpTo (GHC.mkModuleName m)
882 doLoad session howmuch = do
883 -- turn off breakpoints before we load: we can't turn them off later, because
884 -- the ModBreaks will have gone away.
885 discardActiveBreakPoints
886 ok <- io (GHC.load session howmuch)
890 afterLoad ok session = do
891 io (revertCAFs) -- always revert CAFs on load.
893 graph <- io (GHC.getModuleGraph session)
894 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
895 setContextAfterLoad session graph'
896 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
898 setContextAfterLoad session [] = do
899 prel_mod <- getPrelude
900 io (GHC.setContext session [] [prel_mod])
901 setContextAfterLoad session ms = do
902 -- load a target if one is available, otherwise load the topmost module.
903 targets <- io (GHC.getTargets session)
904 case [ m | Just m <- map (findTarget ms) targets ] of
906 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
907 load_this (last graph')
912 = case filter (`matches` t) ms of
916 summary `matches` Target (TargetModule m) _
917 = GHC.ms_mod_name summary == m
918 summary `matches` Target (TargetFile f _) _
919 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
920 summary `matches` target
923 load_this summary | m <- GHC.ms_mod summary = do
924 b <- io (GHC.moduleIsInterpreted session m)
925 if b then io (GHC.setContext session [m] [])
927 prel_mod <- getPrelude
928 io (GHC.setContext session [] [prel_mod,m])
931 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
932 modulesLoadedMsg ok mods = do
933 dflags <- getDynFlags
934 when (verbosity dflags > 0) $ do
936 | null mods = text "none."
938 punctuate comma (map ppr mods)) <> text "."
941 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
943 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
946 typeOfExpr :: String -> GHCi ()
948 = do cms <- getSession
949 maybe_ty <- io (GHC.exprType cms str)
952 Just ty -> do ty' <- cleanType ty
953 printForUser $ text str <> text " :: " <> ppr ty'
955 kindOfType :: String -> GHCi ()
957 = do cms <- getSession
958 maybe_ty <- io (GHC.typeKind cms str)
961 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
963 quit :: String -> GHCi Bool
966 shellEscape :: String -> GHCi Bool
967 shellEscape str = io (system str >> return False)
969 -----------------------------------------------------------------------------
970 -- Browsing a module's contents
972 browseCmd :: String -> GHCi ()
975 ['*':m] | looksLikeModuleName m -> browseModule m False
976 [m] | looksLikeModuleName m -> browseModule m True
977 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
979 browseModule m exports_only = do
981 modl <- if exports_only then lookupModule m
982 else wantInterpretedModule m
984 -- Temporarily set the context to the module we're interested in,
985 -- just so we can get an appropriate PrintUnqualified
986 (as,bs) <- io (GHC.getContext s)
987 prel_mod <- getPrelude
988 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
989 else GHC.setContext s [modl] [])
990 unqual <- io (GHC.getPrintUnqual s)
991 io (GHC.setContext s as bs)
993 mb_mod_info <- io $ GHC.getModuleInfo s modl
995 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
998 | exports_only = GHC.modInfoExports mod_info
999 | otherwise = GHC.modInfoTopLevelScope mod_info
1002 mb_things <- io $ mapM (GHC.lookupName s) names
1003 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1005 dflags <- getDynFlags
1006 let pefas = dopt Opt_PrintExplicitForalls dflags
1007 io (putStrLn (showSDocForUser unqual (
1008 vcat (map (pprTyThingInContext pefas) filtered_things)
1010 -- ToDo: modInfoInstances currently throws an exception for
1011 -- package modules. When it works, we can do this:
1012 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1014 -----------------------------------------------------------------------------
1015 -- Setting the module context
1018 | all sensible mods = fn mods
1019 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1021 (fn, mods) = case str of
1022 '+':stuff -> (addToContext, words stuff)
1023 '-':stuff -> (removeFromContext, words stuff)
1024 stuff -> (newContext, words stuff)
1026 sensible ('*':m) = looksLikeModuleName m
1027 sensible m = looksLikeModuleName m
1029 separate :: Session -> [String] -> [Module] -> [Module]
1030 -> GHCi ([Module],[Module])
1031 separate session [] as bs = return (as,bs)
1032 separate session (('*':str):ms) as bs = do
1033 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1034 b <- io $ GHC.moduleIsInterpreted session m
1035 if b then separate session ms (m:as) bs
1036 else throwDyn (CmdLineError ("module '"
1037 ++ GHC.moduleNameString (GHC.moduleName m)
1038 ++ "' is not interpreted"))
1039 separate session (str:ms) as bs = do
1040 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1041 separate session ms as (m:bs)
1043 newContext :: [String] -> GHCi ()
1044 newContext strs = do
1046 (as,bs) <- separate s strs [] []
1047 prel_mod <- getPrelude
1048 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1049 io $ GHC.setContext s as bs'
1052 addToContext :: [String] -> GHCi ()
1053 addToContext strs = do
1055 (as,bs) <- io $ GHC.getContext s
1057 (new_as,new_bs) <- separate s strs [] []
1059 let as_to_add = new_as \\ (as ++ bs)
1060 bs_to_add = new_bs \\ (as ++ bs)
1062 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1065 removeFromContext :: [String] -> GHCi ()
1066 removeFromContext strs = do
1068 (as,bs) <- io $ GHC.getContext s
1070 (as_to_remove,bs_to_remove) <- separate s strs [] []
1072 let as' = as \\ (as_to_remove ++ bs_to_remove)
1073 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1075 io $ GHC.setContext s as' bs'
1077 ----------------------------------------------------------------------------
1080 -- set options in the interpreter. Syntax is exactly the same as the
1081 -- ghc command line, except that certain options aren't available (-C,
1084 -- This is pretty fragile: most options won't work as expected. ToDo:
1085 -- figure out which ones & disallow them.
1087 setCmd :: String -> GHCi ()
1089 = do st <- getGHCiState
1090 let opts = options st
1091 io $ putStrLn (showSDoc (
1092 text "options currently set: " <>
1095 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1098 = case toArgs str of
1099 ("args":args) -> setArgs args
1100 ("prog":prog) -> setProg prog
1101 ("prompt":prompt) -> setPrompt (after 6)
1102 ("editor":cmd) -> setEditor (after 6)
1103 ("stop":cmd) -> setStop (after 4)
1104 wds -> setOptions wds
1105 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1109 setGHCiState st{ args = args }
1113 setGHCiState st{ progname = prog }
1115 io (hPutStrLn stderr "syntax: :set prog <progname>")
1119 setGHCiState st{ editor = cmd }
1121 setStop str@(c:_) | isDigit c
1122 = do let (nm_str,rest) = break (not.isDigit) str
1125 let old_breaks = breaks st
1126 if all ((/= nm) . fst) old_breaks
1127 then printForUser (text "Breakpoint" <+> ppr nm <+>
1128 text "does not exist")
1130 let new_breaks = map fn old_breaks
1131 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1132 | otherwise = (i,loc)
1133 setGHCiState st{ breaks = new_breaks }
1136 setGHCiState st{ stop = cmd }
1138 setPrompt value = do
1141 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1142 else setGHCiState st{ prompt = remQuotes value }
1144 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1148 do -- first, deal with the GHCi opts (+s, +t, etc.)
1149 let (plus_opts, minus_opts) = partition isPlus wds
1150 mapM_ setOpt plus_opts
1151 -- then, dynamic flags
1152 newDynFlags minus_opts
1154 newDynFlags minus_opts = do
1155 dflags <- getDynFlags
1156 let pkg_flags = packageFlags dflags
1157 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1159 if (not (null leftovers))
1160 then throwDyn (CmdLineError ("unrecognised flags: " ++
1164 new_pkgs <- setDynFlags dflags'
1166 -- if the package flags changed, we should reset the context
1167 -- and link the new packages.
1168 dflags <- getDynFlags
1169 when (packageFlags dflags /= pkg_flags) $ do
1170 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1171 session <- getSession
1172 io (GHC.setTargets session [])
1173 io (GHC.load session LoadAllTargets)
1174 io (linkPackages dflags new_pkgs)
1175 setContextAfterLoad session []
1179 unsetOptions :: String -> GHCi ()
1181 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1182 let opts = words str
1183 (minus_opts, rest1) = partition isMinus opts
1184 (plus_opts, rest2) = partition isPlus rest1
1186 if (not (null rest2))
1187 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1190 mapM_ unsetOpt plus_opts
1192 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1193 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1195 no_flags <- mapM no_flag minus_opts
1196 newDynFlags no_flags
1198 isMinus ('-':s) = True
1201 isPlus ('+':s) = True
1205 = case strToGHCiOpt str of
1206 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1207 Just o -> setOption o
1210 = case strToGHCiOpt str of
1211 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1212 Just o -> unsetOption o
1214 strToGHCiOpt :: String -> (Maybe GHCiOption)
1215 strToGHCiOpt "s" = Just ShowTiming
1216 strToGHCiOpt "t" = Just ShowType
1217 strToGHCiOpt "r" = Just RevertCAFs
1218 strToGHCiOpt _ = Nothing
1220 optToStr :: GHCiOption -> String
1221 optToStr ShowTiming = "s"
1222 optToStr ShowType = "t"
1223 optToStr RevertCAFs = "r"
1225 -- ---------------------------------------------------------------------------
1231 ["args"] -> io $ putStrLn (show (args st))
1232 ["prog"] -> io $ putStrLn (show (progname st))
1233 ["prompt"] -> io $ putStrLn (show (prompt st))
1234 ["editor"] -> io $ putStrLn (show (editor st))
1235 ["stop"] -> io $ putStrLn (show (stop st))
1236 ["modules" ] -> showModules
1237 ["bindings"] -> showBindings
1238 ["linker"] -> io showLinkerState
1239 ["breaks"] -> showBkptTable
1240 ["context"] -> showContext
1241 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1244 session <- getSession
1245 let show_one ms = do m <- io (GHC.showModule session ms)
1247 graph <- io (GHC.getModuleGraph session)
1248 mapM_ show_one graph
1252 unqual <- io (GHC.getPrintUnqual s)
1253 bindings <- io (GHC.getBindings s)
1254 mapM_ printTyThing $ sortBy compareTyThings bindings
1257 compareTyThings :: TyThing -> TyThing -> Ordering
1258 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1260 printTyThing :: TyThing -> GHCi ()
1261 printTyThing (AnId id) = do
1262 ty' <- cleanType (GHC.idType id)
1263 printForUser $ ppr id <> text " :: " <> ppr ty'
1264 printTyThing _ = return ()
1266 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1267 cleanType :: Type -> GHCi Type
1269 dflags <- getDynFlags
1270 if dopt Opt_PrintExplicitForalls dflags
1272 else return $! GHC.dropForAlls ty
1274 showBkptTable :: GHCi ()
1277 printForUser $ prettyLocations (breaks st)
1279 showContext :: GHCi ()
1281 session <- getSession
1282 resumes <- io $ GHC.getResumeContext session
1283 printForUser $ vcat (map pp_resume (reverse resumes))
1286 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1287 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1290 -- -----------------------------------------------------------------------------
1293 completeNone :: String -> IO [String]
1294 completeNone w = return []
1297 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1298 completeWord w start end = do
1299 line <- Readline.getLineBuffer
1301 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1303 | Just c <- is_cmd line -> do
1304 maybe_cmd <- lookupCommand c
1305 let (n,w') = selectWord (words' 0 line)
1307 Nothing -> return Nothing
1308 Just (_,_,False,complete) -> wrapCompleter complete w
1309 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1310 return (map (drop n) rets)
1311 in wrapCompleter complete' w'
1313 --printf "complete %s, start = %d, end = %d\n" w start end
1314 wrapCompleter completeIdentifier w
1315 where words' _ [] = []
1316 words' n str = let (w,r) = break isSpace str
1317 (s,r') = span isSpace r
1318 in (n,w):words' (n+length w+length s) r'
1319 -- In a Haskell expression we want to parse 'a-b' as three words
1320 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1321 -- only be a single word.
1322 selectWord [] = (0,w)
1323 selectWord ((offset,x):xs)
1324 | offset+length x >= start = (start-offset,take (end-offset) x)
1325 | otherwise = selectWord xs
1328 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1329 | otherwise = Nothing
1332 cmds <- readIORef commands
1333 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1335 completeMacro w = do
1336 cmds <- readIORef commands
1337 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1338 return (filter (w `isPrefixOf`) cmds')
1340 completeIdentifier w = do
1342 rdrs <- GHC.getRdrNamesInScope s
1343 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1345 completeModule w = do
1347 dflags <- GHC.getSessionDynFlags s
1348 let pkg_mods = allExposedModules dflags
1349 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1351 completeHomeModule w = do
1353 g <- GHC.getModuleGraph s
1354 let home_mods = map GHC.ms_mod_name g
1355 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1357 completeSetOptions w = do
1358 return (filter (w `isPrefixOf`) options)
1359 where options = "args":"prog":allFlags
1361 completeFilename = Readline.filenameCompletionFunction
1363 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1365 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1366 unionComplete f1 f2 w = do
1371 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1372 wrapCompleter fun w = do
1375 [] -> return Nothing
1376 [x] -> return (Just (x,[]))
1377 xs -> case getCommonPrefix xs of
1378 "" -> return (Just ("",xs))
1379 pref -> return (Just (pref,xs))
1381 getCommonPrefix :: [String] -> String
1382 getCommonPrefix [] = ""
1383 getCommonPrefix (s:ss) = foldl common s ss
1384 where common s "" = ""
1386 common (c:cs) (d:ds)
1387 | c == d = c : common cs ds
1390 allExposedModules :: DynFlags -> [ModuleName]
1391 allExposedModules dflags
1392 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1394 pkg_db = pkgIdMap (pkgState dflags)
1396 completeCmd = completeNone
1397 completeMacro = completeNone
1398 completeIdentifier = completeNone
1399 completeModule = completeNone
1400 completeHomeModule = completeNone
1401 completeSetOptions = completeNone
1402 completeFilename = completeNone
1403 completeHomeModuleOrFile=completeNone
1404 completeBkpt = completeNone
1407 -- ---------------------------------------------------------------------------
1408 -- User code exception handling
1410 -- This is the exception handler for exceptions generated by the
1411 -- user's code and exceptions coming from children sessions;
1412 -- it normally just prints out the exception. The
1413 -- handler must be recursive, in case showing the exception causes
1414 -- more exceptions to be raised.
1416 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1417 -- raising another exception. We therefore don't put the recursive
1418 -- handler arond the flushing operation, so if stderr is closed
1419 -- GHCi will just die gracefully rather than going into an infinite loop.
1420 handler :: Exception -> GHCi Bool
1422 handler exception = do
1424 io installSignalHandlers
1425 ghciHandle handler (showException exception >> return False)
1427 showException (DynException dyn) =
1428 case fromDynamic dyn of
1429 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1430 Just Interrupted -> io (putStrLn "Interrupted.")
1431 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1432 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1433 Just other_ghc_ex -> io (print other_ghc_ex)
1435 showException other_exception
1436 = io (putStrLn ("*** Exception: " ++ show other_exception))
1438 -----------------------------------------------------------------------------
1439 -- recursive exception handlers
1441 -- Don't forget to unblock async exceptions in the handler, or if we're
1442 -- in an exception loop (eg. let a = error a in a) the ^C exception
1443 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1445 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1446 ghciHandle h (GHCi m) = GHCi $ \s ->
1447 Exception.catch (m s)
1448 (\e -> unGHCi (ghciUnblock (h e)) s)
1450 ghciUnblock :: GHCi a -> GHCi a
1451 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1454 -- ----------------------------------------------------------------------------
1457 expandPath :: String -> GHCi String
1459 case dropWhile isSpace path of
1461 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1462 return (tilde ++ '/':d)
1466 wantInterpretedModule :: String -> GHCi Module
1467 wantInterpretedModule str = do
1468 session <- getSession
1469 modl <- lookupModule str
1470 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1471 when (not is_interpreted) $
1472 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1475 wantNameFromInterpretedModule noCanDo str and_then = do
1476 session <- getSession
1477 names <- io $ GHC.parseName session str
1481 let modl = GHC.nameModule n
1482 if not (GHC.isExternalName n)
1483 then noCanDo n $ ppr n <>
1484 text " is not defined in an interpreted module"
1486 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1487 if not is_interpreted
1488 then noCanDo n $ text "module " <> ppr modl <>
1489 text " is not interpreted"
1492 -- ----------------------------------------------------------------------------
1493 -- Windows console setup
1495 setUpConsole :: IO ()
1497 #ifdef mingw32_HOST_OS
1498 -- On Windows we need to set a known code page, otherwise the characters
1499 -- we read from the console will be be in some strange encoding, and
1500 -- similarly for characters we write to the console.
1502 -- At the moment, GHCi pretends all input is Latin-1. In the
1503 -- future we should support UTF-8, but for now we set the code pages
1506 -- It seems you have to set the font in the console window to
1507 -- a Unicode font in order for output to work properly,
1508 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1509 -- (see MSDN for SetConsoleOutputCP()).
1511 setConsoleCP 28591 -- ISO Latin-1
1512 setConsoleOutputCP 28591 -- ISO Latin-1
1516 -- -----------------------------------------------------------------------------
1517 -- commands for debugger
1519 sprintCmd = pprintCommand False False
1520 printCmd = pprintCommand True False
1521 forceCmd = pprintCommand False True
1523 pprintCommand bind force str = do
1524 session <- getSession
1525 io $ pprintClosureCommand session bind force str
1527 stepCmd :: String -> GHCi ()
1528 stepCmd [] = doContinue GHC.SingleStep
1529 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1531 traceCmd :: String -> GHCi ()
1532 traceCmd [] = doContinue GHC.RunAndLogSteps
1533 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1535 continueCmd :: String -> GHCi ()
1536 continueCmd = noArgs $ doContinue GHC.RunToCompletion
1538 doContinue :: SingleStep -> GHCi ()
1539 doContinue step = do
1540 session <- getSession
1541 runResult <- io $ GHC.resume session step
1542 afterRunStmt runResult
1545 abandonCmd :: String -> GHCi ()
1546 abandonCmd = noArgs $ do
1548 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1549 when (not b) $ io $ putStrLn "There is no computation running."
1552 deleteCmd :: String -> GHCi ()
1553 deleteCmd argLine = do
1554 deleteSwitch $ words argLine
1556 deleteSwitch :: [String] -> GHCi ()
1558 io $ putStrLn "The delete command requires at least one argument."
1559 -- delete all break points
1560 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1561 deleteSwitch idents = do
1562 mapM_ deleteOneBreak idents
1564 deleteOneBreak :: String -> GHCi ()
1566 | all isDigit str = deleteBreak (read str)
1567 | otherwise = return ()
1569 historyCmd :: String -> GHCi ()
1571 | null arg = history 20
1572 | all isDigit arg = history (read arg)
1573 | otherwise = io $ putStrLn "Syntax: :history [num]"
1577 resumes <- io $ GHC.getResumeContext s
1579 [] -> io $ putStrLn "Not stopped at a breakpoint"
1581 let hist = GHC.resumeHistory r
1582 (took,rest) = splitAt num hist
1583 spans <- mapM (io . GHC.getHistorySpan s) took
1584 let nums = map (printf "-%-3d:") [(1::Int)..]
1585 printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans)))
1586 io $ putStrLn $ if null rest then "<end of history>" else "..."
1588 backCmd :: String -> GHCi ()
1589 backCmd = noArgs $ do
1591 (names, ix, span) <- io $ GHC.back s
1592 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1593 printTypeOfNames s names
1594 -- run the command set with ":set stop <cmd>"
1596 enqueueCommands [stop st]
1598 forwardCmd :: String -> GHCi ()
1599 forwardCmd = noArgs $ do
1601 (names, ix, span) <- io $ GHC.forward s
1602 printForUser $ (if (ix == 0)
1603 then ptext SLIT("Stopped at")
1604 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1605 printTypeOfNames s names
1606 -- run the command set with ":set stop <cmd>"
1608 enqueueCommands [stop st]
1610 -- handle the "break" command
1611 breakCmd :: String -> GHCi ()
1612 breakCmd argLine = do
1613 session <- getSession
1614 breakSwitch session $ words argLine
1616 breakSwitch :: Session -> [String] -> GHCi ()
1617 breakSwitch _session [] = do
1618 io $ putStrLn "The break command requires at least one argument."
1619 breakSwitch session args@(arg1:rest)
1620 | looksLikeModuleName arg1 = do
1621 mod <- wantInterpretedModule arg1
1622 breakByModule session mod rest
1623 | all isDigit arg1 = do
1624 (toplevel, _) <- io $ GHC.getContext session
1626 (mod : _) -> breakByModuleLine mod (read arg1) rest
1628 io $ putStrLn "Cannot find default module for breakpoint."
1629 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1630 | otherwise = do -- try parsing it as an identifier
1631 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1632 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1633 if GHC.isGoodSrcLoc loc
1634 then findBreakAndSet (GHC.nameModule name) $
1635 findBreakByCoord (Just (GHC.srcLocFile loc))
1636 (GHC.srcLocLine loc,
1638 else noCanDo name $ text "can't find its location: " <> ppr loc
1640 noCanDo n why = printForUser $
1641 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1643 breakByModule :: Session -> Module -> [String] -> GHCi ()
1644 breakByModule session mod args@(arg1:rest)
1645 | all isDigit arg1 = do -- looks like a line number
1646 breakByModuleLine mod (read arg1) rest
1647 breakByModule session mod _
1650 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1651 breakByModuleLine mod line args
1652 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1653 | [col] <- args, all isDigit col =
1654 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1655 | otherwise = breakSyntax
1657 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1659 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1660 findBreakAndSet mod lookupTickTree = do
1661 tickArray <- getTickArray mod
1662 (breakArray, _) <- getModBreak mod
1663 case lookupTickTree tickArray of
1664 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1665 Just (tick, span) -> do
1666 success <- io $ setBreakFlag True breakArray tick
1667 session <- getSession
1671 recordBreak $ BreakLocation
1678 text "Breakpoint " <> ppr nm <>
1680 then text " was already set at " <> ppr span
1681 else text " activated at " <> ppr span
1683 printForUser $ text "Breakpoint could not be activated at"
1686 -- When a line number is specified, the current policy for choosing
1687 -- the best breakpoint is this:
1688 -- - the leftmost complete subexpression on the specified line, or
1689 -- - the leftmost subexpression starting on the specified line, or
1690 -- - the rightmost subexpression enclosing the specified line
1692 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1693 findBreakByLine line arr
1694 | not (inRange (bounds arr) line) = Nothing
1696 listToMaybe (sortBy leftmost_largest complete) `mplus`
1697 listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1698 listToMaybe (sortBy rightmost ticks)
1702 starts_here = [ tick | tick@(nm,span) <- ticks,
1703 GHC.srcSpanStartLine span == line ]
1705 (complete,incomplete) = partition ends_here starts_here
1706 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1708 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1709 -> Maybe (BreakIndex,SrcSpan)
1710 findBreakByCoord mb_file (line, col) arr
1711 | not (inRange (bounds arr) line) = Nothing
1713 listToMaybe (sortBy rightmost contains) `mplus`
1714 listToMaybe (sortBy leftmost_smallest after_here)
1718 -- the ticks that span this coordinate
1719 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1720 is_correct_file span ]
1722 is_correct_file span
1723 | Just f <- mb_file = GHC.srcSpanFile span == f
1726 after_here = [ tick | tick@(nm,span) <- ticks,
1727 GHC.srcSpanStartLine span == line,
1728 GHC.srcSpanStartCol span >= col ]
1731 leftmost_smallest (_,a) (_,b) = a `compare` b
1732 leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1734 (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1735 rightmost (_,a) (_,b) = b `compare` a
1737 spans :: SrcSpan -> (Int,Int) -> Bool
1738 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1739 where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1741 -- for now, use ANSI bold on Unixy systems. On Windows, we add a line
1742 -- of carets under the active expression instead. The Windows console
1743 -- doesn't support ANSI escape sequences, and most Unix terminals
1744 -- (including xterm) do, so this is a reasonable guess until we have a
1745 -- proper termcap/terminfo library.
1746 #if !defined(mingw32_TARGET_OS)
1752 start_bold = BS.pack "\ESC[1m"
1753 end_bold = BS.pack "\ESC[0m"
1755 listCmd :: String -> GHCi ()
1757 mb_span <- getCurrentBreakSpan
1759 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1760 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1761 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
1762 listCmd str = list2 (words str)
1764 list2 [arg] | all isDigit arg = do
1765 session <- getSession
1766 (toplevel, _) <- io $ GHC.getContext session
1768 [] -> io $ putStrLn "No module to list"
1769 (mod : _) -> listModuleLine mod (read arg)
1770 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1771 mod <- wantInterpretedModule arg1
1772 listModuleLine mod (read arg2)
1774 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1775 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1776 if GHC.isGoodSrcLoc loc
1778 tickArray <- getTickArray (GHC.nameModule name)
1779 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1780 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1783 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1784 Just (_,span) -> io $ listAround span False
1786 noCanDo name $ text "can't find its location: " <>
1789 noCanDo n why = printForUser $
1790 text "cannot list source code for " <> ppr n <> text ": " <> why
1792 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1794 listModuleLine :: Module -> Int -> GHCi ()
1795 listModuleLine modl line = do
1796 session <- getSession
1797 graph <- io (GHC.getModuleGraph session)
1798 let this = filter ((== modl) . GHC.ms_mod) graph
1800 [] -> panic "listModuleLine"
1802 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1803 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1804 io $ listAround (GHC.srcLocSpan loc) False
1806 -- | list a section of a source file around a particular SrcSpan.
1807 -- If the highlight flag is True, also highlight the span using
1808 -- start_bold/end_bold.
1809 listAround span do_highlight = do
1810 contents <- BS.readFile (unpackFS file)
1812 lines = BS.split '\n' contents
1813 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1814 drop (line1 - 1 - pad_before) $ lines
1815 fst_line = max 1 (line1 - pad_before)
1816 line_nos = [ fst_line .. ]
1818 highlighted | do_highlight = zipWith highlight line_nos these_lines
1819 | otherwise = these_lines
1821 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1822 prefixed = zipWith BS.append bs_line_nos highlighted
1824 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1826 file = GHC.srcSpanFile span
1827 line1 = GHC.srcSpanStartLine span
1828 col1 = GHC.srcSpanStartCol span
1829 line2 = GHC.srcSpanEndLine span
1830 col2 = GHC.srcSpanEndCol span
1832 pad_before | line1 == 1 = 0
1836 highlight | do_bold = highlight_bold
1837 | otherwise = highlight_carets
1839 highlight_bold no line
1840 | no == line1 && no == line2
1841 = let (a,r) = BS.splitAt col1 line
1842 (b,c) = BS.splitAt (col2-col1) r
1844 BS.concat [a,start_bold,b,end_bold,c]
1846 = let (a,b) = BS.splitAt col1 line in
1847 BS.concat [a, start_bold, b]
1849 = let (a,b) = BS.splitAt col2 line in
1850 BS.concat [a, end_bold, b]
1853 highlight_carets no line
1854 | no == line1 && no == line2
1855 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1856 BS.replicate (col2-col1) '^']
1858 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1859 BS.replicate (BS.length line-col1) '^']
1861 = BS.concat [line, nl, indent, BS.replicate col2 '^']
1864 indent = BS.pack " "
1865 nl = BS.singleton '\n'
1867 -- --------------------------------------------------------------------------
1870 getTickArray :: Module -> GHCi TickArray
1871 getTickArray modl = do
1873 let arrmap = tickarrays st
1874 case lookupModuleEnv arrmap modl of
1875 Just arr -> return arr
1877 (breakArray, ticks) <- getModBreak modl
1878 let arr = mkTickArray (assocs ticks)
1879 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1882 discardTickArrays :: GHCi ()
1883 discardTickArrays = do
1885 setGHCiState st{tickarrays = emptyModuleEnv}
1887 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1889 = accumArray (flip (:)) [] (1, max_line)
1890 [ (line, (nm,span)) | (nm,span) <- ticks,
1891 line <- srcSpanLines span ]
1893 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1894 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1895 GHC.srcSpanEndLine span ]
1897 lookupModule :: String -> GHCi Module
1898 lookupModule modName
1899 = do session <- getSession
1900 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1902 -- don't reset the counter back to zero?
1903 discardActiveBreakPoints :: GHCi ()
1904 discardActiveBreakPoints = do
1906 mapM (turnOffBreak.snd) (breaks st)
1907 setGHCiState $ st { breaks = [] }
1909 deleteBreak :: Int -> GHCi ()
1910 deleteBreak identity = do
1912 let oldLocations = breaks st
1913 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
1915 then printForUser (text "Breakpoint" <+> ppr identity <+>
1916 text "does not exist")
1918 mapM (turnOffBreak.snd) this
1919 setGHCiState $ st { breaks = rest }
1921 turnOffBreak loc = do
1922 (arr, _) <- getModBreak (breakModule loc)
1923 io $ setBreakFlag False arr (breakTick loc)
1925 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1926 getModBreak mod = do
1927 session <- getSession
1928 Just mod_info <- io $ GHC.getModuleInfo session mod
1929 let modBreaks = GHC.modInfoModBreaks mod_info
1930 let array = GHC.modBreaks_flags modBreaks
1931 let ticks = GHC.modBreaks_locs modBreaks
1932 return (array, ticks)
1934 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1935 setBreakFlag toggle array index
1936 | toggle = GHC.setBreakOn array index
1937 | otherwise = GHC.setBreakOff array index