1 {-# OPTIONS -fno-cse #-}
2 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
4 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
5 -----------------------------------------------------------------------------
7 -- GHC Interactive User Interface
9 -- (c) The GHC Team 2005-2006
11 -----------------------------------------------------------------------------
13 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
15 #include "HsVersions.h"
17 import qualified GhciMonad
18 import GhciMonad hiding (runStmt)
23 import qualified GHC hiding (resume, runStmt)
24 import GHC ( LoadHowMuch(..), Target(..), TargetId(..),
26 BreakIndex, Resume, SingleStep,
27 Ghc, handleSourceError )
30 import qualified Lexer
34 -- import PackageConfig
37 import HscTypes ( handleFlagWarnings )
39 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
40 import RdrName (RdrName)
41 import Outputable hiding (printForUser, printForUserPartWay)
42 import Module -- for ModuleEnv
46 -- Other random utilities
48 import BasicTypes hiding (isTopLevel)
49 import Panic hiding (showException)
55 import Maybes ( orElse, expectJust )
60 #ifndef mingw32_HOST_OS
61 import System.Posix hiding (getEnv)
63 import qualified System.Win32
66 import System.Console.Haskeline as Haskeline
67 import qualified System.Console.Haskeline.Encoding as Encoding
68 import Control.Monad.Trans
72 import Exception hiding (catch, block, unblock)
74 -- import Control.Concurrent
76 import System.FilePath
77 import qualified Data.ByteString.Char8 as BS
81 import System.Environment
82 import System.Exit ( exitWith, ExitCode(..) )
83 import System.Directory
85 import System.IO.Error
88 import Control.Monad as Monad
91 import GHC.Exts ( unsafeCoerce# )
93 import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
94 import GHC.IO.Handle ( hFlushAll )
98 import Data.IORef ( IORef, readIORef, writeIORef )
100 -----------------------------------------------------------------------------
102 ghciWelcomeMsg :: String
103 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
104 ": http://www.haskell.org/ghc/ :? for help"
106 cmdName :: Command -> String
109 GLOBAL_VAR(macros_ref, [], [Command])
111 builtin_commands :: [Command]
113 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
114 ("?", keepGoing help, noCompletion),
115 ("add", keepGoingPaths addModule, completeFilename),
116 ("abandon", keepGoing abandonCmd, noCompletion),
117 ("break", keepGoing breakCmd, completeIdentifier),
118 ("back", keepGoing backCmd, noCompletion),
119 ("browse", keepGoing' (browseCmd False), completeModule),
120 ("browse!", keepGoing' (browseCmd True), completeModule),
121 ("cd", keepGoing' changeDirectory, completeFilename),
122 ("check", keepGoing' checkModule, completeHomeModule),
123 ("continue", keepGoing continueCmd, noCompletion),
124 ("cmd", keepGoing cmdCmd, completeExpression),
125 ("ctags", keepGoing createCTagsWithLineNumbersCmd, completeFilename),
126 ("ctags!", keepGoing createCTagsWithRegExesCmd, completeFilename),
127 ("def", keepGoing (defineMacro False), completeExpression),
128 ("def!", keepGoing (defineMacro True), completeExpression),
129 ("delete", keepGoing deleteCmd, noCompletion),
130 ("edit", keepGoing editFile, completeFilename),
131 ("etags", keepGoing createETagsFileCmd, completeFilename),
132 ("force", keepGoing forceCmd, completeExpression),
133 ("forward", keepGoing forwardCmd, noCompletion),
134 ("help", keepGoing help, noCompletion),
135 ("history", keepGoing historyCmd, noCompletion),
136 ("info", keepGoing' info, completeIdentifier),
137 ("kind", keepGoing' kindOfType, completeIdentifier),
138 ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),
139 ("list", keepGoing' listCmd, noCompletion),
140 ("module", keepGoing setContext, completeSetModule),
141 ("main", keepGoing runMain, completeFilename),
142 ("print", keepGoing printCmd, completeExpression),
143 ("quit", quit, noCompletion),
144 ("reload", keepGoing' reloadModule, noCompletion),
145 ("run", keepGoing runRun, completeFilename),
146 ("script", keepGoing' scriptCmd, completeFilename),
147 ("set", keepGoing setCmd, completeSetOptions),
148 ("show", keepGoing showCmd, completeShowOptions),
149 ("sprint", keepGoing sprintCmd, completeExpression),
150 ("step", keepGoing stepCmd, completeIdentifier),
151 ("steplocal", keepGoing stepLocalCmd, completeIdentifier),
152 ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),
153 ("type", keepGoing' typeOfExpr, completeExpression),
154 ("trace", keepGoing traceCmd, completeExpression),
155 ("undef", keepGoing undefineMacro, completeMacro),
156 ("unset", keepGoing unsetOptions, completeSetOptions)
160 -- We initialize readline (in the interactiveUI function) to use
161 -- word_break_chars as the default set of completion word break characters.
162 -- This can be overridden for a particular command (for example, filename
163 -- expansion shouldn't consider '/' to be a word break) by setting the third
164 -- entry in the Command tuple above.
166 -- NOTE: in order for us to override the default correctly, any custom entry
167 -- must be a SUBSET of word_break_chars.
168 word_break_chars :: String
169 word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
170 specials = "(),;[]`{}"
172 in spaces ++ specials ++ symbols
174 flagWordBreakChars :: String
175 flagWordBreakChars = " \t\n"
178 keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)
179 keepGoing a str = keepGoing' (lift . a) str
181 keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool
182 keepGoing' a str = a str >> return False
184 keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
186 = do case toArgs str of
187 Left err -> Encoding.encode err >>= liftIO . BS.hPutStrLn stderr
191 shortHelpText :: String
192 shortHelpText = "use :? for help.\n"
196 " Commands available from the prompt:\n" ++
198 " <statement> evaluate/run <statement>\n" ++
199 " : repeat last command\n" ++
200 " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
201 " :add [*]<module> ... add module(s) to the current target set\n" ++
202 " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
203 " (!: more details; *: all top-level names)\n" ++
204 " :cd <dir> change directory to <dir>\n" ++
205 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
206 " :ctags[!] [<file>] create tags file for Vi (default: \"tags\")\n" ++
207 " (!: use regex instead of line number)\n" ++
208 " :def <cmd> <expr> define a command :<cmd>\n" ++
209 " :edit <file> edit file\n" ++
210 " :edit edit last module\n" ++
211 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
212 " :help, :? display this list of commands\n" ++
213 " :info [<name> ...] display information about the given names\n" ++
214 " :kind <type> show the kind of <type>\n" ++
215 " :load [*]<module> ... load module(s) and their dependents\n" ++
216 " :main [<arguments> ...] run the main function with the given arguments\n" ++
217 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
218 " :quit exit GHCi\n" ++
219 " :reload reload the current module set\n" ++
220 " :run function [<arguments> ...] run the function with the given arguments\n" ++
221 " :script <filename> run the script <filename>" ++
222 " :type <expr> show the type of <expr>\n" ++
223 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
224 " :!<command> run the shell command <command>\n" ++
226 " -- Commands for debugging:\n" ++
228 " :abandon at a breakpoint, abandon current computation\n" ++
229 " :back go back in the history (after :trace)\n" ++
230 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
231 " :break <name> set a breakpoint on the specified function\n" ++
232 " :continue resume after a breakpoint\n" ++
233 " :delete <number> delete the specified breakpoint\n" ++
234 " :delete * delete all breakpoints\n" ++
235 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
236 " :forward go forward in the history (after :back)\n" ++
237 " :history [<n>] after :trace, show the execution history\n" ++
238 " :list show the source code around current breakpoint\n" ++
239 " :list identifier show the source code for <identifier>\n" ++
240 " :list [<module>] <line> show the source code around line number <line>\n" ++
241 " :print [<name> ...] prints a value without forcing its computation\n" ++
242 " :sprint [<name> ...] simplifed version of :print\n" ++
243 " :step single-step after stopping at a breakpoint\n"++
244 " :step <expr> single-step into <expr>\n"++
245 " :steplocal single-step within the current top-level binding\n"++
246 " :stepmodule single-step restricted to the current module\n"++
247 " :trace trace after stopping at a breakpoint\n"++
248 " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++
251 " -- Commands for changing settings:\n" ++
253 " :set <option> ... set options\n" ++
254 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
255 " :set prog <progname> set the value returned by System.getProgName\n" ++
256 " :set prompt <prompt> set the prompt used in GHCi\n" ++
257 " :set editor <cmd> set the command used for :edit\n" ++
258 " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" ++
259 " :unset <option> ... unset options\n" ++
261 " Options for ':set' and ':unset':\n" ++
263 " +m allow multiline commands\n" ++
264 " +r revert top-level expressions after each evaluation\n" ++
265 " +s print timing/memory stats after each evaluation\n" ++
266 " +t print type after evaluation\n" ++
267 " -<flags> most GHC command line flags can also be set here\n" ++
268 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
269 " for GHCi-specific flags, see User's Guide,\n"++
270 " Flag reference, Interactive-mode options\n" ++
272 " -- Commands for displaying information:\n" ++
274 " :show bindings show the current bindings made at the prompt\n" ++
275 " :show breaks show the active breakpoints\n" ++
276 " :show context show the breakpoint context\n" ++
277 " :show modules show the currently loaded modules\n" ++
278 " :show packages show the currently active package flags\n" ++
279 " :show languages show the currently active language flags\n" ++
280 " :show <setting> show value of <setting>, which is one of\n" ++
281 " [args, prog, prompt, editor, stop]\n" ++
284 findEditor :: IO String
289 win <- System.Win32.getWindowsDirectory
290 return (win </> "notepad.exe")
295 foreign import ccall unsafe "rts_isProfiled" isProfiled :: IO CInt
297 default_progname, default_prompt, default_stop :: String
298 default_progname = "<interactive>"
299 default_prompt = "%s> "
302 default_args :: [String]
305 interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String]
307 interactiveUI srcs maybe_exprs = do
308 -- although GHCi compiles with -prof, it is not usable: the byte-code
309 -- compiler and interpreter don't work with profiling. So we check for
310 -- this up front and emit a helpful error message (#2197)
311 i <- liftIO $ isProfiled
313 ghcError (InstallationError "GHCi cannot be used when compiled with -prof")
315 -- HACK! If we happen to get into an infinite loop (eg the user
316 -- types 'let x=x in x' at the prompt), then the thread will block
317 -- on a blackhole, and become unreachable during GC. The GC will
318 -- detect that it is unreachable and send it the NonTermination
319 -- exception. However, since the thread is unreachable, everything
320 -- it refers to might be finalized, including the standard Handles.
321 -- This sounds like a bug, but we don't have a good solution right
323 _ <- liftIO $ newStablePtr stdin
324 _ <- liftIO $ newStablePtr stdout
325 _ <- liftIO $ newStablePtr stderr
327 -- Initialise buffering for the *interpreted* I/O system
330 liftIO $ when (isNothing maybe_exprs) $ do
331 -- Only for GHCi (not runghc and ghc -e):
333 -- Turn buffering off for the compiled program's stdout/stderr
335 -- Turn buffering off for GHCi's stdout
337 hSetBuffering stdout NoBuffering
338 -- We don't want the cmd line to buffer any input that might be
339 -- intended for the program, so unbuffer stdin.
340 hSetBuffering stdin NoBuffering
341 #if defined(mingw32_HOST_OS)
342 -- On Unix, stdin will use the locale encoding. The IO library
343 -- doesn't do this on Windows (yet), so for now we use UTF-8,
344 -- for consistency with GHC 6.10 and to make the tests work.
345 hSetEncoding stdin utf8
348 -- initial context is just the Prelude
349 prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing
350 GHC.setContext [] [(prel_mod, Nothing)]
352 default_editor <- liftIO $ findEditor
354 startGHCi (runGHCi srcs maybe_exprs)
355 GHCiState{ progname = default_progname,
357 prompt = default_prompt,
359 editor = default_editor,
360 -- session = session,
366 tickarrays = emptyModuleEnv,
367 last_command = Nothing,
370 ghc_e = isJust maybe_exprs
375 withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
376 withGhcAppData right left = do
377 either_dir <- tryIO (getAppUserDataDirectory "ghc")
380 do createDirectoryIfMissing False dir `catchIO` \_ -> return ()
384 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
385 runGHCi paths maybe_exprs = do
387 read_dot_files = not opt_IgnoreDotGhci
389 current_dir = return (Just ".ghci")
391 app_user_dir = liftIO $ withGhcAppData
392 (\dir -> return (Just (dir </> "ghci.conf")))
396 either_dir <- liftIO $ tryIO (getEnv "HOME")
398 Right home -> return (Just (home </> ".ghci"))
401 canonicalizePath' :: FilePath -> IO (Maybe FilePath)
402 canonicalizePath' fp = liftM Just (canonicalizePath fp)
403 `catchIO` \_ -> return Nothing
405 sourceConfigFile :: FilePath -> GHCi ()
406 sourceConfigFile file = do
407 exists <- liftIO $ doesFileExist file
409 dir_ok <- liftIO $ checkPerms (getDirectory file)
410 file_ok <- liftIO $ checkPerms file
411 when (dir_ok && file_ok) $ do
412 either_hdl <- liftIO $ tryIO (openFile file ReadMode)
415 -- NOTE: this assumes that runInputT won't affect the terminal;
416 -- can we assume this will always be the case?
417 -- This would be a good place for runFileInputT.
419 do runInputTWithPrefs defaultPrefs defaultSettings $
420 runCommands $ fileLoop hdl
421 liftIO (hClose hdl `catchIO` \_ -> return ())
423 getDirectory f = case takeDirectory f of "" -> "."; d -> d
425 when (read_dot_files) $ do
426 mcfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
427 mcfgs <- liftIO $ mapM canonicalizePath' (catMaybes mcfgs0)
428 mapM_ sourceConfigFile $ nub $ catMaybes mcfgs
429 -- nub, because we don't want to read .ghci twice if the
432 -- Perform a :load for files given on the GHCi command line
433 -- When in -e mode, if the load fails then we want to stop
434 -- immediately rather than going on to evaluate the expression.
435 when (not (null paths)) $ do
436 ok <- ghciHandle (\e -> do showException e; return Failed) $
437 -- TODO: this is a hack.
438 runInputTWithPrefs defaultPrefs defaultSettings $ do
439 let (filePaths, phases) = unzip paths
440 filePaths' <- mapM (Encoding.decode . BS.pack) filePaths
441 loadModule (zip filePaths' phases)
442 when (isJust maybe_exprs && failed ok) $
443 liftIO (exitWith (ExitFailure 1))
445 -- if verbosity is greater than 0, or we are connected to a
446 -- terminal, display the prompt in the interactive loop.
447 is_tty <- liftIO (hIsTerminalDevice stdin)
448 dflags <- getDynFlags
449 let show_prompt = verbosity dflags > 0 || is_tty
454 -- enter the interactive loop
455 runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
457 -- just evaluate the expression we were given
458 enqueueCommands exprs
459 let handle e = do st <- getGHCiState
460 -- flush the interpreter's stdout/stderr on exit (#3890)
462 -- Jump through some hoops to get the
463 -- current progname in the exception text:
464 -- <progname>: <exception>
465 liftIO $ withProgName (progname st)
466 -- this used to be topHandlerFastExit, see #2228
468 runInputTWithPrefs defaultPrefs defaultSettings $ do
469 runCommands' handle (return Nothing)
472 liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
474 runGHCiInput :: InputT GHCi a -> GHCi a
476 histFile <- liftIO $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
478 let settings = setComplete ghciCompleteWord
479 $ defaultSettings {historyFile = histFile}
482 nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
483 nextInputLine show_prompt is_tty
485 prompt <- if show_prompt then lift mkPrompt else return ""
488 when show_prompt $ lift mkPrompt >>= liftIO . putStr
491 -- NOTE: We only read .ghci files if they are owned by the current user,
492 -- and aren't world writable. Otherwise, we could be accidentally
493 -- running code planted by a malicious third party.
495 -- Furthermore, We only read ./.ghci if . is owned by the current user
496 -- and isn't writable by anyone else. I think this is sufficient: we
497 -- don't need to check .. and ../.. etc. because "." always refers to
498 -- the same directory while a process is running.
500 checkPerms :: String -> IO Bool
501 #ifdef mingw32_HOST_OS
506 handleIO (\_ -> return False) $ do
507 st <- getFileStatus name
509 if fileOwner st /= me then do
510 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
513 let mode = System.Posix.fileMode st
514 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
515 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
517 putStrLn $ "*** WARNING: " ++ name ++
518 " is writable by someone else, IGNORING!"
523 incrementLines :: InputT GHCi ()
525 st <- lift $ getGHCiState
526 let ln = 1+(line_number st)
527 lift $ setGHCiState st{line_number=ln}
529 fileLoop :: Handle -> InputT GHCi (Maybe String)
531 l <- liftIO $ tryIO $ hGetLine hdl
533 Left e | isEOFError e -> return Nothing
534 | InvalidArgument <- etype -> return Nothing
535 | otherwise -> liftIO $ ioError e
536 where etype = ioeGetErrorType e
537 -- treat InvalidArgument in the same way as EOF:
538 -- this can happen if the user closed stdin, or
539 -- perhaps did getContents which closes stdin at
545 mkPrompt :: GHCi String
547 (toplevs,exports) <- GHC.getContext
548 resumes <- GHC.getResumeContext
549 -- st <- getGHCiState
555 let ix = GHC.resumeHistoryIx r
557 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
559 let hist = GHC.resumeHistory r !! (ix-1)
560 span <- GHC.getHistorySpan hist
561 return (brackets (ppr (negate ix) <> char ':'
562 <+> ppr span) <> space)
564 dots | _:rs <- resumes, not (null rs) = text "... "
569 -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
570 -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
571 -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
572 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
573 hsep (map (ppr . GHC.moduleName) (nub (map fst exports)))
575 deflt_prompt = dots <> context_bit <> modules_bit
577 f ('%':'s':xs) = deflt_prompt <> f xs
578 f ('%':'%':xs) = char '%' <> f xs
579 f (x:xs) = char x <> f xs
583 return (showSDoc (f (prompt st)))
586 queryQueue :: GHCi (Maybe String)
591 c:cs -> do setGHCiState st{ cmdqueue = cs }
594 runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
595 runCommands = runCommands' handler
597 runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
598 -> InputT GHCi (Maybe String) -> InputT GHCi ()
599 runCommands' eh getCmd = do
600 b <- ghandle (\e -> case fromException e of
601 Just UserInterrupt -> return $ Just False
602 _ -> case fromException e of
604 do liftIO (print (ghc_e :: GhcException))
607 liftIO (Exception.throwIO e))
608 (runOneCommand eh getCmd)
611 Just _ -> runCommands' eh getCmd
613 runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
614 -> InputT GHCi (Maybe Bool)
615 runOneCommand eh getCmd = do
616 mb_cmd <- noSpace (lift queryQueue)
617 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
619 Nothing -> return Nothing
620 Just c -> ghciHandle (\e -> lift $ eh e >>= return . Just) $
621 handleSourceError printErrorAndKeepGoing
623 -- source error's are handled by runStmt
624 -- is the handler necessary here?
626 printErrorAndKeepGoing err = do
627 GHC.printException err
630 noSpace q = q >>= maybe (return Nothing)
631 (\c->case removeSpaces c of
633 ":{" -> multiLineCmd q
634 c -> return (Just c) )
636 st <- lift getGHCiState
638 lift $ setGHCiState st{ prompt = "%s| " }
639 mb_cmd <- collectCommand q ""
640 lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p }
642 -- we can't use removeSpaces for the sublines here, so
643 -- multiline commands are somewhat more brittle against
644 -- fileformat errors (such as \r in dos input on unix),
645 -- we get rid of any extra spaces for the ":}" test;
646 -- we also avoid silent failure if ":}" is not found;
647 -- and since there is no (?) valid occurrence of \r (as
648 -- opposed to its String representation, "\r") inside a
649 -- ghci command, we replace any such with ' ' (argh:-(
650 collectCommand q c = q >>=
651 maybe (liftIO (ioError collectError))
652 (\l->if removeSpaces l == ":}"
653 then return (Just $ removeSpaces c)
654 else collectCommand q (c ++ "\n" ++ map normSpace l))
655 where normSpace '\r' = ' '
657 -- QUESTION: is userError the one to use here?
658 collectError = userError "unterminated multiline command :{ .. :}"
659 doCommand (':' : cmd) = do
660 result <- specialCommand cmd
662 True -> return Nothing
663 _ -> return $ Just True
665 ml <- lift $ isOptionSet Multiline
668 mb_stmt <- checkInputForLayout stmt getCmd
670 Nothing -> return $ Just True
672 result <- timeIt $ lift $ runStmt ml_stmt GHC.RunToCompletion
675 result <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion
679 -- lex the input. If there is an unclosed layout context, request input
680 checkInputForLayout :: String -> InputT GHCi (Maybe String)
681 -> InputT GHCi (Maybe String)
682 checkInputForLayout stmt getStmt = do
683 dflags' <- lift $ getDynFlags
684 let dflags = xopt_set dflags' Opt_AlternativeLayoutRule
685 st <- lift $ getGHCiState
686 let buf = stringToStringBuffer stmt
687 loc = mkSrcLoc (fsLit (progname st)) (line_number st) 1
688 pstate = Lexer.mkPState dflags buf loc
689 case Lexer.unP goToEnd pstate of
690 (Lexer.POk _ False) -> return $ Just stmt
692 st <- lift getGHCiState
694 lift $ setGHCiState st{ prompt = "%s| " }
695 mb_stmt <- ghciHandle (\ex -> case fromException ex of
696 Just UserInterrupt -> return Nothing
697 _ -> case fromException ex of
699 do liftIO (print (ghc_e :: GhcException))
701 _other -> liftIO (Exception.throwIO ex))
703 lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p }
704 -- the recursive call does not recycle parser state
705 -- as we use a new string buffer
707 Nothing -> return Nothing
708 Just str -> if str == ""
709 then return $ Just stmt
711 checkInputForLayout (stmt++"\n"++str) getStmt
713 eof <- Lexer.nextIsEOF
715 then Lexer.activeContext
716 else Lexer.lexer return >> goToEnd
718 enqueueCommands :: [String] -> GHCi ()
719 enqueueCommands cmds = do
721 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
724 runStmt :: String -> SingleStep -> GHCi Bool
726 | null (filter (not.isSpace) stmt)
728 | "import " `isPrefixOf` stmt
729 = do newContextCmd (Import stmt); return False
731 = do -- In the new IO library, read handles buffer data even if the Handle
732 -- is set to NoBuffering. This causes problems for GHCi where there
733 -- are really two stdin Handles. So we flush any bufferred data in
734 -- GHCi's stdin Handle here (only relevant if stdin is attached to
735 -- a file, otherwise the read buffer can't be flushed).
736 _ <- liftIO $ tryIO $ hFlushAll stdin
737 result <- GhciMonad.runStmt stmt step
738 afterRunStmt (const True) result
740 --afterRunStmt :: GHC.RunResult -> GHCi Bool
741 -- False <=> the statement failed to compile
742 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
743 afterRunStmt _ (GHC.RunException e) = throw e
744 afterRunStmt step_here run_result = do
745 resumes <- GHC.getResumeContext
747 GHC.RunOk names -> do
748 show_types <- isOptionSet ShowType
749 when show_types $ printTypeOfNames names
750 GHC.RunBreak _ names mb_info
751 | isNothing mb_info ||
752 step_here (GHC.resumeSpan $ head resumes) -> do
753 mb_id_loc <- toBreakIdAndLocation mb_info
754 let breakCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
756 then printStoppedAtBreakInfo (head resumes) names
757 else enqueueCommands [breakCmd]
758 -- run the command set with ":set stop <cmd>"
760 enqueueCommands [stop st]
762 | otherwise -> resume step_here GHC.SingleStep >>=
763 afterRunStmt step_here >> return ()
767 liftIO installSignalHandlers
768 b <- isOptionSet RevertCAFs
771 return (case run_result of GHC.RunOk _ -> True; _ -> False)
773 toBreakIdAndLocation ::
774 Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
775 toBreakIdAndLocation Nothing = return Nothing
776 toBreakIdAndLocation (Just info) = do
777 let mod = GHC.breakInfo_module info
778 nm = GHC.breakInfo_number info
780 return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
781 breakModule loc == mod,
782 breakTick loc == nm ]
784 printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
785 printStoppedAtBreakInfo resume names = do
786 printForUser $ ptext (sLit "Stopped at") <+>
787 ppr (GHC.resumeSpan resume)
788 -- printTypeOfNames session names
789 let namesSorted = sortBy compareNames names
790 tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
791 docs <- pprTypeAndContents [id | AnId id <- tythings]
792 printForUserPartWay docs
794 printTypeOfNames :: [Name] -> GHCi ()
795 printTypeOfNames names
796 = mapM_ (printTypeOfName ) $ sortBy compareNames names
798 compareNames :: Name -> Name -> Ordering
799 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
800 where compareWith n = (getOccString n, getSrcSpan n)
802 printTypeOfName :: Name -> GHCi ()
804 = do maybe_tything <- GHC.lookupName n
805 case maybe_tything of
807 Just thing -> printTyThing thing
810 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
812 specialCommand :: String -> InputT GHCi Bool
813 specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
814 specialCommand str = do
815 let (cmd,rest) = break isSpace str
816 maybe_cmd <- lift $ lookupCommand cmd
818 GotCommand (_,f,_) -> f (dropWhile isSpace rest)
820 do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
824 do liftIO $ hPutStr stdout ("there is no last command to perform\n"
828 lookupCommand :: String -> GHCi (MaybeCommand)
829 lookupCommand "" = do
831 case last_command st of
832 Just c -> return $ GotCommand c
833 Nothing -> return NoLastCommand
834 lookupCommand str = do
835 mc <- liftIO $ lookupCommand' str
837 setGHCiState st{ last_command = mc }
839 Just c -> GotCommand c
840 Nothing -> BadCommand
842 lookupCommand' :: String -> IO (Maybe Command)
843 lookupCommand' ":" = return Nothing
844 lookupCommand' str' = do
845 macros <- readIORef macros_ref
846 let{ (str, cmds) = case str' of
847 ':' : rest -> (rest, builtin_commands)
848 _ -> (str', macros ++ builtin_commands) }
849 -- look for exact match first, then the first prefix match
850 return $ case [ c | c <- cmds, str == cmdName c ] of
852 [] -> case [ c | c@(s,_,_) <- cmds, str `isPrefixOf` s ] of
856 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
857 getCurrentBreakSpan = do
858 resumes <- GHC.getResumeContext
862 let ix = GHC.resumeHistoryIx r
864 then return (Just (GHC.resumeSpan r))
866 let hist = GHC.resumeHistory r !! (ix-1)
867 span <- GHC.getHistorySpan hist
870 getCurrentBreakModule :: GHCi (Maybe Module)
871 getCurrentBreakModule = do
872 resumes <- GHC.getResumeContext
876 let ix = GHC.resumeHistoryIx r
878 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
880 let hist = GHC.resumeHistory r !! (ix-1)
881 return $ Just $ GHC.getHistoryModule hist
883 -----------------------------------------------------------------------------
886 noArgs :: GHCi () -> String -> GHCi ()
888 noArgs _ _ = liftIO $ putStrLn "This command takes no arguments"
890 help :: String -> GHCi ()
891 help _ = liftIO (putStr helpText)
893 info :: String -> InputT GHCi ()
894 info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
895 info s = handleSourceError GHC.printException $
896 do { let names = words s
897 ; dflags <- getDynFlags
898 ; let pefas = dopt Opt_PrintExplicitForalls dflags
899 ; mapM_ (infoThing pefas) names }
901 infoThing pefas str = do
902 names <- GHC.parseName str
903 mb_stuffs <- mapM GHC.getInfo names
904 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
905 unqual <- GHC.getPrintUnqual
906 liftIO $ putStrLn $ showSDocForUser unqual $
907 vcat (intersperse (text "") $
908 map (pprInfo pefas) filtered)
910 -- Filter out names whose parent is also there Good
911 -- example is '[]', which is both a type and data
912 -- constructor in the same type
913 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
914 filterOutChildren get_thing xs
915 = filterOut has_parent xs
917 all_names = mkNameSet (map (getName . get_thing) xs)
918 has_parent x = case pprTyThingParent_maybe (get_thing x) of
919 Just p -> getName p `elemNameSet` all_names
922 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
923 pprInfo pefas (thing, fixity, insts)
924 = pprTyThingInContextLoc pefas thing
925 $$ show_fixity fixity
926 $$ vcat (map GHC.pprInstance insts)
929 | fix == GHC.defaultFixity = empty
930 | otherwise = ppr fix <+> ppr (GHC.getName thing)
932 runMain :: String -> GHCi ()
933 runMain s = case toArgs s of
934 Left err -> liftIO (hPutStrLn stderr err)
936 do dflags <- getDynFlags
937 case mainFunIs dflags of
938 Nothing -> doWithArgs args "main"
939 Just f -> doWithArgs args f
941 runRun :: String -> GHCi ()
942 runRun s = case toCmdArgs s of
943 Left err -> liftIO (hPutStrLn stderr err)
944 Right (cmd, args) -> doWithArgs args cmd
946 doWithArgs :: [String] -> String -> GHCi ()
947 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
948 show args ++ " (" ++ cmd ++ ")"]
950 addModule :: [FilePath] -> InputT GHCi ()
952 lift revertCAFs -- always revert CAFs on load/add.
953 files <- mapM expandPath files
954 targets <- mapM (\m -> GHC.guessTarget m Nothing) files
955 -- remove old targets with the same id; e.g. for :add *M
956 mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
957 mapM_ GHC.addTarget targets
958 prev_context <- GHC.getContext
959 ok <- trySuccess $ GHC.load LoadAllTargets
960 afterLoad ok False prev_context
962 changeDirectory :: String -> InputT GHCi ()
963 changeDirectory "" = do
964 -- :cd on its own changes to the user's home directory
965 either_dir <- liftIO $ tryIO getHomeDirectory
968 Right dir -> changeDirectory dir
969 changeDirectory dir = do
970 graph <- GHC.getModuleGraph
971 when (not (null graph)) $
972 liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."
973 prev_context <- GHC.getContext
975 _ <- GHC.load LoadAllTargets
976 lift $ setContextAfterLoad prev_context False []
977 GHC.workingDirectoryChanged
978 dir <- expandPath dir
979 liftIO $ setCurrentDirectory dir
981 trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
983 handleSourceError (\e -> do GHC.printException e
987 editFile :: String -> GHCi ()
989 do file <- if null str then chooseEditFile else return str
993 $ ghcError (CmdLineError "editor not set, use :set editor")
994 _ <- liftIO $ system (cmd ++ ' ':file)
997 -- The user didn't specify a file so we pick one for them.
998 -- Our strategy is to pick the first module that failed to load,
999 -- or otherwise the first target.
1001 -- XXX: Can we figure out what happened if the depndecy analysis fails
1002 -- (e.g., because the porgrammeer mistyped the name of a module)?
1003 -- XXX: Can we figure out the location of an error to pass to the editor?
1004 -- XXX: if we could figure out the list of errors that occured during the
1005 -- last load/reaload, then we could start the editor focused on the first
1007 chooseEditFile :: GHCi String
1009 do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
1011 graph <- GHC.getModuleGraph
1012 failed_graph <- filterM hasFailed graph
1013 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
1014 pick xs = case xs of
1015 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
1018 case pick (order failed_graph) of
1019 Just file -> return file
1021 do targets <- GHC.getTargets
1022 case msum (map fromTarget targets) of
1023 Just file -> return file
1024 Nothing -> ghcError (CmdLineError "No files to edit.")
1026 where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
1027 fromTarget _ = Nothing -- when would we get a module target?
1029 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
1030 defineMacro _ (':':_) =
1031 liftIO $ putStrLn "macro name cannot start with a colon"
1032 defineMacro overwrite s = do
1033 let (macro_name, definition) = break isSpace s
1034 macros <- liftIO (readIORef macros_ref)
1035 let defined = map cmdName macros
1036 if (null macro_name)
1037 then if null defined
1038 then liftIO $ putStrLn "no macros defined"
1039 else liftIO $ putStr ("the following macros are defined:\n" ++
1042 if (not overwrite && macro_name `elem` defined)
1043 then ghcError (CmdLineError
1044 ("macro '" ++ macro_name ++ "' is already defined"))
1047 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
1049 -- give the expression a type signature, so we can be sure we're getting
1050 -- something of the right type.
1051 let new_expr = '(' : definition ++ ") :: String -> IO String"
1053 -- compile the expression
1054 handleSourceError (\e -> GHC.printException e) $
1056 hv <- GHC.compileExpr new_expr
1057 liftIO (writeIORef macros_ref --
1058 (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)]))
1060 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
1062 str <- liftIO ((unsafeCoerce# fun :: String -> IO String) s)
1063 -- make sure we force any exceptions in the result, while we are still
1064 -- inside the exception handler for commands:
1065 seqList str (return ())
1066 enqueueCommands (lines str)
1069 undefineMacro :: String -> GHCi ()
1070 undefineMacro str = mapM_ undef (words str)
1071 where undef macro_name = do
1072 cmds <- liftIO (readIORef macros_ref)
1073 if (macro_name `notElem` map cmdName cmds)
1074 then ghcError (CmdLineError
1075 ("macro '" ++ macro_name ++ "' is not defined"))
1077 liftIO (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
1079 cmdCmd :: String -> GHCi ()
1081 let expr = '(' : str ++ ") :: IO String"
1082 handleSourceError (\e -> GHC.printException e) $
1084 hv <- GHC.compileExpr expr
1085 cmds <- liftIO $ (unsafeCoerce# hv :: IO String)
1086 enqueueCommands (lines cmds)
1089 loadModuleName :: GHC.GhcMonad m => ImportDecl RdrName -> m Module
1090 loadModuleName = flip GHC.findModule Nothing . unLoc . ideclName
1092 loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
1093 loadModule fs = timeIt (loadModule' fs)
1095 loadModule_ :: [FilePath] -> InputT GHCi ()
1096 loadModule_ fs = loadModule (zip fs (repeat Nothing)) >> return ()
1098 loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
1099 loadModule' files = do
1100 prev_context <- GHC.getContext
1104 lift discardActiveBreakPoints
1106 _ <- GHC.load LoadAllTargets
1108 let (filenames, phases) = unzip files
1109 exp_filenames <- mapM expandPath filenames
1110 let files' = zip exp_filenames phases
1111 targets <- mapM (uncurry GHC.guessTarget) files'
1113 -- NOTE: we used to do the dependency anal first, so that if it
1114 -- fails we didn't throw away the current set of modules. This would
1115 -- require some re-working of the GHC interface, so we'll leave it
1116 -- as a ToDo for now.
1118 GHC.setTargets targets
1119 doLoad False prev_context LoadAllTargets
1121 checkModule :: String -> InputT GHCi ()
1123 let modl = GHC.mkModuleName m
1124 prev_context <- GHC.getContext
1125 ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do
1126 r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
1127 liftIO $ putStrLn $ showSDoc $
1128 case GHC.moduleInfo r of
1129 cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1131 (local,global) = ASSERT( all isExternalName scope )
1132 partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1134 (text "global names: " <+> ppr global) $$
1135 (text "local names: " <+> ppr local)
1138 afterLoad (successIf ok) False prev_context
1140 reloadModule :: String -> InputT GHCi ()
1142 prev_context <- GHC.getContext
1143 _ <- doLoad True prev_context $
1144 if null m then LoadAllTargets
1145 else LoadUpTo (GHC.mkModuleName m)
1148 doLoad :: Bool -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> LoadHowMuch -> InputT GHCi SuccessFlag
1149 doLoad retain_context prev_context howmuch = do
1150 -- turn off breakpoints before we load: we can't turn them off later, because
1151 -- the ModBreaks will have gone away.
1152 lift discardActiveBreakPoints
1153 ok <- trySuccess $ GHC.load howmuch
1154 afterLoad ok retain_context prev_context
1157 afterLoad :: SuccessFlag -> Bool -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> InputT GHCi ()
1158 afterLoad ok retain_context prev_context = do
1159 lift revertCAFs -- always revert CAFs on load.
1160 lift discardTickArrays
1161 loaded_mod_summaries <- getLoadedModules
1162 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1163 loaded_mod_names = map GHC.moduleName loaded_mods
1164 modulesLoadedMsg ok loaded_mod_names
1166 lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
1169 setContextAfterLoad :: ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> Bool -> [GHC.ModSummary] -> GHCi ()
1170 setContextAfterLoad prev keep_ctxt [] = do
1171 prel_mod <- getPrelude
1172 setContextKeepingPackageModules prev keep_ctxt ([], [(prel_mod, Nothing)])
1173 setContextAfterLoad prev keep_ctxt ms = do
1174 -- load a target if one is available, otherwise load the topmost module.
1175 targets <- GHC.getTargets
1176 case [ m | Just m <- map (findTarget ms) targets ] of
1178 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1179 load_this (last graph')
1184 = case filter (`matches` t) ms of
1188 summary `matches` Target (TargetModule m) _ _
1189 = GHC.ms_mod_name summary == m
1190 summary `matches` Target (TargetFile f _) _ _
1191 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1195 load_this summary | m <- GHC.ms_mod summary = do
1196 b <- GHC.moduleIsInterpreted m
1197 if b then setContextKeepingPackageModules prev keep_ctxt ([m], [])
1199 prel_mod <- getPrelude
1200 setContextKeepingPackageModules prev keep_ctxt ([],[(prel_mod,Nothing),(m,Nothing)])
1202 -- | Keep any package modules (except Prelude) when changing the context.
1203 setContextKeepingPackageModules
1204 :: ([Module],[(Module, Maybe (ImportDecl RdrName))]) -- previous context
1205 -> Bool -- re-execute :module commands
1206 -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -- new context
1208 setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do
1209 let (_,bs0) = prev_context
1210 prel_mod <- getPrelude
1211 -- filter everything, not just lefts
1212 let pkg_modules = filter ((\p -> not (isHomeModule p) && p /= prel_mod) . fst) bs0
1213 let bs1 = if null as then nubBy sameFst ((prel_mod,Nothing) : bs) else bs
1214 GHC.setContext as (nubBy sameFst (bs1 ++ pkg_modules))
1218 mapM_ (playCtxtCmd False) (remembered_ctx st)
1221 setGHCiState st{ remembered_ctx = [] }
1223 isHomeModule :: Module -> Bool
1224 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1226 sameFst :: (Module, Maybe (ImportDecl RdrName)) -> (Module, Maybe (ImportDecl RdrName)) -> Bool
1227 sameFst x y = fst x == fst y
1229 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi ()
1230 modulesLoadedMsg ok mods = do
1231 dflags <- getDynFlags
1232 when (verbosity dflags > 0) $ do
1234 | null mods = text "none."
1235 | otherwise = hsep (
1236 punctuate comma (map ppr mods)) <> text "."
1239 liftIO $ putStrLn $ showSDoc (text "Failed, modules loaded: " <> mod_commas)
1241 liftIO $ putStrLn $ showSDoc (text "Ok, modules loaded: " <> mod_commas)
1244 typeOfExpr :: String -> InputT GHCi ()
1246 = handleSourceError GHC.printException
1248 ty <- GHC.exprType str
1249 dflags <- getDynFlags
1250 let pefas = dopt Opt_PrintExplicitForalls dflags
1251 printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]
1253 kindOfType :: String -> InputT GHCi ()
1255 = handleSourceError GHC.printException
1257 ty <- GHC.typeKind str
1258 printForUser $ text str <+> dcolon <+> ppr ty
1260 quit :: String -> InputT GHCi Bool
1261 quit _ = return True
1263 shellEscape :: String -> GHCi Bool
1264 shellEscape str = liftIO (system str >> return False)
1266 -----------------------------------------------------------------------------
1267 -- running a script file #1363
1269 scriptCmd :: String -> InputT GHCi ()
1273 _ -> ghcError (CmdLineError "syntax: :script <filename>")
1275 runScript :: String -- ^ filename
1277 runScript filename = do
1278 either_script <- liftIO $ tryIO (openFile filename ReadMode)
1279 case either_script of
1280 Left _err -> ghcError (CmdLineError $ "IO error: \""++filename++"\" "
1281 ++(ioeGetErrorString _err))
1283 st <- lift $ getGHCiState
1284 let prog = progname st
1285 line = line_number st
1286 lift $ setGHCiState st{progname=filename,line_number=0}
1288 liftIO $ hClose script
1289 new_st <- lift $ getGHCiState
1290 lift $ setGHCiState new_st{progname=prog,line_number=line}
1291 where scriptLoop script = do
1292 res <- runOneCommand handler $ fileLoop script
1294 Nothing -> return ()
1295 Just succ -> if succ
1296 then scriptLoop script
1299 -----------------------------------------------------------------------------
1300 -- Browsing a module's contents
1302 browseCmd :: Bool -> String -> InputT GHCi ()
1305 ['*':s] | looksLikeModuleName s -> do
1306 m <- lift $ wantInterpretedModule s
1307 browseModule bang m False
1308 [s] | looksLikeModuleName s -> do
1309 m <- lift $ lookupModule s
1310 browseModule bang m True
1312 (as,bs) <- GHC.getContext
1313 -- Guess which module the user wants to browse. Pick
1314 -- modules that are interpreted first. The most
1315 -- recently-added module occurs last, it seems.
1317 (as@(_:_), _) -> browseModule bang (last as) True
1318 ([], bs@(_:_)) -> browseModule bang (fst (last bs)) True
1319 ([], []) -> ghcError (CmdLineError ":browse: no current module")
1320 _ -> ghcError (CmdLineError "syntax: :browse <module>")
1322 -- without bang, show items in context of their parents and omit children
1323 -- with bang, show class methods and data constructors separately, and
1324 -- indicate import modules, to aid qualifying unqualified names
1325 -- with sorted, sort items alphabetically
1326 browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
1327 browseModule bang modl exports_only = do
1328 -- :browse! reports qualifiers wrt current context
1329 current_unqual <- GHC.getPrintUnqual
1330 -- Temporarily set the context to the module we're interested in,
1331 -- just so we can get an appropriate PrintUnqualified
1332 (as,bs) <- GHC.getContext
1333 prel_mod <- lift getPrelude
1334 if exports_only then GHC.setContext [] [(prel_mod,Nothing), (modl,Nothing)]
1335 else GHC.setContext [modl] []
1336 target_unqual <- GHC.getPrintUnqual
1337 GHC.setContext as bs
1339 let unqual = if bang then current_unqual else target_unqual
1341 mb_mod_info <- GHC.getModuleInfo modl
1343 Nothing -> ghcError (CmdLineError ("unknown module: " ++
1344 GHC.moduleNameString (GHC.moduleName modl)))
1346 dflags <- getDynFlags
1348 | exports_only = GHC.modInfoExports mod_info
1349 | otherwise = GHC.modInfoTopLevelScope mod_info
1352 -- sort alphabetically name, but putting
1353 -- locally-defined identifiers first.
1354 -- We would like to improve this; see #1799.
1355 sorted_names = loc_sort local ++ occ_sort external
1357 (local,external) = ASSERT( all isExternalName names )
1358 partition ((==modl) . nameModule) names
1359 occ_sort = sortBy (compare `on` nameOccName)
1360 -- try to sort by src location. If the first name in
1361 -- our list has a good source location, then they all should.
1363 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1364 = sortBy (compare `on` nameSrcSpan) names
1368 mb_things <- mapM GHC.lookupName sorted_names
1369 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1371 rdr_env <- GHC.getGRE
1373 let pefas = dopt Opt_PrintExplicitForalls dflags
1374 things | bang = catMaybes mb_things
1375 | otherwise = filtered_things
1376 pretty | bang = pprTyThing
1377 | otherwise = pprTyThingInContext
1379 labels [] = text "-- not currently imported"
1380 labels l = text $ intercalate "\n" $ map qualifier l
1381 qualifier = maybe "-- defined locally"
1382 (("-- imported via "++) . intercalate ", "
1383 . map GHC.moduleNameString)
1384 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1385 modNames = map (importInfo . GHC.getName) things
1387 -- annotate groups of imports with their import modules
1388 -- the default ordering is somewhat arbitrary, so we group
1389 -- by header and sort groups; the names themselves should
1390 -- really come in order of source appearance.. (trac #1799)
1391 annotate mts = concatMap (\(m,ts)->labels m:ts)
1392 $ sortBy cmpQualifiers $ group mts
1393 where cmpQualifiers =
1394 compare `on` (map (fmap (map moduleNameFS)) . fst)
1396 group mts@((m,_):_) = (m,map snd g) : group ng
1397 where (g,ng) = partition ((==m).fst) mts
1399 let prettyThings = map (pretty pefas) things
1400 prettyThings' | bang = annotate $ zip modNames prettyThings
1401 | otherwise = prettyThings
1402 liftIO $ putStrLn $ showSDocForUser unqual (vcat prettyThings')
1403 -- ToDo: modInfoInstances currently throws an exception for
1404 -- package modules. When it works, we can do this:
1405 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1407 -----------------------------------------------------------------------------
1408 -- Setting the module context
1410 newContextCmd :: CtxtCmd -> GHCi ()
1411 newContextCmd cmd = do
1412 playCtxtCmd True cmd
1414 let cmds = remembered_ctx st
1415 setGHCiState st{ remembered_ctx = cmds ++ [cmd] }
1417 setContext :: String -> GHCi ()
1419 | all sensible strs = newContextCmd cmd
1420 | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1424 '+':stuff -> rest AddModules stuff
1425 '-':stuff -> rest RemModules stuff
1426 stuff -> rest SetContext stuff
1428 rest cmd stuff = (cmd as bs, strs)
1429 where strs = words stuff
1430 (as,bs) = partitionWith starred strs
1432 sensible ('*':m) = looksLikeModuleName m
1433 sensible m = looksLikeModuleName m
1435 starred ('*':m) = Left m
1438 playCtxtCmd:: Bool -> CtxtCmd -> GHCi ()
1439 playCtxtCmd fail cmd = do
1440 (prev_as,prev_bs) <- GHC.getContext
1442 SetContext as bs -> do
1443 (as',bs') <- do_checks as bs
1444 prel_mod <- getPrelude
1445 let bs'' = if null as && prel_mod `notElem` (map fst bs')
1446 then (prel_mod,Nothing):bs'
1448 GHC.setContext as' bs''
1450 AddModules as bs -> do
1451 (as',bs') <- do_checks as bs
1452 -- it should replace the old stuff, not the other way around
1453 -- need deleteAllBy, not deleteFirstsBy for sameFst
1454 let remaining_as = prev_as \\ (as' ++ map fst bs')
1455 remaining_bs = deleteAllBy sameFst prev_bs (bs' ++ map contextualize as')
1456 GHC.setContext (remaining_as ++ as') (remaining_bs ++ bs')
1458 RemModules as bs -> do
1459 (as',bs') <- do_checks as bs
1460 let new_as = prev_as \\ (as' ++ map fst bs')
1461 new_bs = deleteAllBy sameFst prev_bs (map contextualize as' ++ bs')
1462 GHC.setContext new_as new_bs
1465 m_idecl <- maybe_fail $ GHC.parseImportDecl str
1467 Nothing -> return ()
1469 m_mdl <- maybe_fail $ loadModuleName idecl
1471 Nothing -> return ()
1472 Just m -> GHC.setContext prev_as (prev_bs ++ [(m, Just idecl)])
1475 maybe_fail | fail = liftM Just
1476 | otherwise = trymaybe
1478 do_checks as bs = do
1479 as' <- mapM (maybe_fail . wantInterpretedModule) as
1480 bs' <- mapM (maybe_fail . lookupModule) bs
1481 return (catMaybes as', map contextualize (catMaybes bs'))
1483 contextualize x = (x,Nothing)
1484 deleteAllBy f a b = filter (\x->(not (any (f x) b))) a
1486 trymaybe ::GHCi a -> GHCi (Maybe a)
1490 Left _ -> return Nothing
1491 Right a -> return (Just a)
1493 ----------------------------------------------------------------------------
1496 -- set options in the interpreter. Syntax is exactly the same as the
1497 -- ghc command line, except that certain options aren't available (-C,
1500 -- This is pretty fragile: most options won't work as expected. ToDo:
1501 -- figure out which ones & disallow them.
1503 setCmd :: String -> GHCi ()
1505 = do st <- getGHCiState
1506 let opts = options st
1507 liftIO $ putStrLn (showSDoc (
1508 text "options currently set: " <>
1511 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1513 dflags <- getDynFlags
1514 liftIO $ putStrLn (showSDoc (
1515 vcat (text "GHCi-specific dynamic flag settings:"
1516 :map (flagSetting dflags) ghciFlags)
1518 liftIO $ putStrLn (showSDoc (
1519 vcat (text "other dynamic, non-language, flag settings:"
1520 :map (flagSetting dflags) others)
1522 where flagSetting dflags (str, f, _)
1523 | dopt f dflags = text " " <> text "-f" <> text str
1524 | otherwise = text " " <> text "-fno-" <> text str
1525 (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags)
1527 flags = [Opt_PrintExplicitForalls
1528 ,Opt_PrintBindResult
1529 ,Opt_BreakOnException
1531 ,Opt_PrintEvldWithShow
1534 = case getCmd str of
1535 Right ("args", rest) ->
1537 Left err -> liftIO (hPutStrLn stderr err)
1538 Right args -> setArgs args
1539 Right ("prog", rest) ->
1541 Right [prog] -> setProg prog
1542 _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")
1543 Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1544 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1545 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1546 _ -> case toArgs str of
1547 Left err -> liftIO (hPutStrLn stderr err)
1548 Right wds -> setOptions wds
1550 setArgs, setOptions :: [String] -> GHCi ()
1551 setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
1555 setGHCiState st{ args = args }
1559 setGHCiState st{ progname = prog }
1563 setGHCiState st{ editor = cmd }
1565 setStop str@(c:_) | isDigit c
1566 = do let (nm_str,rest) = break (not.isDigit) str
1569 let old_breaks = breaks st
1570 if all ((/= nm) . fst) old_breaks
1571 then printForUser (text "Breakpoint" <+> ppr nm <+>
1572 text "does not exist")
1574 let new_breaks = map fn old_breaks
1575 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1576 | otherwise = (i,loc)
1577 setGHCiState st{ breaks = new_breaks }
1580 setGHCiState st{ stop = cmd }
1582 setPrompt value = do
1585 then liftIO $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1587 '\"' : _ -> case reads value of
1588 [(value', xs)] | all isSpace xs ->
1589 setGHCiState (st { prompt = value' })
1591 liftIO $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
1592 _ -> setGHCiState (st { prompt = value })
1595 do -- first, deal with the GHCi opts (+s, +t, etc.)
1596 let (plus_opts, minus_opts) = partitionWith isPlus wds
1597 mapM_ setOpt plus_opts
1598 -- then, dynamic flags
1599 newDynFlags minus_opts
1601 newDynFlags :: [String] -> GHCi ()
1602 newDynFlags minus_opts = do
1603 dflags <- getDynFlags
1604 let pkg_flags = packageFlags dflags
1605 (dflags', leftovers, warns) <- liftIO $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
1606 liftIO $ handleFlagWarnings dflags' warns
1608 if (not (null leftovers))
1609 then ghcError . CmdLineError
1610 $ "Some flags have not been recognized: "
1611 ++ (concat . intersperse ", " $ map unLoc leftovers)
1614 new_pkgs <- setDynFlags dflags'
1616 -- if the package flags changed, we should reset the context
1617 -- and link the new packages.
1618 dflags <- getDynFlags
1619 when (packageFlags dflags /= pkg_flags) $ do
1620 liftIO $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
1622 _ <- GHC.load LoadAllTargets
1623 liftIO (linkPackages dflags new_pkgs)
1624 -- package flags changed, we can't re-use any of the old context
1625 setContextAfterLoad ([],[]) False []
1629 unsetOptions :: String -> GHCi ()
1631 = -- first, deal with the GHCi opts (+s, +t, etc.)
1632 let opts = words str
1633 (minus_opts, rest1) = partition isMinus opts
1634 (plus_opts, rest2) = partitionWith isPlus rest1
1635 (other_opts, rest3) = partition (`elem` map fst defaulters) rest2
1638 [ ("args" , setArgs default_args)
1639 , ("prog" , setProg default_progname)
1640 , ("prompt", setPrompt default_prompt)
1641 , ("editor", liftIO findEditor >>= setEditor)
1642 , ("stop" , setStop default_stop)
1645 no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1646 no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
1648 in if (not (null rest3))
1649 then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))
1651 mapM_ (fromJust.flip lookup defaulters) other_opts
1653 mapM_ unsetOpt plus_opts
1655 no_flags <- mapM no_flag minus_opts
1656 newDynFlags no_flags
1658 isMinus :: String -> Bool
1659 isMinus ('-':_) = True
1662 isPlus :: String -> Either String String
1663 isPlus ('+':opt) = Left opt
1664 isPlus other = Right other
1666 setOpt, unsetOpt :: String -> GHCi ()
1669 = case strToGHCiOpt str of
1670 Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
1671 Just o -> setOption o
1674 = case strToGHCiOpt str of
1675 Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
1676 Just o -> unsetOption o
1678 strToGHCiOpt :: String -> (Maybe GHCiOption)
1679 strToGHCiOpt "m" = Just Multiline
1680 strToGHCiOpt "s" = Just ShowTiming
1681 strToGHCiOpt "t" = Just ShowType
1682 strToGHCiOpt "r" = Just RevertCAFs
1683 strToGHCiOpt _ = Nothing
1685 optToStr :: GHCiOption -> String
1686 optToStr Multiline = "m"
1687 optToStr ShowTiming = "s"
1688 optToStr ShowType = "t"
1689 optToStr RevertCAFs = "r"
1691 -- ---------------------------------------------------------------------------
1694 showCmd :: String -> GHCi ()
1698 ["args"] -> liftIO $ putStrLn (show (args st))
1699 ["prog"] -> liftIO $ putStrLn (show (progname st))
1700 ["prompt"] -> liftIO $ putStrLn (show (prompt st))
1701 ["editor"] -> liftIO $ putStrLn (show (editor st))
1702 ["stop"] -> liftIO $ putStrLn (show (stop st))
1703 ["modules" ] -> showModules
1704 ["bindings"] -> showBindings
1705 ["linker"] -> liftIO showLinkerState
1706 ["breaks"] -> showBkptTable
1707 ["context"] -> showContext
1708 ["packages"] -> showPackages
1709 ["languages"] -> showLanguages
1710 _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
1711 " | breaks | context | packages | languages ]"))
1713 showModules :: GHCi ()
1715 loaded_mods <- getLoadedModules
1716 -- we want *loaded* modules only, see #1734
1717 let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)
1718 mapM_ show_one loaded_mods
1720 getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
1721 getLoadedModules = do
1722 graph <- GHC.getModuleGraph
1723 filterM (GHC.isLoaded . GHC.ms_mod_name) graph
1725 showBindings :: GHCi ()
1727 bindings <- GHC.getBindings
1728 docs <- pprTypeAndContents
1729 [ id | AnId id <- sortBy compareTyThings bindings]
1730 printForUserPartWay docs
1732 compareTyThings :: TyThing -> TyThing -> Ordering
1733 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1735 printTyThing :: TyThing -> GHCi ()
1736 printTyThing tyth = do dflags <- getDynFlags
1737 let pefas = dopt Opt_PrintExplicitForalls dflags
1738 printForUser (pprTyThing pefas tyth)
1740 showBkptTable :: GHCi ()
1743 printForUser $ prettyLocations (breaks st)
1745 showContext :: GHCi ()
1747 resumes <- GHC.getResumeContext
1748 printForUser $ vcat (map pp_resume (reverse resumes))
1751 ptext (sLit "--> ") <> text (GHC.resumeStmt resume)
1752 $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume))
1754 showPackages :: GHCi ()
1756 pkg_flags <- fmap packageFlags getDynFlags
1757 liftIO $ putStrLn $ showSDoc $ vcat $
1758 text ("active package flags:"++if null pkg_flags then " none" else "")
1759 : map showFlag pkg_flags
1760 where showFlag (ExposePackage p) = text $ " -package " ++ p
1761 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1762 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1763 showFlag (ExposePackageId p) = text $ " -package-id " ++ p
1765 showLanguages :: GHCi ()
1767 dflags <- getDynFlags
1768 liftIO $ putStrLn $ showSDoc $ vcat $
1769 text "active language flags:" :
1770 [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, xopt f dflags]
1772 -- -----------------------------------------------------------------------------
1775 completeCmd, completeMacro, completeIdentifier, completeModule,
1777 completeHomeModule, completeSetOptions, completeShowOptions,
1778 completeHomeModuleOrFile, completeExpression
1779 :: CompletionFunc GHCi
1781 ghciCompleteWord :: CompletionFunc GHCi
1782 ghciCompleteWord line@(left,_) = case firstWord of
1783 ':':cmd | null rest -> completeCmd line
1785 completion <- lookupCompletion cmd
1787 "import" -> completeModule line
1788 _ -> completeExpression line
1790 (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
1791 lookupCompletion ('!':_) = return completeFilename
1792 lookupCompletion c = do
1793 maybe_cmd <- liftIO $ lookupCommand' c
1795 Just (_,_,f) -> return f
1796 Nothing -> return completeFilename
1798 completeCmd = wrapCompleter " " $ \w -> do
1799 macros <- liftIO $ readIORef macros_ref
1800 let macro_names = map (':':) . map cmdName $ macros
1801 let command_names = map (':':) . map cmdName $ builtin_commands
1802 let{ candidates = case w of
1803 ':' : ':' : _ -> map (':':) command_names
1804 _ -> nub $ macro_names ++ command_names }
1805 return $ filter (w `isPrefixOf`) candidates
1807 completeMacro = wrapIdentCompleter $ \w -> do
1808 cmds <- liftIO $ readIORef macros_ref
1809 return (filter (w `isPrefixOf`) (map cmdName cmds))
1811 completeIdentifier = wrapIdentCompleter $ \w -> do
1812 rdrs <- GHC.getRdrNamesInScope
1813 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1815 completeModule = wrapIdentCompleter $ \w -> do
1816 dflags <- GHC.getSessionDynFlags
1817 let pkg_mods = allExposedModules dflags
1818 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
1819 return $ filter (w `isPrefixOf`)
1820 $ map (showSDoc.ppr) $ loaded_mods ++ pkg_mods
1822 completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
1823 modules <- case m of
1825 (toplevs, exports) <- GHC.getContext
1826 return $ map GHC.moduleName (nub (map fst exports) ++ toplevs)
1828 dflags <- GHC.getSessionDynFlags
1829 let pkg_mods = allExposedModules dflags
1830 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
1831 return $ loaded_mods ++ pkg_mods
1832 return $ filter (w `isPrefixOf`) $ map (showSDoc.ppr) modules
1834 completeHomeModule = wrapIdentCompleter listHomeModules
1836 listHomeModules :: String -> GHCi [String]
1837 listHomeModules w = do
1838 g <- GHC.getModuleGraph
1839 let home_mods = map GHC.ms_mod_name g
1840 return $ sort $ filter (w `isPrefixOf`)
1841 $ map (showSDoc.ppr) home_mods
1843 completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
1844 return (filter (w `isPrefixOf`) options)
1845 where options = "args":"prog":"prompt":"editor":"stop":flagList
1846 flagList = map head $ group $ sort allFlags
1848 completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
1849 return (filter (w `isPrefixOf`) options)
1850 where options = ["args", "prog", "prompt", "editor", "stop",
1851 "modules", "bindings", "linker", "breaks",
1852 "context", "packages", "languages"]
1854 completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
1855 $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
1858 unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
1859 unionComplete f1 f2 line = do
1864 wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
1865 wrapCompleter breakChars fun = completeWord Nothing breakChars
1866 $ fmap (map simpleCompletion) . fmap sort . fun
1868 wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
1869 wrapIdentCompleter = wrapCompleter word_break_chars
1871 wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi
1872 wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars
1873 $ \rest -> fmap (map simpleCompletion) . fmap sort . fun (getModifier rest)
1875 getModifier = find (`elem` modifChars)
1877 allExposedModules :: DynFlags -> [ModuleName]
1878 allExposedModules dflags
1879 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1881 pkg_db = pkgIdMap (pkgState dflags)
1883 completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
1886 -- ---------------------------------------------------------------------------
1887 -- User code exception handling
1889 -- This is the exception handler for exceptions generated by the
1890 -- user's code and exceptions coming from children sessions;
1891 -- it normally just prints out the exception. The
1892 -- handler must be recursive, in case showing the exception causes
1893 -- more exceptions to be raised.
1895 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1896 -- raising another exception. We therefore don't put the recursive
1897 -- handler arond the flushing operation, so if stderr is closed
1898 -- GHCi will just die gracefully rather than going into an infinite loop.
1899 handler :: SomeException -> GHCi Bool
1901 handler exception = do
1903 liftIO installSignalHandlers
1904 ghciHandle handler (showException exception >> return False)
1906 showException :: SomeException -> GHCi ()
1908 liftIO $ case fromException se of
1909 -- omit the location for CmdLineError:
1910 Just (CmdLineError s) -> putStrLn s
1912 Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
1913 Just other_ghc_ex -> print other_ghc_ex
1915 case fromException se of
1916 Just UserInterrupt -> putStrLn "Interrupted."
1917 _ -> putStrLn ("*** Exception: " ++ show se)
1919 -----------------------------------------------------------------------------
1920 -- recursive exception handlers
1922 -- Don't forget to unblock async exceptions in the handler, or if we're
1923 -- in an exception loop (eg. let a = error a in a) the ^C exception
1924 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1926 ghciHandle :: MonadException m => (SomeException -> m a) -> m a -> m a
1927 ghciHandle h m = Haskeline.catch m $ \e -> unblock (h e)
1929 ghciTry :: GHCi a -> GHCi (Either SomeException a)
1930 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
1932 -- ----------------------------------------------------------------------------
1935 -- TODO: won't work if home dir is encoded.
1936 -- (changeDirectory may not work either in that case.)
1937 expandPath :: MonadIO m => String -> InputT m String
1938 expandPath path = do
1939 exp_path <- liftIO $ expandPathIO path
1940 enc <- fmap BS.unpack $ Encoding.encode exp_path
1943 expandPathIO :: String -> IO String
1945 case dropWhile isSpace path of
1947 tilde <- getHomeDirectory -- will fail if HOME not defined
1948 return (tilde ++ '/':d)
1952 wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
1953 wantInterpretedModule str = do
1954 modl <- lookupModule str
1955 dflags <- getDynFlags
1956 when (GHC.modulePackageId modl /= thisPackage dflags) $
1957 ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
1958 is_interpreted <- GHC.moduleIsInterpreted modl
1959 when (not is_interpreted) $
1960 ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
1963 wantNameFromInterpretedModule :: GHC.GhcMonad m
1964 => (Name -> SDoc -> m ())
1968 wantNameFromInterpretedModule noCanDo str and_then =
1969 handleSourceError GHC.printException $ do
1970 names <- GHC.parseName str
1974 let modl = ASSERT( isExternalName n ) GHC.nameModule n
1975 if not (GHC.isExternalName n)
1976 then noCanDo n $ ppr n <>
1977 text " is not defined in an interpreted module"
1979 is_interpreted <- GHC.moduleIsInterpreted modl
1980 if not is_interpreted
1981 then noCanDo n $ text "module " <> ppr modl <>
1982 text " is not interpreted"
1985 -- -----------------------------------------------------------------------------
1986 -- commands for debugger
1988 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1989 sprintCmd = pprintCommand False False
1990 printCmd = pprintCommand True False
1991 forceCmd = pprintCommand False True
1993 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1994 pprintCommand bind force str = do
1995 pprintClosureCommand bind force str
1997 stepCmd :: String -> GHCi ()
1998 stepCmd [] = doContinue (const True) GHC.SingleStep
1999 stepCmd expression = runStmt expression GHC.SingleStep >> return ()
2001 stepLocalCmd :: String -> GHCi ()
2002 stepLocalCmd [] = do
2003 mb_span <- getCurrentBreakSpan
2005 Nothing -> stepCmd []
2007 Just mod <- getCurrentBreakModule
2008 current_toplevel_decl <- enclosingTickSpan mod loc
2009 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
2011 stepLocalCmd expression = stepCmd expression
2013 stepModuleCmd :: String -> GHCi ()
2014 stepModuleCmd [] = do
2015 mb_span <- getCurrentBreakSpan
2017 Nothing -> stepCmd []
2019 Just span <- getCurrentBreakSpan
2020 let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span
2021 doContinue f GHC.SingleStep
2023 stepModuleCmd expression = stepCmd expression
2025 -- | Returns the span of the largest tick containing the srcspan given
2026 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
2027 enclosingTickSpan mod src = do
2028 ticks <- getTickArray mod
2029 let line = srcSpanStartLine src
2030 ASSERT (inRange (bounds ticks) line) do
2031 let enclosing_spans = [ span | (_,span) <- ticks ! line
2032 , srcSpanEnd span >= srcSpanEnd src]
2033 return . head . sortBy leftmost_largest $ enclosing_spans
2035 traceCmd :: String -> GHCi ()
2036 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
2037 traceCmd expression = runStmt expression GHC.RunAndLogSteps >> return ()
2039 continueCmd :: String -> GHCi ()
2040 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
2042 -- doContinue :: SingleStep -> GHCi ()
2043 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
2044 doContinue pred step = do
2045 runResult <- resume pred step
2046 _ <- afterRunStmt pred runResult
2049 abandonCmd :: String -> GHCi ()
2050 abandonCmd = noArgs $ do
2051 b <- GHC.abandon -- the prompt will change to indicate the new context
2052 when (not b) $ liftIO $ putStrLn "There is no computation running."
2054 deleteCmd :: String -> GHCi ()
2055 deleteCmd argLine = do
2056 deleteSwitch $ words argLine
2058 deleteSwitch :: [String] -> GHCi ()
2060 liftIO $ putStrLn "The delete command requires at least one argument."
2061 -- delete all break points
2062 deleteSwitch ("*":_rest) = discardActiveBreakPoints
2063 deleteSwitch idents = do
2064 mapM_ deleteOneBreak idents
2066 deleteOneBreak :: String -> GHCi ()
2068 | all isDigit str = deleteBreak (read str)
2069 | otherwise = return ()
2071 historyCmd :: String -> GHCi ()
2073 | null arg = history 20
2074 | all isDigit arg = history (read arg)
2075 | otherwise = liftIO $ putStrLn "Syntax: :history [num]"
2078 resumes <- GHC.getResumeContext
2080 [] -> liftIO $ putStrLn "Not stopped at a breakpoint"
2082 let hist = GHC.resumeHistory r
2083 (took,rest) = splitAt num hist
2085 [] -> liftIO $ putStrLn $
2086 "Empty history. Perhaps you forgot to use :trace?"
2088 spans <- mapM GHC.getHistorySpan took
2089 let nums = map (printf "-%-3d:") [(1::Int)..]
2090 names = map GHC.historyEnclosingDecls took
2091 printForUser (vcat(zipWith3
2092 (\x y z -> x <+> y <+> z)
2094 (map (bold . hcat . punctuate colon . map text) names)
2095 (map (parens . ppr) spans)))
2096 liftIO $ putStrLn $ if null rest then "<end of history>" else "..."
2098 bold :: SDoc -> SDoc
2099 bold c | do_bold = text start_bold <> c <> text end_bold
2102 backCmd :: String -> GHCi ()
2103 backCmd = noArgs $ do
2104 (names, _, span) <- GHC.back
2105 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span
2106 printTypeOfNames names
2107 -- run the command set with ":set stop <cmd>"
2109 enqueueCommands [stop st]
2111 forwardCmd :: String -> GHCi ()
2112 forwardCmd = noArgs $ do
2113 (names, ix, span) <- GHC.forward
2114 printForUser $ (if (ix == 0)
2115 then ptext (sLit "Stopped at")
2116 else ptext (sLit "Logged breakpoint at")) <+> ppr span
2117 printTypeOfNames names
2118 -- run the command set with ":set stop <cmd>"
2120 enqueueCommands [stop st]
2122 -- handle the "break" command
2123 breakCmd :: String -> GHCi ()
2124 breakCmd argLine = do
2125 breakSwitch $ words argLine
2127 breakSwitch :: [String] -> GHCi ()
2129 liftIO $ putStrLn "The break command requires at least one argument."
2130 breakSwitch (arg1:rest)
2131 | looksLikeModuleName arg1 && not (null rest) = do
2132 mod <- wantInterpretedModule arg1
2133 breakByModule mod rest
2134 | all isDigit arg1 = do
2135 (toplevel, _) <- GHC.getContext
2137 (mod : _) -> breakByModuleLine mod (read arg1) rest
2139 liftIO $ putStrLn "Cannot find default module for breakpoint."
2140 liftIO $ putStrLn "Perhaps no modules are loaded for debugging?"
2141 | otherwise = do -- try parsing it as an identifier
2142 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
2143 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2144 if GHC.isGoodSrcLoc loc
2145 then ASSERT( isExternalName name )
2146 findBreakAndSet (GHC.nameModule name) $
2147 findBreakByCoord (Just (GHC.srcLocFile loc))
2148 (GHC.srcLocLine loc,
2150 else noCanDo name $ text "can't find its location: " <> ppr loc
2152 noCanDo n why = printForUser $
2153 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
2155 breakByModule :: Module -> [String] -> GHCi ()
2156 breakByModule mod (arg1:rest)
2157 | all isDigit arg1 = do -- looks like a line number
2158 breakByModuleLine mod (read arg1) rest
2162 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
2163 breakByModuleLine mod line args
2164 | [] <- args = findBreakAndSet mod $ findBreakByLine line
2165 | [col] <- args, all isDigit col =
2166 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
2167 | otherwise = breakSyntax
2170 breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
2172 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
2173 findBreakAndSet mod lookupTickTree = do
2174 tickArray <- getTickArray mod
2175 (breakArray, _) <- getModBreak mod
2176 case lookupTickTree tickArray of
2177 Nothing -> liftIO $ putStrLn $ "No breakpoints found at that location."
2178 Just (tick, span) -> do
2179 success <- liftIO $ setBreakFlag True breakArray tick
2183 recordBreak $ BreakLocation
2190 text "Breakpoint " <> ppr nm <>
2192 then text " was already set at " <> ppr span
2193 else text " activated at " <> ppr span
2195 printForUser $ text "Breakpoint could not be activated at"
2198 -- When a line number is specified, the current policy for choosing
2199 -- the best breakpoint is this:
2200 -- - the leftmost complete subexpression on the specified line, or
2201 -- - the leftmost subexpression starting on the specified line, or
2202 -- - the rightmost subexpression enclosing the specified line
2204 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2205 findBreakByLine line arr
2206 | not (inRange (bounds arr) line) = Nothing
2208 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
2209 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2210 listToMaybe (sortBy (rightmost `on` snd) ticks)
2214 starts_here = [ tick | tick@(_,span) <- ticks,
2215 GHC.srcSpanStartLine span == line ]
2217 (complete,incomplete) = partition ends_here starts_here
2218 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2220 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2221 -> Maybe (BreakIndex,SrcSpan)
2222 findBreakByCoord mb_file (line, col) arr
2223 | not (inRange (bounds arr) line) = Nothing
2225 listToMaybe (sortBy (rightmost `on` snd) contains ++
2226 sortBy (leftmost_smallest `on` snd) after_here)
2230 -- the ticks that span this coordinate
2231 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2232 is_correct_file span ]
2234 is_correct_file span
2235 | Just f <- mb_file = GHC.srcSpanFile span == f
2238 after_here = [ tick | tick@(_,span) <- ticks,
2239 GHC.srcSpanStartLine span == line,
2240 GHC.srcSpanStartCol span >= col ]
2242 -- For now, use ANSI bold on terminals that we know support it.
2243 -- Otherwise, we add a line of carets under the active expression instead.
2244 -- In particular, on Windows and when running the testsuite (which sets
2245 -- TERM to vt100 for other reasons) we get carets.
2246 -- We really ought to use a proper termcap/terminfo library.
2248 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2249 where mTerm = System.Environment.getEnv "TERM"
2250 `catchIO` \_ -> return "TERM not set"
2252 start_bold :: String
2253 start_bold = "\ESC[1m"
2255 end_bold = "\ESC[0m"
2257 listCmd :: String -> InputT GHCi ()
2258 listCmd c = listCmd' c
2260 listCmd' :: String -> InputT GHCi ()
2262 mb_span <- lift getCurrentBreakSpan
2265 printForUser $ text "Not stopped at a breakpoint; nothing to list"
2267 | GHC.isGoodSrcSpan span -> listAround span True
2269 do resumes <- GHC.getResumeContext
2271 [] -> panic "No resumes"
2273 do let traceIt = case GHC.resumeHistory r of
2274 [] -> text "rerunning with :trace,"
2276 doWhat = traceIt <+> text ":back then :list"
2277 printForUser (text "Unable to list source for" <+>
2279 $$ text "Try" <+> doWhat)
2280 listCmd' str = list2 (words str)
2282 list2 :: [String] -> InputT GHCi ()
2283 list2 [arg] | all isDigit arg = do
2284 (toplevel, _) <- GHC.getContext
2286 [] -> liftIO $ putStrLn "No module to list"
2287 (mod : _) -> listModuleLine mod (read arg)
2288 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2289 mod <- wantInterpretedModule arg1
2290 listModuleLine mod (read arg2)
2292 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2293 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2294 if GHC.isGoodSrcLoc loc
2296 tickArray <- ASSERT( isExternalName name )
2297 lift $ getTickArray (GHC.nameModule name)
2298 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2299 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2302 Nothing -> listAround (GHC.srcLocSpan loc) False
2303 Just (_,span) -> listAround span False
2305 noCanDo name $ text "can't find its location: " <>
2308 noCanDo n why = printForUser $
2309 text "cannot list source code for " <> ppr n <> text ": " <> why
2311 liftIO $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2313 listModuleLine :: Module -> Int -> InputT GHCi ()
2314 listModuleLine modl line = do
2315 graph <- GHC.getModuleGraph
2316 let this = filter ((== modl) . GHC.ms_mod) graph
2318 [] -> panic "listModuleLine"
2320 let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
2321 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2322 listAround (GHC.srcLocSpan loc) False
2324 -- | list a section of a source file around a particular SrcSpan.
2325 -- If the highlight flag is True, also highlight the span using
2326 -- start_bold\/end_bold.
2328 -- GHC files are UTF-8, so we can implement this by:
2329 -- 1) read the file in as a BS and syntax highlight it as before
2330 -- 2) convert the BS to String using utf-string, and write it out.
2331 -- It would be better if we could convert directly between UTF-8 and the
2332 -- console encoding, of course.
2333 listAround :: MonadIO m => SrcSpan -> Bool -> InputT m ()
2334 listAround span do_highlight = do
2335 contents <- liftIO $ BS.readFile (unpackFS file)
2337 lines = BS.split '\n' contents
2338 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2339 drop (line1 - 1 - pad_before) $ lines
2340 fst_line = max 1 (line1 - pad_before)
2341 line_nos = [ fst_line .. ]
2343 highlighted | do_highlight = zipWith highlight line_nos these_lines
2344 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2346 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2347 prefixed = zipWith ($) highlighted bs_line_nos
2349 let output = BS.intercalate (BS.pack "\n") prefixed
2350 utf8Decoded <- liftIO $ BS.useAsCStringLen output
2351 $ \(p,n) -> utf8DecodeString (castPtr p) n
2352 liftIO $ putStrLn utf8Decoded
2354 file = GHC.srcSpanFile span
2355 line1 = GHC.srcSpanStartLine span
2356 col1 = GHC.srcSpanStartCol span - 1
2357 line2 = GHC.srcSpanEndLine span
2358 col2 = GHC.srcSpanEndCol span - 1
2360 pad_before | line1 == 1 = 0
2364 highlight | do_bold = highlight_bold
2365 | otherwise = highlight_carets
2367 highlight_bold no line prefix
2368 | no == line1 && no == line2
2369 = let (a,r) = BS.splitAt col1 line
2370 (b,c) = BS.splitAt (col2-col1) r
2372 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2374 = let (a,b) = BS.splitAt col1 line in
2375 BS.concat [prefix, a, BS.pack start_bold, b]
2377 = let (a,b) = BS.splitAt col2 line in
2378 BS.concat [prefix, a, BS.pack end_bold, b]
2379 | otherwise = BS.concat [prefix, line]
2381 highlight_carets no line prefix
2382 | no == line1 && no == line2
2383 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2384 BS.replicate (col2-col1) '^']
2386 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2389 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2391 | otherwise = BS.concat [prefix, line]
2393 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2394 nl = BS.singleton '\n'
2396 -- --------------------------------------------------------------------------
2399 getTickArray :: Module -> GHCi TickArray
2400 getTickArray modl = do
2402 let arrmap = tickarrays st
2403 case lookupModuleEnv arrmap modl of
2404 Just arr -> return arr
2406 (_breakArray, ticks) <- getModBreak modl
2407 let arr = mkTickArray (assocs ticks)
2408 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2411 discardTickArrays :: GHCi ()
2412 discardTickArrays = do
2414 setGHCiState st{tickarrays = emptyModuleEnv}
2416 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2418 = accumArray (flip (:)) [] (1, max_line)
2419 [ (line, (nm,span)) | (nm,span) <- ticks,
2420 line <- srcSpanLines span ]
2422 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2423 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2424 GHC.srcSpanEndLine span ]
2426 lookupModule :: GHC.GhcMonad m => String -> m Module
2427 lookupModule modName
2428 = GHC.lookupModule (GHC.mkModuleName modName) Nothing
2430 -- don't reset the counter back to zero?
2431 discardActiveBreakPoints :: GHCi ()
2432 discardActiveBreakPoints = do
2434 mapM_ (turnOffBreak.snd) (breaks st)
2435 setGHCiState $ st { breaks = [] }
2437 deleteBreak :: Int -> GHCi ()
2438 deleteBreak identity = do
2440 let oldLocations = breaks st
2441 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2443 then printForUser (text "Breakpoint" <+> ppr identity <+>
2444 text "does not exist")
2446 mapM_ (turnOffBreak.snd) this
2447 setGHCiState $ st { breaks = rest }
2449 turnOffBreak :: BreakLocation -> GHCi Bool
2450 turnOffBreak loc = do
2451 (arr, _) <- getModBreak (breakModule loc)
2452 liftIO $ setBreakFlag False arr (breakTick loc)
2454 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2455 getModBreak mod = do
2456 Just mod_info <- GHC.getModuleInfo mod
2457 let modBreaks = GHC.modInfoModBreaks mod_info
2458 let array = GHC.modBreaks_flags modBreaks
2459 let ticks = GHC.modBreaks_locs modBreaks
2460 return (array, ticks)
2462 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2463 setBreakFlag toggle array index
2464 | toggle = GHC.setBreakOn array index
2465 | otherwise = GHC.setBreakOff array index