1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005-2006
8 -----------------------------------------------------------------------------
9 module InteractiveUI ( interactiveUI ) where
11 #include "HsVersions.h"
19 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
20 Type, Module, ModuleName, TyThing(..), Phase,
21 BreakIndex, SrcSpan, Resume, SingleStep )
27 import Outputable hiding (printForUser)
28 import Module -- for ModuleEnv
31 -- Other random utilities
33 import BasicTypes hiding (isTopLevel)
34 import Panic hiding (showException)
41 #ifndef mingw32_HOST_OS
42 import System.Posix hiding (getEnv)
44 import GHC.ConsoleHandler ( flushConsole )
45 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
46 import qualified System.Win32
50 import Control.Concurrent ( yield ) -- Used in readline loop
51 import System.Console.Readline as Readline
56 import Control.Exception as Exception
57 -- import Control.Concurrent
59 import qualified Data.ByteString.Char8 as BS
63 import System.Environment
64 import System.Exit ( exitWith, ExitCode(..) )
65 import System.Directory
67 import System.IO.Error as IO
71 import Control.Monad as Monad
74 import Foreign.StablePtr ( newStablePtr )
75 import GHC.Exts ( unsafeCoerce# )
76 import GHC.IOBase ( IOErrorType(InvalidArgument) )
78 import Data.IORef ( IORef, readIORef, writeIORef )
80 import System.Posix.Internals ( setNonBlockingFD )
82 -----------------------------------------------------------------------------
86 " / _ \\ /\\ /\\/ __(_)\n"++
87 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
88 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
89 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
92 "GHCi, version " ++ cProjectVersion ++
93 ": http://www.haskell.org/ghc/ :? for help"
95 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
98 GLOBAL_VAR(commands, builtin_commands, [Command])
100 builtin_commands :: [Command]
102 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
103 ("?", keepGoing help, False, completeNone),
104 ("add", keepGoingPaths addModule, False, completeFilename),
105 ("abandon", keepGoing abandonCmd, False, completeNone),
106 ("break", keepGoing breakCmd, False, completeIdentifier),
107 ("back", keepGoing backCmd, False, completeNone),
108 ("browse", keepGoing browseCmd, False, completeModule),
109 ("cd", keepGoing changeDirectory, False, completeFilename),
110 ("check", keepGoing checkModule, False, completeHomeModule),
111 ("continue", keepGoing continueCmd, False, completeNone),
112 ("cmd", keepGoing cmdCmd, False, completeIdentifier),
113 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
114 ("def", keepGoing defineMacro, False, completeIdentifier),
115 ("delete", keepGoing deleteCmd, False, completeNone),
116 ("e", keepGoing editFile, False, completeFilename),
117 ("edit", keepGoing editFile, False, completeFilename),
118 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
119 ("force", keepGoing forceCmd, False, completeIdentifier),
120 ("forward", keepGoing forwardCmd, False, completeNone),
121 ("help", keepGoing help, False, completeNone),
122 ("history", keepGoing historyCmd, False, completeNone),
123 ("info", keepGoing info, False, completeIdentifier),
124 ("kind", keepGoing kindOfType, False, completeIdentifier),
125 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
126 ("list", keepGoing listCmd, False, completeNone),
127 ("module", keepGoing setContext, False, completeModule),
128 ("main", keepGoing runMain, False, completeIdentifier),
129 ("print", keepGoing printCmd, False, completeIdentifier),
130 ("quit", quit, False, completeNone),
131 ("reload", keepGoing reloadModule, False, completeNone),
132 ("set", keepGoing setCmd, True, completeSetOptions),
133 ("show", keepGoing showCmd, False, completeNone),
134 ("sprint", keepGoing sprintCmd, False, completeIdentifier),
135 ("step", keepGoing stepCmd, False, completeIdentifier),
136 ("type", keepGoing typeOfExpr, False, completeIdentifier),
137 ("trace", keepGoing traceCmd, False, completeIdentifier),
138 ("undef", keepGoing undefineMacro, False, completeMacro),
139 ("unset", keepGoing unsetOptions, True, completeSetOptions)
142 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
143 keepGoing a str = a str >> return False
145 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
146 keepGoingPaths a str = a (toArgs str) >> return False
148 shortHelpText = "use :? for help.\n"
151 " Commands available from the prompt:\n" ++
153 " <statement> evaluate/run <statement>\n" ++
154 " :add <filename> ... add module(s) to the current target set\n" ++
155 " :browse [*]<module> display the names defined by <module>\n" ++
156 " :cd <dir> change directory to <dir>\n" ++
157 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
158 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
159 " :def <cmd> <expr> define a command :<cmd>\n" ++
160 " :edit <file> edit file\n" ++
161 " :edit edit last module\n" ++
162 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
163 " :help, :? display this list of commands\n" ++
164 " :info [<name> ...] display information about the given names\n" ++
165 " :kind <type> show the kind of <type>\n" ++
166 " :load <filename> ... load module(s) and their dependents\n" ++
167 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
168 " :main [<arguments> ...] run the main function with the given arguments\n" ++
169 " :quit exit GHCi\n" ++
170 " :reload reload the current module set\n" ++
171 " :type <expr> show the type of <expr>\n" ++
172 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
173 " :!<command> run the shell command <command>\n" ++
175 " -- Commands for debugging:\n" ++
177 " :abandon at a breakpoint, abandon current computation\n" ++
178 " :back go back in the history (after :trace)\n" ++
179 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
180 " :break <name> set a breakpoint on the specified function\n" ++
181 " :continue resume after a breakpoint\n" ++
182 " :delete <number> delete the specified breakpoint\n" ++
183 " :delete * delete all breakpoints\n" ++
184 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
185 " :forward go forward in the history (after :back)\n" ++
186 " :history [<n>] show the last <n> items in the history (after :trace)\n" ++
187 " :print [<name> ...] prints a value without forcing its computation\n" ++
188 " :sprint [<name> ...] simplifed version of :print\n" ++
189 " :step single-step after stopping at a breakpoint\n"++
190 " :step <expr> single-step into <expr>\n"++
191 " :trace trace after stopping at a breakpoint\n"++
192 " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
195 " -- Commands for changing settings:\n" ++
197 " :set <option> ... set options\n" ++
198 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
199 " :set prog <progname> set the value returned by System.getProgName\n" ++
200 " :set prompt <prompt> set the prompt used in GHCi\n" ++
201 " :set editor <cmd> set the command used for :edit\n" ++
202 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
203 " :unset <option> ... unset options\n" ++
205 " Options for ':set' and ':unset':\n" ++
207 " +r revert top-level expressions after each evaluation\n" ++
208 " +s print timing/memory stats after each evaluation\n" ++
209 " +t print type after evaluation\n" ++
210 " -<flags> most GHC command line flags can also be set here\n" ++
211 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
213 " -- Commands for displaying information:\n" ++
215 " :show bindings show the current bindings made at the prompt\n" ++
216 " :show breaks show the active breakpoints\n" ++
217 " :show context show the breakpoint context\n" ++
218 " :show modules show the currently loaded modules\n" ++
219 " :show <setting> show anything that can be set with :set (e.g. args)\n" ++
226 win <- System.Win32.getWindowsDirectory
227 return (win `joinFileName` "notepad.exe")
232 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
233 interactiveUI session srcs maybe_expr = do
234 -- HACK! If we happen to get into an infinite loop (eg the user
235 -- types 'let x=x in x' at the prompt), then the thread will block
236 -- on a blackhole, and become unreachable during GC. The GC will
237 -- detect that it is unreachable and send it the NonTermination
238 -- exception. However, since the thread is unreachable, everything
239 -- it refers to might be finalized, including the standard Handles.
240 -- This sounds like a bug, but we don't have a good solution right
246 -- Initialise buffering for the *interpreted* I/O system
247 initInterpBuffering session
249 when (isNothing maybe_expr) $ do
250 -- Only for GHCi (not runghc and ghc -e):
252 -- Turn buffering off for the compiled program's stdout/stderr
254 -- Turn buffering off for GHCi's stdout
256 hSetBuffering stdout NoBuffering
257 -- We don't want the cmd line to buffer any input that might be
258 -- intended for the program, so unbuffer stdin.
259 hSetBuffering stdin NoBuffering
261 -- initial context is just the Prelude
262 prel_mod <- GHC.findModule session prel_name (Just basePackageId)
263 GHC.setContext session [] [prel_mod]
267 Readline.setAttemptedCompletionFunction (Just completeWord)
268 --Readline.parseAndBind "set show-all-if-ambiguous 1"
270 let symbols = "!#$%&*+/<=>?@\\^|-~"
271 specials = "(),;[]`{}"
273 word_break_chars = spaces ++ specials ++ symbols
275 Readline.setBasicWordBreakCharacters word_break_chars
276 Readline.setCompleterWordBreakCharacters word_break_chars
279 default_editor <- findEditor
281 startGHCi (runGHCi srcs maybe_expr)
282 GHCiState{ progname = "<interactive>",
286 editor = default_editor,
292 tickarrays = emptyModuleEnv,
297 Readline.resetTerminal Nothing
302 prel_name = GHC.mkModuleName "Prelude"
304 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
305 runGHCi paths maybe_expr = do
306 let read_dot_files = not opt_IgnoreDotGhci
308 when (read_dot_files) $ do
311 exists <- io (doesFileExist file)
313 dir_ok <- io (checkPerms ".")
314 file_ok <- io (checkPerms file)
315 when (dir_ok && file_ok) $ do
316 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
319 Right hdl -> fileLoop hdl False
321 when (read_dot_files) $ do
322 -- Read in $HOME/.ghci
323 either_dir <- io (IO.try (getEnv "HOME"))
327 cwd <- io (getCurrentDirectory)
328 when (dir /= cwd) $ do
329 let file = dir ++ "/.ghci"
330 ok <- io (checkPerms file)
332 either_hdl <- io (IO.try (openFile file ReadMode))
335 Right hdl -> fileLoop hdl False
337 -- Perform a :load for files given on the GHCi command line
338 -- When in -e mode, if the load fails then we want to stop
339 -- immediately rather than going on to evaluate the expression.
340 when (not (null paths)) $ do
341 ok <- ghciHandle (\e -> do showException e; return Failed) $
343 when (isJust maybe_expr && failed ok) $
344 io (exitWith (ExitFailure 1))
346 -- if verbosity is greater than 0, or we are connected to a
347 -- terminal, display the prompt in the interactive loop.
348 is_tty <- io (hIsTerminalDevice stdin)
349 dflags <- getDynFlags
350 let show_prompt = verbosity dflags > 0 || is_tty
355 #if defined(mingw32_HOST_OS)
356 -- The win32 Console API mutates the first character of
357 -- type-ahead when reading from it in a non-buffered manner. Work
358 -- around this by flushing the input buffer of type-ahead characters,
359 -- but only if stdin is available.
360 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
362 Left err | isDoesNotExistError err -> return ()
363 | otherwise -> io (ioError err)
364 Right () -> return ()
366 -- initialise the console if necessary
369 let msg = if dopt Opt_ShortGhciBanner dflags
370 then ghciShortWelcomeMsg
372 when (verbosity dflags >= 1) $ io $ putStrLn msg
374 -- enter the interactive loop
375 interactiveLoop is_tty show_prompt
377 -- just evaluate the expression we were given
382 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
385 interactiveLoop is_tty show_prompt =
386 -- Ignore ^C exceptions caught here
387 ghciHandleDyn (\e -> case e of
389 #if defined(mingw32_HOST_OS)
392 interactiveLoop is_tty show_prompt
393 _other -> return ()) $
395 ghciUnblock $ do -- unblock necessary if we recursed from the
396 -- exception handler above.
398 -- read commands from stdin
402 else fileLoop stdin show_prompt
404 fileLoop stdin show_prompt
408 -- NOTE: We only read .ghci files if they are owned by the current user,
409 -- and aren't world writable. Otherwise, we could be accidentally
410 -- running code planted by a malicious third party.
412 -- Furthermore, We only read ./.ghci if . is owned by the current user
413 -- and isn't writable by anyone else. I think this is sufficient: we
414 -- don't need to check .. and ../.. etc. because "." always refers to
415 -- the same directory while a process is running.
417 checkPerms :: String -> IO Bool
419 #ifdef mingw32_HOST_OS
422 Util.handle (\_ -> return False) $ do
423 st <- getFileStatus name
425 if fileOwner st /= me then do
426 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
429 let mode = fileMode st
430 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
431 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
433 putStrLn $ "*** WARNING: " ++ name ++
434 " is writable by someone else, IGNORING!"
439 fileLoop :: Handle -> Bool -> GHCi ()
440 fileLoop hdl show_prompt = do
441 when show_prompt $ do
444 l <- io (IO.try (hGetLine hdl))
446 Left e | isEOFError e -> return ()
447 | InvalidArgument <- etype -> return ()
448 | otherwise -> io (ioError e)
449 where etype = ioeGetErrorType e
450 -- treat InvalidArgument in the same way as EOF:
451 -- this can happen if the user closed stdin, or
452 -- perhaps did getContents which closes stdin at
455 case removeSpaces l of
456 "" -> fileLoop hdl show_prompt
457 l -> do quit <- runCommands l
458 if quit then return () else fileLoop hdl show_prompt
461 session <- getSession
462 (toplevs,exports) <- io (GHC.getContext session)
463 resumes <- io $ GHC.getResumeContext session
469 let ix = GHC.resumeHistoryIx r
471 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
473 let hist = GHC.resumeHistory r !! (ix-1)
474 span <- io $ GHC.getHistorySpan session hist
475 return (brackets (ppr (negate ix) <> char ':'
476 <+> ppr span) <> space)
478 dots | r:rs <- resumes, not (null rs) = text "... "
482 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
483 hsep (map (ppr . GHC.moduleName) exports)
485 deflt_prompt = dots <> context_bit <> modules_bit
487 f ('%':'s':xs) = deflt_prompt <> f xs
488 f ('%':'%':xs) = char '%' <> f xs
489 f (x:xs) = char x <> f xs
493 return (showSDoc (f (prompt st)))
497 readlineLoop :: GHCi ()
499 session <- getSession
500 (mod,imports) <- io (GHC.getContext session)
502 saveSession -- for use by completion
504 mb_span <- getCurrentBreakSpan
506 l <- io (readline prompt `finally` setNonBlockingFD 0)
507 -- readline sometimes puts stdin into blocking mode,
508 -- so we need to put it back for the IO library
513 case removeSpaces l of
517 quit <- runCommands l
518 if quit then return () else readlineLoop
521 runCommands :: String -> GHCi Bool
523 q <- ghciHandle handler (doCommand cmd)
524 if q then return True else runNext
530 c:cs -> do setGHCiState st{ cmdqueue = cs }
533 doCommand (':' : cmd) = specialCommand cmd
534 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
537 enqueueCommands :: [String] -> GHCi ()
538 enqueueCommands cmds = do
540 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
543 -- This version is for the GHC command-line option -e. The only difference
544 -- from runCommand is that it catches the ExitException exception and
545 -- exits, rather than printing out the exception.
546 runCommandEval c = ghciHandle handleEval (doCommand c)
548 handleEval (ExitException code) = io (exitWith code)
549 handleEval e = do handler e
550 io (exitWith (ExitFailure 1))
552 doCommand (':' : command) = specialCommand command
554 = do r <- runStmt stmt GHC.RunToCompletion
556 False -> io (exitWith (ExitFailure 1))
557 -- failure to run the command causes exit(1) for ghc -e.
560 runStmt :: String -> SingleStep -> GHCi Bool
562 | null (filter (not.isSpace) stmt) = return False
563 | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
565 = do st <- getGHCiState
566 session <- getSession
567 result <- io $ withProgName (progname st) $ withArgs (args st) $
568 GHC.runStmt session stmt step
572 afterRunStmt :: GHC.RunResult -> GHCi Bool
573 -- False <=> the statement failed to compile
574 afterRunStmt (GHC.RunException e) = throw e
575 afterRunStmt run_result = do
576 session <- getSession
578 GHC.RunOk names -> do
579 show_types <- isOptionSet ShowType
580 when show_types $ printTypeOfNames session names
581 GHC.RunBreak _ names mb_info -> do
582 resumes <- io $ GHC.getResumeContext session
583 printForUser $ ptext SLIT("Stopped at") <+>
584 ppr (GHC.resumeSpan (head resumes))
585 printTypeOfNames session names
586 maybe (return ()) runBreakCmd mb_info
587 -- run the command set with ":set stop <cmd>"
589 enqueueCommands [stop st]
594 io installSignalHandlers
595 b <- isOptionSet RevertCAFs
596 io (when b revertCAFs)
598 return (case run_result of GHC.RunOk _ -> True; _ -> False)
600 runBreakCmd :: GHC.BreakInfo -> GHCi ()
601 runBreakCmd info = do
602 let mod = GHC.breakInfo_module info
603 nm = GHC.breakInfo_number info
605 case [ loc | (i,loc) <- breaks st,
606 breakModule loc == mod, breakTick loc == nm ] of
608 loc:_ | null cmd -> return ()
609 | otherwise -> do enqueueCommands [cmd]; return ()
610 where cmd = onBreakCmd loc
612 printTypeOfNames :: Session -> [Name] -> GHCi ()
613 printTypeOfNames session names
614 = mapM_ (printTypeOfName session) $ sortBy compareNames names
616 compareNames :: Name -> Name -> Ordering
617 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
618 where compareWith n = (getOccString n, getSrcSpan n)
620 printTypeOfName :: Session -> Name -> GHCi ()
621 printTypeOfName session n
622 = do maybe_tything <- io (GHC.lookupName session n)
623 case maybe_tything of
625 Just thing -> printTyThing thing
627 specialCommand :: String -> GHCi Bool
628 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
629 specialCommand str = do
630 let (cmd,rest) = break isSpace str
631 maybe_cmd <- io (lookupCommand cmd)
633 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
634 ++ shortHelpText) >> return False)
635 Just (_,f,_,_) -> f (dropWhile isSpace rest)
637 lookupCommand :: String -> IO (Maybe Command)
638 lookupCommand str = do
639 cmds <- readIORef commands
640 -- look for exact match first, then the first prefix match
641 case [ c | c <- cmds, str == cmdName c ] of
642 c:_ -> return (Just c)
643 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
645 c:_ -> return (Just c)
648 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
649 getCurrentBreakSpan = do
650 session <- getSession
651 resumes <- io $ GHC.getResumeContext session
655 let ix = GHC.resumeHistoryIx r
657 then return (Just (GHC.resumeSpan r))
659 let hist = GHC.resumeHistory r !! (ix-1)
660 span <- io $ GHC.getHistorySpan session hist
663 -----------------------------------------------------------------------------
666 noArgs :: GHCi () -> String -> GHCi ()
668 noArgs m _ = io $ putStrLn "This command takes no arguments"
670 help :: String -> GHCi ()
671 help _ = io (putStr helpText)
673 info :: String -> GHCi ()
674 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
675 info s = do { let names = words s
676 ; session <- getSession
677 ; dflags <- getDynFlags
678 ; let exts = dopt Opt_GlasgowExts dflags
679 ; mapM_ (infoThing exts session) names }
681 infoThing exts session str = io $ do
682 names <- GHC.parseName session str
683 let filtered = filterOutChildren names
684 mb_stuffs <- mapM (GHC.getInfo session) filtered
685 unqual <- GHC.getPrintUnqual session
686 putStrLn (showSDocForUser unqual $
687 vcat (intersperse (text "") $
688 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
690 -- Filter out names whose parent is also there Good
691 -- example is '[]', which is both a type and data
692 -- constructor in the same type
693 filterOutChildren :: [Name] -> [Name]
694 filterOutChildren names = filter (not . parent_is_there) names
695 where parent_is_there n
696 -- | Just p <- GHC.nameParent_maybe n = p `elem` names
700 pprInfo exts (thing, fixity, insts)
701 = pprTyThingInContextLoc exts thing
702 $$ show_fixity fixity
703 $$ vcat (map GHC.pprInstance insts)
706 | fix == GHC.defaultFixity = empty
707 | otherwise = ppr fix <+> ppr (GHC.getName thing)
709 runMain :: String -> GHCi ()
711 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
712 enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
714 addModule :: [FilePath] -> GHCi ()
716 io (revertCAFs) -- always revert CAFs on load/add.
717 files <- mapM expandPath files
718 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
719 session <- getSession
720 io (mapM_ (GHC.addTarget session) targets)
721 ok <- io (GHC.load session LoadAllTargets)
724 changeDirectory :: String -> GHCi ()
725 changeDirectory dir = do
726 session <- getSession
727 graph <- io (GHC.getModuleGraph session)
728 when (not (null graph)) $
729 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
730 io (GHC.setTargets session [])
731 io (GHC.load session LoadAllTargets)
732 setContextAfterLoad session []
733 io (GHC.workingDirectoryChanged session)
734 dir <- expandPath dir
735 io (setCurrentDirectory dir)
737 editFile :: String -> GHCi ()
739 do file <- if null str then chooseEditFile else return str
743 $ throwDyn (CmdLineError "editor not set, use :set editor")
744 io $ system (cmd ++ ' ':file)
747 -- The user didn't specify a file so we pick one for them.
748 -- Our strategy is to pick the first module that failed to load,
749 -- or otherwise the first target.
751 -- XXX: Can we figure out what happened if the depndecy analysis fails
752 -- (e.g., because the porgrammeer mistyped the name of a module)?
753 -- XXX: Can we figure out the location of an error to pass to the editor?
754 -- XXX: if we could figure out the list of errors that occured during the
755 -- last load/reaload, then we could start the editor focused on the first
757 chooseEditFile :: GHCi String
759 do session <- getSession
760 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
762 graph <- io (GHC.getModuleGraph session)
763 failed_graph <- filterM hasFailed graph
764 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
766 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
769 case pick (order failed_graph) of
770 Just file -> return file
772 do targets <- io (GHC.getTargets session)
773 case msum (map fromTarget targets) of
774 Just file -> return file
775 Nothing -> throwDyn (CmdLineError "No files to edit.")
777 where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
778 fromTarget _ = Nothing -- when would we get a module target?
780 defineMacro :: String -> GHCi ()
782 let (macro_name, definition) = break isSpace s
783 cmds <- io (readIORef commands)
785 then throwDyn (CmdLineError "invalid macro name")
787 if (macro_name `elem` map cmdName cmds)
788 then throwDyn (CmdLineError
789 ("command '" ++ macro_name ++ "' is already defined"))
792 -- give the expression a type signature, so we can be sure we're getting
793 -- something of the right type.
794 let new_expr = '(' : definition ++ ") :: String -> IO String"
796 -- compile the expression
798 maybe_hv <- io (GHC.compileExpr cms new_expr)
801 Just hv -> io (writeIORef commands --
802 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
804 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
806 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
807 enqueueCommands (lines str)
810 undefineMacro :: String -> GHCi ()
811 undefineMacro macro_name = do
812 cmds <- io (readIORef commands)
813 if (macro_name `elem` map cmdName builtin_commands)
814 then throwDyn (CmdLineError
815 ("command '" ++ macro_name ++ "' cannot be undefined"))
817 if (macro_name `notElem` map cmdName cmds)
818 then throwDyn (CmdLineError
819 ("command '" ++ macro_name ++ "' not defined"))
821 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
823 cmdCmd :: String -> GHCi ()
825 let expr = '(' : str ++ ") :: IO String"
826 session <- getSession
827 maybe_hv <- io (GHC.compileExpr session expr)
831 cmds <- io $ (unsafeCoerce# hv :: IO String)
832 enqueueCommands (lines cmds)
835 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
836 loadModule fs = timeIt (loadModule' fs)
838 loadModule_ :: [FilePath] -> GHCi ()
839 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
841 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
842 loadModule' files = do
843 session <- getSession
846 discardActiveBreakPoints
847 io (GHC.setTargets session [])
848 io (GHC.load session LoadAllTargets)
851 let (filenames, phases) = unzip files
852 exp_filenames <- mapM expandPath filenames
853 let files' = zip exp_filenames phases
854 targets <- io (mapM (uncurry GHC.guessTarget) files')
856 -- NOTE: we used to do the dependency anal first, so that if it
857 -- fails we didn't throw away the current set of modules. This would
858 -- require some re-working of the GHC interface, so we'll leave it
859 -- as a ToDo for now.
861 io (GHC.setTargets session targets)
862 doLoad session LoadAllTargets
864 checkModule :: String -> GHCi ()
866 let modl = GHC.mkModuleName m
867 session <- getSession
868 result <- io (GHC.checkModule session modl)
870 Nothing -> io $ putStrLn "Nothing"
871 Just r -> io $ putStrLn (showSDoc (
872 case GHC.checkedModuleInfo r of
873 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
875 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
877 (text "global names: " <+> ppr global) $$
878 (text "local names: " <+> ppr local)
880 afterLoad (successIf (isJust result)) session
882 reloadModule :: String -> GHCi ()
884 io (revertCAFs) -- always revert CAFs on reload.
885 discardActiveBreakPoints
886 session <- getSession
887 doLoad session $ if null m then LoadAllTargets
888 else LoadUpTo (GHC.mkModuleName m)
891 doLoad session howmuch = do
892 -- turn off breakpoints before we load: we can't turn them off later, because
893 -- the ModBreaks will have gone away.
894 discardActiveBreakPoints
895 ok <- io (GHC.load session howmuch)
899 afterLoad ok session = do
900 io (revertCAFs) -- always revert CAFs on load.
902 graph <- io (GHC.getModuleGraph session)
903 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
904 setContextAfterLoad session graph'
905 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
907 setContextAfterLoad session [] = do
908 prel_mod <- getPrelude
909 io (GHC.setContext session [] [prel_mod])
910 setContextAfterLoad session ms = do
911 -- load a target if one is available, otherwise load the topmost module.
912 targets <- io (GHC.getTargets session)
913 case [ m | Just m <- map (findTarget ms) targets ] of
915 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
916 load_this (last graph')
921 = case filter (`matches` t) ms of
925 summary `matches` Target (TargetModule m) _
926 = GHC.ms_mod_name summary == m
927 summary `matches` Target (TargetFile f _) _
928 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
929 summary `matches` target
932 load_this summary | m <- GHC.ms_mod summary = do
933 b <- io (GHC.moduleIsInterpreted session m)
934 if b then io (GHC.setContext session [m] [])
936 prel_mod <- getPrelude
937 io (GHC.setContext session [] [prel_mod,m])
940 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
941 modulesLoadedMsg ok mods = do
942 dflags <- getDynFlags
943 when (verbosity dflags > 0) $ do
945 | null mods = text "none."
947 punctuate comma (map ppr mods)) <> text "."
950 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
952 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
955 typeOfExpr :: String -> GHCi ()
957 = do cms <- getSession
958 maybe_ty <- io (GHC.exprType cms str)
961 Just ty -> do ty' <- cleanType ty
962 printForUser $ text str <> text " :: " <> ppr ty'
964 kindOfType :: String -> GHCi ()
966 = do cms <- getSession
967 maybe_ty <- io (GHC.typeKind cms str)
970 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
972 quit :: String -> GHCi Bool
975 shellEscape :: String -> GHCi Bool
976 shellEscape str = io (system str >> return False)
978 -----------------------------------------------------------------------------
979 -- Browsing a module's contents
981 browseCmd :: String -> GHCi ()
984 ['*':m] | looksLikeModuleName m -> browseModule m False
985 [m] | looksLikeModuleName m -> browseModule m True
986 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
988 browseModule m exports_only = do
990 modl <- if exports_only then lookupModule m
991 else wantInterpretedModule m
993 -- Temporarily set the context to the module we're interested in,
994 -- just so we can get an appropriate PrintUnqualified
995 (as,bs) <- io (GHC.getContext s)
996 prel_mod <- getPrelude
997 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
998 else GHC.setContext s [modl] [])
999 unqual <- io (GHC.getPrintUnqual s)
1000 io (GHC.setContext s as bs)
1002 mb_mod_info <- io $ GHC.getModuleInfo s modl
1004 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1007 | exports_only = GHC.modInfoExports mod_info
1008 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
1010 filtered = filterOutChildren names
1012 things <- io $ mapM (GHC.lookupName s) filtered
1014 dflags <- getDynFlags
1015 let exts = dopt Opt_GlasgowExts dflags
1016 io (putStrLn (showSDocForUser unqual (
1017 vcat (map (pprTyThingInContext exts) (catMaybes things))
1019 -- ToDo: modInfoInstances currently throws an exception for
1020 -- package modules. When it works, we can do this:
1021 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1023 -----------------------------------------------------------------------------
1024 -- Setting the module context
1027 | all sensible mods = fn mods
1028 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1030 (fn, mods) = case str of
1031 '+':stuff -> (addToContext, words stuff)
1032 '-':stuff -> (removeFromContext, words stuff)
1033 stuff -> (newContext, words stuff)
1035 sensible ('*':m) = looksLikeModuleName m
1036 sensible m = looksLikeModuleName m
1038 separate :: Session -> [String] -> [Module] -> [Module]
1039 -> GHCi ([Module],[Module])
1040 separate session [] as bs = return (as,bs)
1041 separate session (('*':str):ms) as bs = do
1042 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1043 b <- io $ GHC.moduleIsInterpreted session m
1044 if b then separate session ms (m:as) bs
1045 else throwDyn (CmdLineError ("module '"
1046 ++ GHC.moduleNameString (GHC.moduleName m)
1047 ++ "' is not interpreted"))
1048 separate session (str:ms) as bs = do
1049 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1050 separate session ms as (m:bs)
1052 newContext :: [String] -> GHCi ()
1053 newContext strs = do
1055 (as,bs) <- separate s strs [] []
1056 prel_mod <- getPrelude
1057 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1058 io $ GHC.setContext s as bs'
1061 addToContext :: [String] -> GHCi ()
1062 addToContext strs = do
1064 (as,bs) <- io $ GHC.getContext s
1066 (new_as,new_bs) <- separate s strs [] []
1068 let as_to_add = new_as \\ (as ++ bs)
1069 bs_to_add = new_bs \\ (as ++ bs)
1071 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1074 removeFromContext :: [String] -> GHCi ()
1075 removeFromContext strs = do
1077 (as,bs) <- io $ GHC.getContext s
1079 (as_to_remove,bs_to_remove) <- separate s strs [] []
1081 let as' = as \\ (as_to_remove ++ bs_to_remove)
1082 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1084 io $ GHC.setContext s as' bs'
1086 ----------------------------------------------------------------------------
1089 -- set options in the interpreter. Syntax is exactly the same as the
1090 -- ghc command line, except that certain options aren't available (-C,
1093 -- This is pretty fragile: most options won't work as expected. ToDo:
1094 -- figure out which ones & disallow them.
1096 setCmd :: String -> GHCi ()
1098 = do st <- getGHCiState
1099 let opts = options st
1100 io $ putStrLn (showSDoc (
1101 text "options currently set: " <>
1104 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1107 = case toArgs str of
1108 ("args":args) -> setArgs args
1109 ("prog":prog) -> setProg prog
1110 ("prompt":prompt) -> setPrompt (after 6)
1111 ("editor":cmd) -> setEditor (after 6)
1112 ("stop":cmd) -> setStop (after 4)
1113 wds -> setOptions wds
1114 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1118 setGHCiState st{ args = args }
1122 setGHCiState st{ progname = prog }
1124 io (hPutStrLn stderr "syntax: :set prog <progname>")
1128 setGHCiState st{ editor = cmd }
1130 setStop str@(c:_) | isDigit c
1131 = do let (nm_str,rest) = break (not.isDigit) str
1134 let old_breaks = breaks st
1135 if all ((/= nm) . fst) old_breaks
1136 then printForUser (text "Breakpoint" <+> ppr nm <+>
1137 text "does not exist")
1139 let new_breaks = map fn old_breaks
1140 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1141 | otherwise = (i,loc)
1142 setGHCiState st{ breaks = new_breaks }
1145 setGHCiState st{ stop = cmd }
1147 setPrompt value = do
1150 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1151 else setGHCiState st{ prompt = remQuotes value }
1153 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1157 do -- first, deal with the GHCi opts (+s, +t, etc.)
1158 let (plus_opts, minus_opts) = partition isPlus wds
1159 mapM_ setOpt plus_opts
1160 -- then, dynamic flags
1161 newDynFlags minus_opts
1163 newDynFlags minus_opts = do
1164 dflags <- getDynFlags
1165 let pkg_flags = packageFlags dflags
1166 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1168 if (not (null leftovers))
1169 then throwDyn (CmdLineError ("unrecognised flags: " ++
1173 new_pkgs <- setDynFlags dflags'
1175 -- if the package flags changed, we should reset the context
1176 -- and link the new packages.
1177 dflags <- getDynFlags
1178 when (packageFlags dflags /= pkg_flags) $ do
1179 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1180 session <- getSession
1181 io (GHC.setTargets session [])
1182 io (GHC.load session LoadAllTargets)
1183 io (linkPackages dflags new_pkgs)
1184 setContextAfterLoad session []
1188 unsetOptions :: String -> GHCi ()
1190 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1191 let opts = words str
1192 (minus_opts, rest1) = partition isMinus opts
1193 (plus_opts, rest2) = partition isPlus rest1
1195 if (not (null rest2))
1196 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1199 mapM_ unsetOpt plus_opts
1201 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1202 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1204 no_flags <- mapM no_flag minus_opts
1205 newDynFlags no_flags
1207 isMinus ('-':s) = True
1210 isPlus ('+':s) = True
1214 = case strToGHCiOpt str of
1215 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1216 Just o -> setOption o
1219 = case strToGHCiOpt str of
1220 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1221 Just o -> unsetOption o
1223 strToGHCiOpt :: String -> (Maybe GHCiOption)
1224 strToGHCiOpt "s" = Just ShowTiming
1225 strToGHCiOpt "t" = Just ShowType
1226 strToGHCiOpt "r" = Just RevertCAFs
1227 strToGHCiOpt _ = Nothing
1229 optToStr :: GHCiOption -> String
1230 optToStr ShowTiming = "s"
1231 optToStr ShowType = "t"
1232 optToStr RevertCAFs = "r"
1234 -- ---------------------------------------------------------------------------
1240 ["args"] -> io $ putStrLn (show (args st))
1241 ["prog"] -> io $ putStrLn (show (progname st))
1242 ["prompt"] -> io $ putStrLn (show (prompt st))
1243 ["editor"] -> io $ putStrLn (show (editor st))
1244 ["stop"] -> io $ putStrLn (show (stop st))
1245 ["modules" ] -> showModules
1246 ["bindings"] -> showBindings
1247 ["linker"] -> io showLinkerState
1248 ["breaks"] -> showBkptTable
1249 ["context"] -> showContext
1250 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1253 session <- getSession
1254 let show_one ms = do m <- io (GHC.showModule session ms)
1256 graph <- io (GHC.getModuleGraph session)
1257 mapM_ show_one graph
1261 unqual <- io (GHC.getPrintUnqual s)
1262 bindings <- io (GHC.getBindings s)
1263 mapM_ printTyThing $ sortBy compareTyThings bindings
1266 compareTyThings :: TyThing -> TyThing -> Ordering
1267 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1269 printTyThing :: TyThing -> GHCi ()
1270 printTyThing (AnId id) = do
1271 ty' <- cleanType (GHC.idType id)
1272 printForUser $ ppr id <> text " :: " <> ppr ty'
1273 printTyThing _ = return ()
1275 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1276 cleanType :: Type -> GHCi Type
1278 dflags <- getDynFlags
1279 if dopt Opt_GlasgowExts dflags
1281 else return $! GHC.dropForAlls ty
1283 showBkptTable :: GHCi ()
1286 printForUser $ prettyLocations (breaks st)
1288 showContext :: GHCi ()
1290 session <- getSession
1291 resumes <- io $ GHC.getResumeContext session
1292 printForUser $ vcat (map pp_resume (reverse resumes))
1295 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1296 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1299 -- -----------------------------------------------------------------------------
1302 completeNone :: String -> IO [String]
1303 completeNone w = return []
1306 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1307 completeWord w start end = do
1308 line <- Readline.getLineBuffer
1310 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1312 | Just c <- is_cmd line -> do
1313 maybe_cmd <- lookupCommand c
1314 let (n,w') = selectWord (words' 0 line)
1316 Nothing -> return Nothing
1317 Just (_,_,False,complete) -> wrapCompleter complete w
1318 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1319 return (map (drop n) rets)
1320 in wrapCompleter complete' w'
1322 --printf "complete %s, start = %d, end = %d\n" w start end
1323 wrapCompleter completeIdentifier w
1324 where words' _ [] = []
1325 words' n str = let (w,r) = break isSpace str
1326 (s,r') = span isSpace r
1327 in (n,w):words' (n+length w+length s) r'
1328 -- In a Haskell expression we want to parse 'a-b' as three words
1329 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1330 -- only be a single word.
1331 selectWord [] = (0,w)
1332 selectWord ((offset,x):xs)
1333 | offset+length x >= start = (start-offset,take (end-offset) x)
1334 | otherwise = selectWord xs
1337 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1338 | otherwise = Nothing
1341 cmds <- readIORef commands
1342 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1344 completeMacro w = do
1345 cmds <- readIORef commands
1346 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1347 return (filter (w `isPrefixOf`) cmds')
1349 completeIdentifier w = do
1351 rdrs <- GHC.getRdrNamesInScope s
1352 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1354 completeModule w = do
1356 dflags <- GHC.getSessionDynFlags s
1357 let pkg_mods = allExposedModules dflags
1358 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1360 completeHomeModule w = do
1362 g <- GHC.getModuleGraph s
1363 let home_mods = map GHC.ms_mod_name g
1364 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1366 completeSetOptions w = do
1367 return (filter (w `isPrefixOf`) options)
1368 where options = "args":"prog":allFlags
1370 completeFilename = Readline.filenameCompletionFunction
1372 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1374 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1375 unionComplete f1 f2 w = do
1380 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1381 wrapCompleter fun w = do
1384 [] -> return Nothing
1385 [x] -> return (Just (x,[]))
1386 xs -> case getCommonPrefix xs of
1387 "" -> return (Just ("",xs))
1388 pref -> return (Just (pref,xs))
1390 getCommonPrefix :: [String] -> String
1391 getCommonPrefix [] = ""
1392 getCommonPrefix (s:ss) = foldl common s ss
1393 where common s "" = ""
1395 common (c:cs) (d:ds)
1396 | c == d = c : common cs ds
1399 allExposedModules :: DynFlags -> [ModuleName]
1400 allExposedModules dflags
1401 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1403 pkg_db = pkgIdMap (pkgState dflags)
1405 completeCmd = completeNone
1406 completeMacro = completeNone
1407 completeIdentifier = completeNone
1408 completeModule = completeNone
1409 completeHomeModule = completeNone
1410 completeSetOptions = completeNone
1411 completeFilename = completeNone
1412 completeHomeModuleOrFile=completeNone
1413 completeBkpt = completeNone
1416 -- ---------------------------------------------------------------------------
1417 -- User code exception handling
1419 -- This is the exception handler for exceptions generated by the
1420 -- user's code and exceptions coming from children sessions;
1421 -- it normally just prints out the exception. The
1422 -- handler must be recursive, in case showing the exception causes
1423 -- more exceptions to be raised.
1425 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1426 -- raising another exception. We therefore don't put the recursive
1427 -- handler arond the flushing operation, so if stderr is closed
1428 -- GHCi will just die gracefully rather than going into an infinite loop.
1429 handler :: Exception -> GHCi Bool
1431 handler exception = do
1433 io installSignalHandlers
1434 ghciHandle handler (showException exception >> return False)
1436 showException (DynException dyn) =
1437 case fromDynamic dyn of
1438 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1439 Just Interrupted -> io (putStrLn "Interrupted.")
1440 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1441 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1442 Just other_ghc_ex -> io (print other_ghc_ex)
1444 showException other_exception
1445 = io (putStrLn ("*** Exception: " ++ show other_exception))
1447 -----------------------------------------------------------------------------
1448 -- recursive exception handlers
1450 -- Don't forget to unblock async exceptions in the handler, or if we're
1451 -- in an exception loop (eg. let a = error a in a) the ^C exception
1452 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1454 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1455 ghciHandle h (GHCi m) = GHCi $ \s ->
1456 Exception.catch (m s)
1457 (\e -> unGHCi (ghciUnblock (h e)) s)
1459 ghciUnblock :: GHCi a -> GHCi a
1460 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1463 -- ----------------------------------------------------------------------------
1466 expandPath :: String -> GHCi String
1468 case dropWhile isSpace path of
1470 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1471 return (tilde ++ '/':d)
1475 wantInterpretedModule :: String -> GHCi Module
1476 wantInterpretedModule str = do
1477 session <- getSession
1478 modl <- lookupModule str
1479 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1480 when (not is_interpreted) $
1481 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1484 wantNameFromInterpretedModule noCanDo str and_then = do
1485 session <- getSession
1486 names <- io $ GHC.parseName session str
1490 let modl = GHC.nameModule n
1491 if not (GHC.isExternalName n)
1492 then noCanDo n $ ppr n <>
1493 text " is not defined in an interpreted module"
1495 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1496 if not is_interpreted
1497 then noCanDo n $ text "module " <> ppr modl <>
1498 text " is not interpreted"
1501 -- ----------------------------------------------------------------------------
1502 -- Windows console setup
1504 setUpConsole :: IO ()
1506 #ifdef mingw32_HOST_OS
1507 -- On Windows we need to set a known code page, otherwise the characters
1508 -- we read from the console will be be in some strange encoding, and
1509 -- similarly for characters we write to the console.
1511 -- At the moment, GHCi pretends all input is Latin-1. In the
1512 -- future we should support UTF-8, but for now we set the code pages
1515 -- It seems you have to set the font in the console window to
1516 -- a Unicode font in order for output to work properly,
1517 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1518 -- (see MSDN for SetConsoleOutputCP()).
1520 setConsoleCP 28591 -- ISO Latin-1
1521 setConsoleOutputCP 28591 -- ISO Latin-1
1525 -- -----------------------------------------------------------------------------
1526 -- commands for debugger
1528 sprintCmd = pprintCommand False False
1529 printCmd = pprintCommand True False
1530 forceCmd = pprintCommand False True
1532 pprintCommand bind force str = do
1533 session <- getSession
1534 io $ pprintClosureCommand session bind force str
1536 stepCmd :: String -> GHCi ()
1537 stepCmd [] = doContinue GHC.SingleStep
1538 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1540 traceCmd :: String -> GHCi ()
1541 traceCmd [] = doContinue GHC.RunAndLogSteps
1542 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1544 continueCmd :: String -> GHCi ()
1545 continueCmd = noArgs $ doContinue GHC.RunToCompletion
1547 doContinue :: SingleStep -> GHCi ()
1548 doContinue step = do
1549 session <- getSession
1550 runResult <- io $ GHC.resume session step
1551 afterRunStmt runResult
1554 abandonCmd :: String -> GHCi ()
1555 abandonCmd = noArgs $ do
1557 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1558 when (not b) $ io $ putStrLn "There is no computation running."
1561 deleteCmd :: String -> GHCi ()
1562 deleteCmd argLine = do
1563 deleteSwitch $ words argLine
1565 deleteSwitch :: [String] -> GHCi ()
1567 io $ putStrLn "The delete command requires at least one argument."
1568 -- delete all break points
1569 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1570 deleteSwitch idents = do
1571 mapM_ deleteOneBreak idents
1573 deleteOneBreak :: String -> GHCi ()
1575 | all isDigit str = deleteBreak (read str)
1576 | otherwise = return ()
1578 historyCmd :: String -> GHCi ()
1580 | null arg = history 20
1581 | all isDigit arg = history (read arg)
1582 | otherwise = io $ putStrLn "Syntax: :history [num]"
1586 resumes <- io $ GHC.getResumeContext s
1588 [] -> io $ putStrLn "Not stopped at a breakpoint"
1590 let hist = GHC.resumeHistory r
1591 (took,rest) = splitAt num hist
1592 spans <- mapM (io . GHC.getHistorySpan s) took
1593 let nums = map (printf "-%-3d:") [(1::Int)..]
1594 printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans)))
1595 io $ putStrLn $ if null rest then "<end of history>" else "..."
1597 backCmd :: String -> GHCi ()
1598 backCmd = noArgs $ do
1600 (names, ix, span) <- io $ GHC.back s
1601 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1602 printTypeOfNames s names
1603 -- run the command set with ":set stop <cmd>"
1605 enqueueCommands [stop st]
1607 forwardCmd :: String -> GHCi ()
1608 forwardCmd = noArgs $ do
1610 (names, ix, span) <- io $ GHC.forward s
1611 printForUser $ (if (ix == 0)
1612 then ptext SLIT("Stopped at")
1613 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1614 printTypeOfNames s names
1615 -- run the command set with ":set stop <cmd>"
1617 enqueueCommands [stop st]
1619 -- handle the "break" command
1620 breakCmd :: String -> GHCi ()
1621 breakCmd argLine = do
1622 session <- getSession
1623 breakSwitch session $ words argLine
1625 breakSwitch :: Session -> [String] -> GHCi ()
1626 breakSwitch _session [] = do
1627 io $ putStrLn "The break command requires at least one argument."
1628 breakSwitch session args@(arg1:rest)
1629 | looksLikeModuleName arg1 = do
1630 mod <- wantInterpretedModule arg1
1631 breakByModule session mod rest
1632 | all isDigit arg1 = do
1633 (toplevel, _) <- io $ GHC.getContext session
1635 (mod : _) -> breakByModuleLine mod (read arg1) rest
1637 io $ putStrLn "Cannot find default module for breakpoint."
1638 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1639 | otherwise = do -- try parsing it as an identifier
1640 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1641 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1642 if GHC.isGoodSrcLoc loc
1643 then findBreakAndSet (GHC.nameModule name) $
1644 findBreakByCoord (Just (GHC.srcLocFile loc))
1645 (GHC.srcLocLine loc,
1647 else noCanDo name $ text "can't find its location: " <> ppr loc
1649 noCanDo n why = printForUser $
1650 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1652 breakByModule :: Session -> Module -> [String] -> GHCi ()
1653 breakByModule session mod args@(arg1:rest)
1654 | all isDigit arg1 = do -- looks like a line number
1655 breakByModuleLine mod (read arg1) rest
1656 | otherwise = io $ putStrLn "Invalid arguments to :break"
1658 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1659 breakByModuleLine mod line args
1660 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1661 | [col] <- args, all isDigit col =
1662 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1663 | otherwise = io $ putStrLn "Invalid arguments to :break"
1665 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1666 findBreakAndSet mod lookupTickTree = do
1667 tickArray <- getTickArray mod
1668 (breakArray, _) <- getModBreak mod
1669 case lookupTickTree tickArray of
1670 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1671 Just (tick, span) -> do
1672 success <- io $ setBreakFlag True breakArray tick
1673 session <- getSession
1677 recordBreak $ BreakLocation
1684 text "Breakpoint " <> ppr nm <>
1686 then text " was already set at " <> ppr span
1687 else text " activated at " <> ppr span
1689 printForUser $ text "Breakpoint could not be activated at"
1692 -- When a line number is specified, the current policy for choosing
1693 -- the best breakpoint is this:
1694 -- - the leftmost complete subexpression on the specified line, or
1695 -- - the leftmost subexpression starting on the specified line, or
1696 -- - the rightmost subexpression enclosing the specified line
1698 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1699 findBreakByLine line arr
1700 | not (inRange (bounds arr) line) = Nothing
1702 listToMaybe (sortBy leftmost_largest complete) `mplus`
1703 listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1704 listToMaybe (sortBy rightmost ticks)
1708 starts_here = [ tick | tick@(nm,span) <- ticks,
1709 GHC.srcSpanStartLine span == line ]
1711 (complete,incomplete) = partition ends_here starts_here
1712 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1714 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1715 -> Maybe (BreakIndex,SrcSpan)
1716 findBreakByCoord mb_file (line, col) arr
1717 | not (inRange (bounds arr) line) = Nothing
1719 listToMaybe (sortBy rightmost contains) `mplus`
1720 listToMaybe (sortBy leftmost_smallest after_here)
1724 -- the ticks that span this coordinate
1725 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1726 is_correct_file span ]
1728 is_correct_file span
1729 | Just f <- mb_file = GHC.srcSpanFile span == f
1732 after_here = [ tick | tick@(nm,span) <- ticks,
1733 GHC.srcSpanStartLine span == line,
1734 GHC.srcSpanStartCol span >= col ]
1737 leftmost_smallest (_,a) (_,b) = a `compare` b
1738 leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1740 (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1741 rightmost (_,a) (_,b) = b `compare` a
1743 spans :: SrcSpan -> (Int,Int) -> Bool
1744 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1745 where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1747 -- for now, use ANSI bold on Unixy systems. On Windows, we add a line
1748 -- of carets under the active expression instead. The Windows console
1749 -- doesn't support ANSI escape sequences, and most Unix terminals
1750 -- (including xterm) do, so this is a reasonable guess until we have a
1751 -- proper termcap/terminfo library.
1752 #if !defined(mingw32_TARGET_OS)
1758 start_bold = BS.pack "\ESC[1m"
1759 end_bold = BS.pack "\ESC[0m"
1761 listCmd :: String -> GHCi ()
1763 mb_span <- getCurrentBreakSpan
1765 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1766 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1767 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
1768 listCmd str = list2 (words str)
1770 list2 [arg] | all isDigit arg = do
1771 session <- getSession
1772 (toplevel, _) <- io $ GHC.getContext session
1774 [] -> io $ putStrLn "No module to list"
1775 (mod : _) -> listModuleLine mod (read arg)
1776 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1777 mod <- wantInterpretedModule arg1
1778 listModuleLine mod (read arg2)
1780 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1781 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1782 if GHC.isGoodSrcLoc loc
1784 tickArray <- getTickArray (GHC.nameModule name)
1785 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1786 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1789 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1790 Just (_,span) -> io $ listAround span False
1792 noCanDo name $ text "can't find its location: " <>
1795 noCanDo n why = printForUser $
1796 text "cannot list source code for " <> ppr n <> text ": " <> why
1798 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1800 listModuleLine :: Module -> Int -> GHCi ()
1801 listModuleLine modl line = do
1802 session <- getSession
1803 graph <- io (GHC.getModuleGraph session)
1804 let this = filter ((== modl) . GHC.ms_mod) graph
1806 [] -> panic "listModuleLine"
1808 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1809 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1810 io $ listAround (GHC.srcLocSpan loc) False
1812 -- | list a section of a source file around a particular SrcSpan.
1813 -- If the highlight flag is True, also highlight the span using
1814 -- start_bold/end_bold.
1815 listAround span do_highlight = do
1817 contents <- BS.readFile (pwd `joinFileName` unpackFS file)
1819 lines = BS.split '\n' contents
1820 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1821 drop (line1 - 1 - pad_before) $ lines
1822 fst_line = max 1 (line1 - pad_before)
1823 line_nos = [ fst_line .. ]
1825 highlighted | do_highlight = zipWith highlight line_nos these_lines
1826 | otherwise = these_lines
1828 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1829 prefixed = zipWith BS.append bs_line_nos highlighted
1831 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1833 file = GHC.srcSpanFile span
1834 line1 = GHC.srcSpanStartLine span
1835 col1 = GHC.srcSpanStartCol span
1836 line2 = GHC.srcSpanEndLine span
1837 col2 = GHC.srcSpanEndCol span
1839 pad_before | line1 == 1 = 0
1843 highlight | do_bold = highlight_bold
1844 | otherwise = highlight_carets
1846 highlight_bold no line
1847 | no == line1 && no == line2
1848 = let (a,r) = BS.splitAt col1 line
1849 (b,c) = BS.splitAt (col2-col1) r
1851 BS.concat [a,start_bold,b,end_bold,c]
1853 = let (a,b) = BS.splitAt col1 line in
1854 BS.concat [a, start_bold, b]
1856 = let (a,b) = BS.splitAt col2 line in
1857 BS.concat [a, end_bold, b]
1860 highlight_carets no line
1861 | no == line1 && no == line2
1862 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1863 BS.replicate (col2-col1) '^']
1865 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1866 BS.replicate (BS.length line-col1) '^']
1868 = BS.concat [line, nl, indent, BS.replicate col2 '^']
1871 indent = BS.pack " "
1872 nl = BS.singleton '\n'
1874 -- --------------------------------------------------------------------------
1877 getTickArray :: Module -> GHCi TickArray
1878 getTickArray modl = do
1880 let arrmap = tickarrays st
1881 case lookupModuleEnv arrmap modl of
1882 Just arr -> return arr
1884 (breakArray, ticks) <- getModBreak modl
1885 let arr = mkTickArray (assocs ticks)
1886 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1889 discardTickArrays :: GHCi ()
1890 discardTickArrays = do
1892 setGHCiState st{tickarrays = emptyModuleEnv}
1894 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1896 = accumArray (flip (:)) [] (1, max_line)
1897 [ (line, (nm,span)) | (nm,span) <- ticks,
1898 line <- srcSpanLines span ]
1900 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1901 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1902 GHC.srcSpanEndLine span ]
1904 lookupModule :: String -> GHCi Module
1905 lookupModule modName
1906 = do session <- getSession
1907 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1909 -- don't reset the counter back to zero?
1910 discardActiveBreakPoints :: GHCi ()
1911 discardActiveBreakPoints = do
1913 mapM (turnOffBreak.snd) (breaks st)
1914 setGHCiState $ st { breaks = [] }
1916 deleteBreak :: Int -> GHCi ()
1917 deleteBreak identity = do
1919 let oldLocations = breaks st
1920 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
1922 then printForUser (text "Breakpoint" <+> ppr identity <+>
1923 text "does not exist")
1925 mapM (turnOffBreak.snd) this
1926 setGHCiState $ st { breaks = rest }
1928 turnOffBreak loc = do
1929 (arr, _) <- getModBreak (breakModule loc)
1930 io $ setBreakFlag False arr (breakTick loc)
1932 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1933 getModBreak mod = do
1934 session <- getSession
1935 Just mod_info <- io $ GHC.getModuleInfo session mod
1936 let modBreaks = GHC.modInfoModBreaks mod_info
1937 let array = GHC.modBreaks_flags modBreaks
1938 let ticks = GHC.modBreaks_locs modBreaks
1939 return (array, ticks)
1941 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1942 setBreakFlag toggle array index
1943 | toggle = GHC.setBreakOn array index
1944 | otherwise = GHC.setBreakOff array index