1 {-# OPTIONS -fno-cse #-}
2 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
4 {-# OPTIONS -#include "Linker.h" #-}
5 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
6 -----------------------------------------------------------------------------
8 -- GHC Interactive User Interface
10 -- (c) The GHC Team 2005-2006
12 -----------------------------------------------------------------------------
14 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
16 #include "HsVersions.h"
18 import qualified GhciMonad
19 import GhciMonad hiding (runStmt)
24 import qualified GHC hiding (resume, runStmt)
25 import GHC ( LoadHowMuch(..), Target(..), TargetId(..),
27 BreakIndex, Resume, SingleStep,
28 Ghc, handleSourceError )
33 -- import PackageConfig
36 import HscTypes ( implicitTyThings, handleFlagWarnings )
37 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
38 import Outputable hiding (printForUser, printForUserPartWay)
39 import Module -- for ModuleEnv
43 -- Other random utilities
46 import BasicTypes hiding (isTopLevel)
47 import Panic hiding (showException)
53 import Maybes ( orElse, expectJust )
58 #ifndef mingw32_HOST_OS
59 import System.Posix hiding (getEnv)
61 import qualified System.Win32
64 import System.Console.Haskeline as Haskeline
65 import qualified System.Console.Haskeline.Encoding as Encoding
66 import Control.Monad.Trans
70 import Exception hiding (catch, block, unblock)
72 -- import Control.Concurrent
74 import System.FilePath
75 import qualified Data.ByteString.Char8 as BS
79 import System.Environment
80 import System.Exit ( exitWith, ExitCode(..) )
81 import System.Directory
83 import System.IO.Error as IO
86 import Control.Monad as Monad
89 import GHC.Exts ( unsafeCoerce# )
91 #if __GLASGOW_HASKELL__ >= 611
92 import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
93 import GHC.IO.Handle ( hFlushAll )
95 import GHC.IOBase ( IOErrorType(InvalidArgument) )
100 import Data.IORef ( IORef, readIORef, writeIORef )
102 -----------------------------------------------------------------------------
104 ghciWelcomeMsg :: String
105 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
106 ": http://www.haskell.org/ghc/ :? for help"
108 cmdName :: Command -> String
111 GLOBAL_VAR(macros_ref, [], [Command])
113 builtin_commands :: [Command]
115 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
116 ("?", keepGoing help, noCompletion),
117 ("add", keepGoingPaths addModule, completeFilename),
118 ("abandon", keepGoing abandonCmd, noCompletion),
119 ("break", keepGoing breakCmd, completeIdentifier),
120 ("back", keepGoing backCmd, noCompletion),
121 ("browse", keepGoing' (browseCmd False), completeModule),
122 ("browse!", keepGoing' (browseCmd True), completeModule),
123 ("cd", keepGoing' changeDirectory, completeFilename),
124 ("check", keepGoing' checkModule, completeHomeModule),
125 ("continue", keepGoing continueCmd, noCompletion),
126 ("cmd", keepGoing cmdCmd, completeExpression),
127 ("ctags", keepGoing createCTagsFileCmd, completeFilename),
128 ("def", keepGoing (defineMacro False), completeExpression),
129 ("def!", keepGoing (defineMacro True), completeExpression),
130 ("delete", keepGoing deleteCmd, noCompletion),
131 ("e", keepGoing editFile, completeFilename),
132 ("edit", keepGoing editFile, completeFilename),
133 ("etags", keepGoing createETagsFileCmd, completeFilename),
134 ("force", keepGoing forceCmd, completeExpression),
135 ("forward", keepGoing forwardCmd, noCompletion),
136 ("help", keepGoing help, noCompletion),
137 ("history", keepGoing historyCmd, noCompletion),
138 ("info", keepGoing' info, completeIdentifier),
139 ("kind", keepGoing' kindOfType, completeIdentifier),
140 ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),
141 ("list", keepGoing' listCmd, noCompletion),
142 ("module", keepGoing setContext, completeModule),
143 ("main", keepGoing runMain, completeFilename),
144 ("print", keepGoing printCmd, completeExpression),
145 ("quit", quit, noCompletion),
146 ("reload", keepGoing' reloadModule, noCompletion),
147 ("run", keepGoing runRun, completeFilename),
148 ("set", keepGoing setCmd, completeSetOptions),
149 ("show", keepGoing showCmd, completeShowOptions),
150 ("sprint", keepGoing sprintCmd, completeExpression),
151 ("step", keepGoing stepCmd, completeIdentifier),
152 ("steplocal", keepGoing stepLocalCmd, completeIdentifier),
153 ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),
154 ("type", keepGoing' typeOfExpr, completeExpression),
155 ("trace", keepGoing traceCmd, completeExpression),
156 ("undef", keepGoing undefineMacro, completeMacro),
157 ("unset", keepGoing unsetOptions, completeSetOptions)
161 -- We initialize readline (in the interactiveUI function) to use
162 -- word_break_chars as the default set of completion word break characters.
163 -- This can be overridden for a particular command (for example, filename
164 -- expansion shouldn't consider '/' to be a word break) by setting the third
165 -- entry in the Command tuple above.
167 -- NOTE: in order for us to override the default correctly, any custom entry
168 -- must be a SUBSET of word_break_chars.
169 word_break_chars :: String
170 word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
171 specials = "(),;[]`{}"
173 in spaces ++ specials ++ symbols
175 flagWordBreakChars :: String
176 flagWordBreakChars = " \t\n"
179 keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)
180 keepGoing a str = keepGoing' (lift . a) str
182 keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool
183 keepGoing' a str = a str >> return False
185 keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
187 = do case toArgs str of
188 Left err -> Encoding.encode err >>= liftIO . BS.hPutStrLn stderr
192 shortHelpText :: String
193 shortHelpText = "use :? for help.\n"
197 " Commands available from the prompt:\n" ++
199 " <statement> evaluate/run <statement>\n" ++
200 " : repeat last command\n" ++
201 " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
202 " :add [*]<module> ... add module(s) to the current target set\n" ++
203 " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
204 " (!: more details; *: all top-level names)\n" ++
205 " :cd <dir> change directory to <dir>\n" ++
206 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
207 " :ctags [<file>] create tags file for Vi (default: \"tags\")\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 " :type <expr> show the type of <expr>\n" ++
222 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
223 " :!<command> run the shell command <command>\n" ++
225 " -- Commands for debugging:\n" ++
227 " :abandon at a breakpoint, abandon current computation\n" ++
228 " :back go back in the history (after :trace)\n" ++
229 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
230 " :break <name> set a breakpoint on the specified function\n" ++
231 " :continue resume after a breakpoint\n" ++
232 " :delete <number> delete the specified breakpoint\n" ++
233 " :delete * delete all breakpoints\n" ++
234 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
235 " :forward go forward in the history (after :back)\n" ++
236 " :history [<n>] after :trace, show the execution history\n" ++
237 " :list show the source code around current breakpoint\n" ++
238 " :list identifier show the source code for <identifier>\n" ++
239 " :list [<module>] <line> show the source code around line number <line>\n" ++
240 " :print [<name> ...] prints a value without forcing its computation\n" ++
241 " :sprint [<name> ...] simplifed version of :print\n" ++
242 " :step single-step after stopping at a breakpoint\n"++
243 " :step <expr> single-step into <expr>\n"++
244 " :steplocal single-step within the current top-level binding\n"++
245 " :stepmodule single-step restricted to the current module\n"++
246 " :trace trace after stopping at a breakpoint\n"++
247 " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++
250 " -- Commands for changing settings:\n" ++
252 " :set <option> ... set options\n" ++
253 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
254 " :set prog <progname> set the value returned by System.getProgName\n" ++
255 " :set prompt <prompt> set the prompt used in GHCi\n" ++
256 " :set editor <cmd> set the command used for :edit\n" ++
257 " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" ++
258 " :unset <option> ... unset options\n" ++
260 " Options for ':set' and ':unset':\n" ++
262 " +r revert top-level expressions after each evaluation\n" ++
263 " +s print timing/memory stats after each evaluation\n" ++
264 " +t print type after evaluation\n" ++
265 " -<flags> most GHC command line flags can also be set here\n" ++
266 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
267 " for GHCi-specific flags, see User's Guide,\n"++
268 " Flag reference, Interactive-mode options\n" ++
270 " -- Commands for displaying information:\n" ++
272 " :show bindings show the current bindings made at the prompt\n" ++
273 " :show breaks show the active breakpoints\n" ++
274 " :show context show the breakpoint context\n" ++
275 " :show modules show the currently loaded modules\n" ++
276 " :show packages show the currently active package flags\n" ++
277 " :show languages show the currently active language flags\n" ++
278 " :show <setting> show value of <setting>, which is one of\n" ++
279 " [args, prog, prompt, editor, stop]\n" ++
282 findEditor :: IO String
287 win <- System.Win32.getWindowsDirectory
288 return (win </> "notepad.exe")
293 foreign import ccall unsafe "rts_isProfiled" isProfiled :: IO CInt
295 interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String]
297 interactiveUI srcs maybe_exprs = do
298 -- although GHCi compiles with -prof, it is not usable: the byte-code
299 -- compiler and interpreter don't work with profiling. So we check for
300 -- this up front and emit a helpful error message (#2197)
301 i <- liftIO $ isProfiled
303 ghcError (InstallationError "GHCi cannot be used when compiled with -prof")
305 -- HACK! If we happen to get into an infinite loop (eg the user
306 -- types 'let x=x in x' at the prompt), then the thread will block
307 -- on a blackhole, and become unreachable during GC. The GC will
308 -- detect that it is unreachable and send it the NonTermination
309 -- exception. However, since the thread is unreachable, everything
310 -- it refers to might be finalized, including the standard Handles.
311 -- This sounds like a bug, but we don't have a good solution right
313 _ <- liftIO $ newStablePtr stdin
314 _ <- liftIO $ newStablePtr stdout
315 _ <- liftIO $ newStablePtr stderr
317 -- Initialise buffering for the *interpreted* I/O system
320 liftIO $ when (isNothing maybe_exprs) $ do
321 -- Only for GHCi (not runghc and ghc -e):
323 -- Turn buffering off for the compiled program's stdout/stderr
325 -- Turn buffering off for GHCi's stdout
327 hSetBuffering stdout NoBuffering
328 -- We don't want the cmd line to buffer any input that might be
329 -- intended for the program, so unbuffer stdin.
330 hSetBuffering stdin NoBuffering
331 #if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611
332 -- On Unix, stdin will use the locale encoding. The IO library
333 -- doesn't do this on Windows (yet), so for now we use UTF-8,
334 -- for consistency with GHC 6.10 and to make the tests work.
335 hSetEncoding stdin utf8
338 -- initial context is just the Prelude
339 prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing
340 GHC.setContext [] [prel_mod]
342 default_editor <- liftIO $ findEditor
344 startGHCi (runGHCi srcs maybe_exprs)
345 GHCiState{ progname = "<interactive>",
349 editor = default_editor,
350 -- session = session,
355 tickarrays = emptyModuleEnv,
356 last_command = Nothing,
359 ghc_e = isJust maybe_exprs
364 withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
365 withGhcAppData right left = do
366 either_dir <- IO.try (getAppUserDataDirectory "ghc")
368 Right dir -> right dir
371 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
372 runGHCi paths maybe_exprs = do
374 read_dot_files = not opt_IgnoreDotGhci
376 current_dir = return (Just ".ghci")
378 app_user_dir = io $ withGhcAppData
379 (\dir -> return (Just (dir </> "ghci.conf")))
383 either_dir <- io $ IO.try (getEnv "HOME")
385 Right home -> return (Just (home </> ".ghci"))
388 sourceConfigFile :: FilePath -> GHCi ()
389 sourceConfigFile file = do
390 exists <- io $ doesFileExist file
392 dir_ok <- io $ checkPerms (getDirectory file)
393 file_ok <- io $ checkPerms file
394 when (dir_ok && file_ok) $ do
395 either_hdl <- io $ IO.try (openFile file ReadMode)
398 -- NOTE: this assumes that runInputT won't affect the terminal;
399 -- can we assume this will always be the case?
400 -- This would be a good place for runFileInputT.
401 Right hdl -> runInputTWithPrefs defaultPrefs defaultSettings $ do
403 runCommands $ fileLoop hdl
405 getDirectory f = case takeDirectory f of "" -> "."; d -> d
407 when (read_dot_files) $ do
408 cfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
409 cfgs <- io $ mapM canonicalizePath (catMaybes cfgs0)
410 mapM_ sourceConfigFile (nub cfgs)
411 -- nub, because we don't want to read .ghci twice if the
414 -- Perform a :load for files given on the GHCi command line
415 -- When in -e mode, if the load fails then we want to stop
416 -- immediately rather than going on to evaluate the expression.
417 when (not (null paths)) $ do
418 ok <- ghciHandle (\e -> do showException e; return Failed) $
419 -- TODO: this is a hack.
420 runInputTWithPrefs defaultPrefs defaultSettings $ do
421 let (filePaths, phases) = unzip paths
422 filePaths' <- mapM (Encoding.decode . BS.pack) filePaths
423 loadModule (zip filePaths' phases)
424 when (isJust maybe_exprs && failed ok) $
425 io (exitWith (ExitFailure 1))
427 -- if verbosity is greater than 0, or we are connected to a
428 -- terminal, display the prompt in the interactive loop.
429 is_tty <- io (hIsTerminalDevice stdin)
430 dflags <- getDynFlags
431 let show_prompt = verbosity dflags > 0 || is_tty
436 -- enter the interactive loop
437 runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
439 -- just evaluate the expression we were given
440 enqueueCommands exprs
441 let handle e = do st <- getGHCiState
442 -- Jump through some hoops to get the
443 -- current progname in the exception text:
444 -- <progname>: <exception>
445 io $ withProgName (progname st)
446 -- this used to be topHandlerFastExit, see #2228
448 runInputTWithPrefs defaultPrefs defaultSettings $ do
450 runCommands' handle (return Nothing)
453 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
455 runGHCiInput :: InputT GHCi a -> GHCi a
457 histFile <- io $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
459 let settings = setComplete ghciCompleteWord
460 $ defaultSettings {historyFile = histFile}
461 runInputT settings $ do
465 nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
466 nextInputLine show_prompt is_tty
468 prompt <- if show_prompt then lift mkPrompt else return ""
471 when show_prompt $ lift mkPrompt >>= liftIO . putStr
474 -- NOTE: We only read .ghci files if they are owned by the current user,
475 -- and aren't world writable. Otherwise, we could be accidentally
476 -- running code planted by a malicious third party.
478 -- Furthermore, We only read ./.ghci if . is owned by the current user
479 -- and isn't writable by anyone else. I think this is sufficient: we
480 -- don't need to check .. and ../.. etc. because "." always refers to
481 -- the same directory while a process is running.
483 checkPerms :: String -> IO Bool
484 #ifdef mingw32_HOST_OS
489 handleIO (\_ -> return False) $ do
490 st <- getFileStatus name
492 if fileOwner st /= me then do
493 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
496 let mode = fileMode st
497 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
498 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
500 putStrLn $ "*** WARNING: " ++ name ++
501 " is writable by someone else, IGNORING!"
506 fileLoop :: MonadIO m => Handle -> InputT m (Maybe String)
508 l <- liftIO $ IO.try $ hGetLine hdl
510 Left e | isEOFError e -> return Nothing
511 | InvalidArgument <- etype -> return Nothing
512 | otherwise -> liftIO $ ioError e
513 where etype = ioeGetErrorType e
514 -- treat InvalidArgument in the same way as EOF:
515 -- this can happen if the user closed stdin, or
516 -- perhaps did getContents which closes stdin at
518 Right l -> return (Just l)
520 mkPrompt :: GHCi String
522 (toplevs,exports) <- GHC.getContext
523 resumes <- GHC.getResumeContext
524 -- st <- getGHCiState
530 let ix = GHC.resumeHistoryIx r
532 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
534 let hist = GHC.resumeHistory r !! (ix-1)
535 span <- GHC.getHistorySpan hist
536 return (brackets (ppr (negate ix) <> char ':'
537 <+> ppr span) <> space)
539 dots | _:rs <- resumes, not (null rs) = text "... "
546 -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
547 -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
548 -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
549 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
550 hsep (map (ppr . GHC.moduleName) exports)
552 deflt_prompt = dots <> context_bit <> modules_bit
554 f ('%':'s':xs) = deflt_prompt <> f xs
555 f ('%':'%':xs) = char '%' <> f xs
556 f (x:xs) = char x <> f xs
560 return (showSDoc (f (prompt st)))
563 queryQueue :: GHCi (Maybe String)
568 c:cs -> do setGHCiState st{ cmdqueue = cs }
571 runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
572 runCommands = runCommands' handler
574 runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
575 -> InputT GHCi (Maybe String) -> InputT GHCi ()
576 runCommands' eh getCmd = do
577 b <- handleGhcException (\e -> case e of
578 Interrupted -> return False
579 _other -> liftIO (print e) >> return True)
580 (runOneCommand eh getCmd)
581 if b then return () else runCommands' eh getCmd
583 runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
585 runOneCommand eh getCmd = do
586 mb_cmd <- noSpace (lift queryQueue)
587 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
589 Nothing -> return True
590 Just c -> ghciHandle (lift . eh) $
591 handleSourceError printErrorAndKeepGoing
594 printErrorAndKeepGoing err = do
595 GHC.printExceptionAndWarnings err
598 noSpace q = q >>= maybe (return Nothing)
599 (\c->case removeSpaces c of
601 ":{" -> multiLineCmd q
602 c -> return (Just c) )
604 st <- lift getGHCiState
606 lift $ setGHCiState st{ prompt = "%s| " }
607 mb_cmd <- collectCommand q ""
608 lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p }
610 -- we can't use removeSpaces for the sublines here, so
611 -- multiline commands are somewhat more brittle against
612 -- fileformat errors (such as \r in dos input on unix),
613 -- we get rid of any extra spaces for the ":}" test;
614 -- we also avoid silent failure if ":}" is not found;
615 -- and since there is no (?) valid occurrence of \r (as
616 -- opposed to its String representation, "\r") inside a
617 -- ghci command, we replace any such with ' ' (argh:-(
618 collectCommand q c = q >>=
619 maybe (liftIO (ioError collectError))
620 (\l->if removeSpaces l == ":}"
621 then return (Just $ removeSpaces c)
622 else collectCommand q (c++map normSpace l))
623 where normSpace '\r' = ' '
625 -- QUESTION: is userError the one to use here?
626 collectError = userError "unterminated multiline command :{ .. :}"
627 doCommand (':' : cmd) = specialCommand cmd
628 doCommand stmt = do _ <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion
631 enqueueCommands :: [String] -> GHCi ()
632 enqueueCommands cmds = do
634 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
637 runStmt :: String -> SingleStep -> GHCi Bool
639 | null (filter (not.isSpace) stmt) = return False
640 | ["import", mod] <- words stmt = keepGoing' setContext ('+':mod)
643 #if __GLASGOW_HASKELL__ >= 611
644 -- In the new IO library, read handles buffer data even if the Handle
645 -- is set to NoBuffering. This causes problems for GHCi where there
646 -- are really two stdin Handles. So we flush any bufferred data in
647 -- GHCi's stdin Handle here (only relevant if stdin is attached to
648 -- a file, otherwise the read buffer can't be flushed).
649 _ <- liftIO $ IO.try $ hFlushAll stdin
651 result <- GhciMonad.runStmt stmt step
652 afterRunStmt (const True) result
654 --afterRunStmt :: GHC.RunResult -> GHCi Bool
655 -- False <=> the statement failed to compile
656 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
657 afterRunStmt _ (GHC.RunException e) = throw e
658 afterRunStmt step_here run_result = do
659 resumes <- GHC.getResumeContext
661 GHC.RunOk names -> do
662 show_types <- isOptionSet ShowType
663 when show_types $ printTypeOfNames names
664 GHC.RunBreak _ names mb_info
665 | isNothing mb_info ||
666 step_here (GHC.resumeSpan $ head resumes) -> do
667 mb_id_loc <- toBreakIdAndLocation mb_info
668 let breakCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
670 then printStoppedAtBreakInfo (head resumes) names
671 else enqueueCommands [breakCmd]
672 -- run the command set with ":set stop <cmd>"
674 enqueueCommands [stop st]
676 | otherwise -> resume step_here GHC.SingleStep >>=
677 afterRunStmt step_here >> return ()
681 io installSignalHandlers
682 b <- isOptionSet RevertCAFs
685 return (case run_result of GHC.RunOk _ -> True; _ -> False)
687 toBreakIdAndLocation ::
688 Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
689 toBreakIdAndLocation Nothing = return Nothing
690 toBreakIdAndLocation (Just info) = do
691 let mod = GHC.breakInfo_module info
692 nm = GHC.breakInfo_number info
694 return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
695 breakModule loc == mod,
696 breakTick loc == nm ]
698 printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
699 printStoppedAtBreakInfo resume names = do
700 printForUser $ ptext (sLit "Stopped at") <+>
701 ppr (GHC.resumeSpan resume)
702 -- printTypeOfNames session names
703 let namesSorted = sortBy compareNames names
704 tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
705 docs <- pprTypeAndContents [id | AnId id <- tythings]
706 printForUserPartWay docs
708 printTypeOfNames :: [Name] -> GHCi ()
709 printTypeOfNames names
710 = mapM_ (printTypeOfName ) $ sortBy compareNames names
712 compareNames :: Name -> Name -> Ordering
713 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
714 where compareWith n = (getOccString n, getSrcSpan n)
716 printTypeOfName :: Name -> GHCi ()
718 = do maybe_tything <- GHC.lookupName n
719 case maybe_tything of
721 Just thing -> printTyThing thing
724 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
726 specialCommand :: String -> InputT GHCi Bool
727 specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
728 specialCommand str = do
729 let (cmd,rest) = break isSpace str
730 maybe_cmd <- lift $ lookupCommand cmd
732 GotCommand (_,f,_) -> f (dropWhile isSpace rest)
734 do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
738 do liftIO $ hPutStr stdout ("there is no last command to perform\n"
742 lookupCommand :: String -> GHCi (MaybeCommand)
743 lookupCommand "" = do
745 case last_command st of
746 Just c -> return $ GotCommand c
747 Nothing -> return NoLastCommand
748 lookupCommand str = do
749 mc <- io $ lookupCommand' str
751 setGHCiState st{ last_command = mc }
753 Just c -> GotCommand c
754 Nothing -> BadCommand
756 lookupCommand' :: String -> IO (Maybe Command)
757 lookupCommand' str = do
758 macros <- readIORef macros_ref
759 let cmds = builtin_commands ++ macros
760 -- look for exact match first, then the first prefix match
761 return $ case [ c | c <- cmds, str == cmdName c ] of
763 [] -> case [ c | c@(s,_,_) <- cmds, str `isPrefixOf` s ] of
767 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
768 getCurrentBreakSpan = do
769 resumes <- GHC.getResumeContext
773 let ix = GHC.resumeHistoryIx r
775 then return (Just (GHC.resumeSpan r))
777 let hist = GHC.resumeHistory r !! (ix-1)
778 span <- GHC.getHistorySpan hist
781 getCurrentBreakModule :: GHCi (Maybe Module)
782 getCurrentBreakModule = do
783 resumes <- GHC.getResumeContext
787 let ix = GHC.resumeHistoryIx r
789 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
791 let hist = GHC.resumeHistory r !! (ix-1)
792 return $ Just $ GHC.getHistoryModule hist
794 -----------------------------------------------------------------------------
797 noArgs :: GHCi () -> String -> GHCi ()
799 noArgs _ _ = io $ putStrLn "This command takes no arguments"
801 help :: String -> GHCi ()
802 help _ = io (putStr helpText)
804 info :: String -> InputT GHCi ()
805 info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
806 info s = handleSourceError GHC.printExceptionAndWarnings $ do
807 { let names = words s
808 ; dflags <- getDynFlags
809 ; let pefas = dopt Opt_PrintExplicitForalls dflags
810 ; mapM_ (infoThing pefas) names }
812 infoThing pefas str = do
813 names <- GHC.parseName str
814 mb_stuffs <- mapM GHC.getInfo names
815 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
816 unqual <- GHC.getPrintUnqual
817 outputStrLn $ showSDocForUser unqual $
818 vcat (intersperse (text "") $
819 map (pprInfo pefas) filtered)
821 -- Filter out names whose parent is also there Good
822 -- example is '[]', which is both a type and data
823 -- constructor in the same type
824 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
825 filterOutChildren get_thing xs
826 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
828 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
830 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
831 pprInfo pefas (thing, fixity, insts)
832 = pprTyThingInContextLoc pefas thing
833 $$ show_fixity fixity
834 $$ vcat (map GHC.pprInstance insts)
837 | fix == GHC.defaultFixity = empty
838 | otherwise = ppr fix <+> ppr (GHC.getName thing)
840 runMain :: String -> GHCi ()
841 runMain s = case toArgs s of
842 Left err -> io (hPutStrLn stderr err)
844 do dflags <- getDynFlags
845 case mainFunIs dflags of
846 Nothing -> doWithArgs args "main"
847 Just f -> doWithArgs args f
849 runRun :: String -> GHCi ()
850 runRun s = case toCmdArgs s of
851 Left err -> io (hPutStrLn stderr err)
852 Right (cmd, args) -> doWithArgs args cmd
854 doWithArgs :: [String] -> String -> GHCi ()
855 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
856 show args ++ " (" ++ cmd ++ ")"]
858 addModule :: [FilePath] -> InputT GHCi ()
860 lift revertCAFs -- always revert CAFs on load/add.
861 files <- mapM expandPath files
862 targets <- mapM (\m -> GHC.guessTarget m Nothing) files
863 -- remove old targets with the same id; e.g. for :add *M
864 mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
865 mapM_ GHC.addTarget targets
866 prev_context <- GHC.getContext
867 ok <- trySuccess $ GHC.load LoadAllTargets
868 afterLoad ok False prev_context
870 changeDirectory :: String -> InputT GHCi ()
871 changeDirectory "" = do
872 -- :cd on its own changes to the user's home directory
873 either_dir <- liftIO $ IO.try getHomeDirectory
876 Right dir -> changeDirectory dir
877 changeDirectory dir = do
878 graph <- GHC.getModuleGraph
879 when (not (null graph)) $
880 outputStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
881 prev_context <- GHC.getContext
883 _ <- GHC.load LoadAllTargets
884 lift $ setContextAfterLoad prev_context False []
885 GHC.workingDirectoryChanged
886 dir <- expandPath dir
887 liftIO $ setCurrentDirectory dir
889 trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
891 handleSourceError (\e -> do GHC.printExceptionAndWarnings e
895 editFile :: String -> GHCi ()
897 do file <- if null str then chooseEditFile else return str
901 $ ghcError (CmdLineError "editor not set, use :set editor")
902 _ <- io $ system (cmd ++ ' ':file)
905 -- The user didn't specify a file so we pick one for them.
906 -- Our strategy is to pick the first module that failed to load,
907 -- or otherwise the first target.
909 -- XXX: Can we figure out what happened if the depndecy analysis fails
910 -- (e.g., because the porgrammeer mistyped the name of a module)?
911 -- XXX: Can we figure out the location of an error to pass to the editor?
912 -- XXX: if we could figure out the list of errors that occured during the
913 -- last load/reaload, then we could start the editor focused on the first
915 chooseEditFile :: GHCi String
917 do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
919 graph <- GHC.getModuleGraph
920 failed_graph <- filterM hasFailed graph
921 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
923 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
926 case pick (order failed_graph) of
927 Just file -> return file
929 do targets <- GHC.getTargets
930 case msum (map fromTarget targets) of
931 Just file -> return file
932 Nothing -> ghcError (CmdLineError "No files to edit.")
934 where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
935 fromTarget _ = Nothing -- when would we get a module target?
937 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
938 defineMacro overwrite s = do
939 let (macro_name, definition) = break isSpace s
940 macros <- io (readIORef macros_ref)
941 let defined = map cmdName macros
944 then io $ putStrLn "no macros defined"
945 else io $ putStr ("the following macros are defined:\n" ++
948 if (not overwrite && macro_name `elem` defined)
949 then ghcError (CmdLineError
950 ("macro '" ++ macro_name ++ "' is already defined"))
953 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
955 -- give the expression a type signature, so we can be sure we're getting
956 -- something of the right type.
957 let new_expr = '(' : definition ++ ") :: String -> IO String"
959 -- compile the expression
960 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
961 hv <- GHC.compileExpr new_expr
962 io (writeIORef macros_ref --
963 (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)]))
965 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
967 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
968 -- make sure we force any exceptions in the result, while we are still
969 -- inside the exception handler for commands:
970 seqList str (return ())
971 enqueueCommands (lines str)
974 undefineMacro :: String -> GHCi ()
975 undefineMacro str = mapM_ undef (words str)
976 where undef macro_name = do
977 cmds <- io (readIORef macros_ref)
978 if (macro_name `notElem` map cmdName cmds)
979 then ghcError (CmdLineError
980 ("macro '" ++ macro_name ++ "' is not defined"))
982 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
984 cmdCmd :: String -> GHCi ()
986 let expr = '(' : str ++ ") :: IO String"
987 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
988 hv <- GHC.compileExpr expr
989 cmds <- io $ (unsafeCoerce# hv :: IO String)
990 enqueueCommands (lines cmds)
993 loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
994 loadModule fs = timeIt (loadModule' fs)
996 loadModule_ :: [FilePath] -> InputT GHCi ()
997 loadModule_ fs = loadModule (zip fs (repeat Nothing)) >> return ()
999 loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
1000 loadModule' files = do
1001 prev_context <- GHC.getContext
1005 lift discardActiveBreakPoints
1007 _ <- GHC.load LoadAllTargets
1009 let (filenames, phases) = unzip files
1010 exp_filenames <- mapM expandPath filenames
1011 let files' = zip exp_filenames phases
1012 targets <- mapM (uncurry GHC.guessTarget) files'
1014 -- NOTE: we used to do the dependency anal first, so that if it
1015 -- fails we didn't throw away the current set of modules. This would
1016 -- require some re-working of the GHC interface, so we'll leave it
1017 -- as a ToDo for now.
1019 GHC.setTargets targets
1020 doLoad False prev_context LoadAllTargets
1022 checkModule :: String -> InputT GHCi ()
1024 let modl = GHC.mkModuleName m
1025 prev_context <- GHC.getContext
1026 ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do
1027 r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
1028 outputStrLn (showSDoc (
1029 case GHC.moduleInfo r of
1030 cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1032 (local,global) = ASSERT( all isExternalName scope )
1033 partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1035 (text "global names: " <+> ppr global) $$
1036 (text "local names: " <+> ppr local)
1039 afterLoad (successIf ok) False prev_context
1041 reloadModule :: String -> InputT GHCi ()
1043 prev_context <- GHC.getContext
1044 _ <- doLoad True prev_context $
1045 if null m then LoadAllTargets
1046 else LoadUpTo (GHC.mkModuleName m)
1049 doLoad :: Bool -> ([Module],[Module]) -> LoadHowMuch -> InputT GHCi SuccessFlag
1050 doLoad retain_context prev_context howmuch = do
1051 -- turn off breakpoints before we load: we can't turn them off later, because
1052 -- the ModBreaks will have gone away.
1053 lift discardActiveBreakPoints
1054 ok <- trySuccess $ GHC.load howmuch
1055 afterLoad ok retain_context prev_context
1058 afterLoad :: SuccessFlag -> Bool -> ([Module],[Module]) -> InputT GHCi ()
1059 afterLoad ok retain_context prev_context = do
1060 lift revertCAFs -- always revert CAFs on load.
1061 lift discardTickArrays
1062 loaded_mod_summaries <- getLoadedModules
1063 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1064 loaded_mod_names = map GHC.moduleName loaded_mods
1065 modulesLoadedMsg ok loaded_mod_names
1067 lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
1070 setContextAfterLoad :: ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi ()
1071 setContextAfterLoad prev keep_ctxt [] = do
1072 prel_mod <- getPrelude
1073 setContextKeepingPackageModules prev keep_ctxt ([], [prel_mod])
1074 setContextAfterLoad prev keep_ctxt ms = do
1075 -- load a target if one is available, otherwise load the topmost module.
1076 targets <- GHC.getTargets
1077 case [ m | Just m <- map (findTarget ms) targets ] of
1079 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1080 load_this (last graph')
1085 = case filter (`matches` t) ms of
1089 summary `matches` Target (TargetModule m) _ _
1090 = GHC.ms_mod_name summary == m
1091 summary `matches` Target (TargetFile f _) _ _
1092 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1096 load_this summary | m <- GHC.ms_mod summary = do
1097 b <- GHC.moduleIsInterpreted m
1098 if b then setContextKeepingPackageModules prev keep_ctxt ([m], [])
1100 prel_mod <- getPrelude
1101 setContextKeepingPackageModules prev keep_ctxt ([],[prel_mod,m])
1103 -- | Keep any package modules (except Prelude) when changing the context.
1104 setContextKeepingPackageModules
1105 :: ([Module],[Module]) -- previous context
1106 -> Bool -- re-execute :module commands
1107 -> ([Module],[Module]) -- new context
1109 setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do
1110 let (_,bs0) = prev_context
1111 prel_mod <- getPrelude
1112 let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1113 let bs1 = if null as then nub (prel_mod : bs) else bs
1114 GHC.setContext as (nub (bs1 ++ pkg_modules))
1118 mapM_ (playCtxtCmd False) (remembered_ctx st)
1121 setGHCiState st{ remembered_ctx = [] }
1123 isHomeModule :: Module -> Bool
1124 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1126 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi ()
1127 modulesLoadedMsg ok mods = do
1128 dflags <- getDynFlags
1129 when (verbosity dflags > 0) $ do
1131 | null mods = text "none."
1132 | otherwise = hsep (
1133 punctuate comma (map ppr mods)) <> text "."
1136 outputStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))
1138 outputStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas))
1141 typeOfExpr :: String -> InputT GHCi ()
1143 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1144 ty <- GHC.exprType str
1145 dflags <- getDynFlags
1146 let pefas = dopt Opt_PrintExplicitForalls dflags
1147 printForUser' $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]
1149 kindOfType :: String -> InputT GHCi ()
1151 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1152 ty <- GHC.typeKind str
1153 printForUser' $ text str <+> dcolon <+> ppr ty
1155 quit :: String -> InputT GHCi Bool
1156 quit _ = return True
1158 shellEscape :: String -> GHCi Bool
1159 shellEscape str = io (system str >> return False)
1161 -----------------------------------------------------------------------------
1162 -- Browsing a module's contents
1164 browseCmd :: Bool -> String -> InputT GHCi ()
1167 ['*':s] | looksLikeModuleName s -> do
1168 m <- lift $ wantInterpretedModule s
1169 browseModule bang m False
1170 [s] | looksLikeModuleName s -> do
1171 m <- lift $ lookupModule s
1172 browseModule bang m True
1174 (as,bs) <- GHC.getContext
1175 -- Guess which module the user wants to browse. Pick
1176 -- modules that are interpreted first. The most
1177 -- recently-added module occurs last, it seems.
1179 (as@(_:_), _) -> browseModule bang (last as) True
1180 ([], bs@(_:_)) -> browseModule bang (last bs) True
1181 ([], []) -> ghcError (CmdLineError ":browse: no current module")
1182 _ -> ghcError (CmdLineError "syntax: :browse <module>")
1184 -- without bang, show items in context of their parents and omit children
1185 -- with bang, show class methods and data constructors separately, and
1186 -- indicate import modules, to aid qualifying unqualified names
1187 -- with sorted, sort items alphabetically
1188 browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
1189 browseModule bang modl exports_only = do
1190 -- :browse! reports qualifiers wrt current context
1191 current_unqual <- GHC.getPrintUnqual
1192 -- Temporarily set the context to the module we're interested in,
1193 -- just so we can get an appropriate PrintUnqualified
1194 (as,bs) <- GHC.getContext
1195 prel_mod <- lift getPrelude
1196 if exports_only then GHC.setContext [] [prel_mod,modl]
1197 else GHC.setContext [modl] []
1198 target_unqual <- GHC.getPrintUnqual
1199 GHC.setContext as bs
1201 let unqual = if bang then current_unqual else target_unqual
1203 mb_mod_info <- GHC.getModuleInfo modl
1205 Nothing -> ghcError (CmdLineError ("unknown module: " ++
1206 GHC.moduleNameString (GHC.moduleName modl)))
1208 dflags <- getDynFlags
1210 | exports_only = GHC.modInfoExports mod_info
1211 | otherwise = GHC.modInfoTopLevelScope mod_info
1214 -- sort alphabetically name, but putting
1215 -- locally-defined identifiers first.
1216 -- We would like to improve this; see #1799.
1217 sorted_names = loc_sort local ++ occ_sort external
1219 (local,external) = ASSERT( all isExternalName names )
1220 partition ((==modl) . nameModule) names
1221 occ_sort = sortBy (compare `on` nameOccName)
1222 -- try to sort by src location. If the first name in
1223 -- our list has a good source location, then they all should.
1225 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1226 = sortBy (compare `on` nameSrcSpan) names
1230 mb_things <- mapM GHC.lookupName sorted_names
1231 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1233 rdr_env <- GHC.getGRE
1235 let pefas = dopt Opt_PrintExplicitForalls dflags
1236 things | bang = catMaybes mb_things
1237 | otherwise = filtered_things
1238 pretty | bang = pprTyThing
1239 | otherwise = pprTyThingInContext
1241 labels [] = text "-- not currently imported"
1242 labels l = text $ intercalate "\n" $ map qualifier l
1243 qualifier = maybe "-- defined locally"
1244 (("-- imported via "++) . intercalate ", "
1245 . map GHC.moduleNameString)
1246 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1247 modNames = map (importInfo . GHC.getName) things
1249 -- annotate groups of imports with their import modules
1250 -- the default ordering is somewhat arbitrary, so we group
1251 -- by header and sort groups; the names themselves should
1252 -- really come in order of source appearance.. (trac #1799)
1253 annotate mts = concatMap (\(m,ts)->labels m:ts)
1254 $ sortBy cmpQualifiers $ group mts
1255 where cmpQualifiers =
1256 compare `on` (map (fmap (map moduleNameFS)) . fst)
1258 group mts@((m,_):_) = (m,map snd g) : group ng
1259 where (g,ng) = partition ((==m).fst) mts
1261 let prettyThings = map (pretty pefas) things
1262 prettyThings' | bang = annotate $ zip modNames prettyThings
1263 | otherwise = prettyThings
1264 outputStrLn $ showSDocForUser unqual (vcat prettyThings')
1265 -- ToDo: modInfoInstances currently throws an exception for
1266 -- package modules. When it works, we can do this:
1267 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1269 -----------------------------------------------------------------------------
1270 -- Setting the module context
1272 setContext :: String -> GHCi ()
1274 | all sensible strs = do
1275 playCtxtCmd True (cmd, as, bs)
1277 setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] }
1278 | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1280 (cmd, strs, as, bs) =
1282 '+':stuff -> rest AddModules stuff
1283 '-':stuff -> rest RemModules stuff
1284 stuff -> rest SetContext stuff
1286 rest cmd stuff = (cmd, strs, as, bs)
1287 where strs = words stuff
1288 (as,bs) = partitionWith starred strs
1290 sensible ('*':m) = looksLikeModuleName m
1291 sensible m = looksLikeModuleName m
1293 starred ('*':m) = Left m
1296 playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi ()
1297 playCtxtCmd fail (cmd, as, bs)
1299 (as',bs') <- do_checks fail
1300 (prev_as,prev_bs) <- GHC.getContext
1304 prel_mod <- getPrelude
1305 let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs'
1309 let as_to_add = as' \\ (prev_as ++ prev_bs)
1310 bs_to_add = bs' \\ (prev_as ++ prev_bs)
1311 return (prev_as ++ as_to_add, prev_bs ++ bs_to_add)
1313 let new_as = prev_as \\ (as' ++ bs')
1314 new_bs = prev_bs \\ (as' ++ bs')
1315 return (new_as, new_bs)
1316 GHC.setContext new_as new_bs
1319 as' <- mapM wantInterpretedModule as
1320 bs' <- mapM lookupModule bs
1322 do_checks False = do
1323 as' <- mapM (trymaybe . wantInterpretedModule) as
1324 bs' <- mapM (trymaybe . lookupModule) bs
1325 return (catMaybes as', catMaybes bs')
1330 Left _ -> return Nothing
1331 Right a -> return (Just a)
1333 ----------------------------------------------------------------------------
1336 -- set options in the interpreter. Syntax is exactly the same as the
1337 -- ghc command line, except that certain options aren't available (-C,
1340 -- This is pretty fragile: most options won't work as expected. ToDo:
1341 -- figure out which ones & disallow them.
1343 setCmd :: String -> GHCi ()
1345 = do st <- getGHCiState
1346 let opts = options st
1347 io $ putStrLn (showSDoc (
1348 text "options currently set: " <>
1351 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1353 dflags <- getDynFlags
1354 io $ putStrLn (showSDoc (
1355 vcat (text "GHCi-specific dynamic flag settings:"
1356 :map (flagSetting dflags) ghciFlags)
1358 io $ putStrLn (showSDoc (
1359 vcat (text "other dynamic, non-language, flag settings:"
1360 :map (flagSetting dflags) nonLanguageDynFlags)
1362 where flagSetting dflags (str, f, _)
1363 | dopt f dflags = text " " <> text "-f" <> text str
1364 | otherwise = text " " <> text "-fno-" <> text str
1365 (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags)
1367 nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions)
1369 flags = [Opt_PrintExplicitForalls
1370 ,Opt_PrintBindResult
1371 ,Opt_BreakOnException
1373 ,Opt_PrintEvldWithShow
1376 = case getCmd str of
1377 Right ("args", rest) ->
1379 Left err -> io (hPutStrLn stderr err)
1380 Right args -> setArgs args
1381 Right ("prog", rest) ->
1383 Right [prog] -> setProg prog
1384 _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")
1385 Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1386 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1387 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1388 _ -> case toArgs str of
1389 Left err -> io (hPutStrLn stderr err)
1390 Right wds -> setOptions wds
1392 setArgs, setOptions :: [String] -> GHCi ()
1393 setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
1397 setGHCiState st{ args = args }
1401 setGHCiState st{ progname = prog }
1405 setGHCiState st{ editor = cmd }
1407 setStop str@(c:_) | isDigit c
1408 = do let (nm_str,rest) = break (not.isDigit) str
1411 let old_breaks = breaks st
1412 if all ((/= nm) . fst) old_breaks
1413 then printForUser (text "Breakpoint" <+> ppr nm <+>
1414 text "does not exist")
1416 let new_breaks = map fn old_breaks
1417 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1418 | otherwise = (i,loc)
1419 setGHCiState st{ breaks = new_breaks }
1422 setGHCiState st{ stop = cmd }
1424 setPrompt value = do
1427 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1429 '\"' : _ -> case reads value of
1430 [(value', xs)] | all isSpace xs ->
1431 setGHCiState (st { prompt = value' })
1433 io $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
1434 _ -> setGHCiState (st { prompt = value })
1437 do -- first, deal with the GHCi opts (+s, +t, etc.)
1438 let (plus_opts, minus_opts) = partitionWith isPlus wds
1439 mapM_ setOpt plus_opts
1440 -- then, dynamic flags
1441 newDynFlags minus_opts
1443 newDynFlags :: [String] -> GHCi ()
1444 newDynFlags minus_opts = do
1445 dflags <- getDynFlags
1446 let pkg_flags = packageFlags dflags
1447 (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
1448 handleFlagWarnings dflags' warns
1450 if (not (null leftovers))
1451 then ghcError $ errorsToGhcException leftovers
1454 new_pkgs <- setDynFlags dflags'
1456 -- if the package flags changed, we should reset the context
1457 -- and link the new packages.
1458 dflags <- getDynFlags
1459 when (packageFlags dflags /= pkg_flags) $ do
1460 io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
1462 _ <- GHC.load LoadAllTargets
1463 io (linkPackages dflags new_pkgs)
1464 -- package flags changed, we can't re-use any of the old context
1465 setContextAfterLoad ([],[]) False []
1469 unsetOptions :: String -> GHCi ()
1471 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1472 let opts = words str
1473 (minus_opts, rest1) = partition isMinus opts
1474 (plus_opts, rest2) = partitionWith isPlus rest1
1476 if (not (null rest2))
1477 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1480 mapM_ unsetOpt plus_opts
1482 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1483 no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
1485 no_flags <- mapM no_flag minus_opts
1486 newDynFlags no_flags
1488 isMinus :: String -> Bool
1489 isMinus ('-':_) = True
1492 isPlus :: String -> Either String String
1493 isPlus ('+':opt) = Left opt
1494 isPlus other = Right other
1496 setOpt, unsetOpt :: String -> GHCi ()
1499 = case strToGHCiOpt str of
1500 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1501 Just o -> setOption o
1504 = case strToGHCiOpt str of
1505 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1506 Just o -> unsetOption o
1508 strToGHCiOpt :: String -> (Maybe GHCiOption)
1509 strToGHCiOpt "s" = Just ShowTiming
1510 strToGHCiOpt "t" = Just ShowType
1511 strToGHCiOpt "r" = Just RevertCAFs
1512 strToGHCiOpt _ = Nothing
1514 optToStr :: GHCiOption -> String
1515 optToStr ShowTiming = "s"
1516 optToStr ShowType = "t"
1517 optToStr RevertCAFs = "r"
1519 -- ---------------------------------------------------------------------------
1522 showCmd :: String -> GHCi ()
1526 ["args"] -> io $ putStrLn (show (args st))
1527 ["prog"] -> io $ putStrLn (show (progname st))
1528 ["prompt"] -> io $ putStrLn (show (prompt st))
1529 ["editor"] -> io $ putStrLn (show (editor st))
1530 ["stop"] -> io $ putStrLn (show (stop st))
1531 ["modules" ] -> showModules
1532 ["bindings"] -> showBindings
1533 ["linker"] -> io showLinkerState
1534 ["breaks"] -> showBkptTable
1535 ["context"] -> showContext
1536 ["packages"] -> showPackages
1537 ["languages"] -> showLanguages
1538 _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
1539 " | breaks | context | packages | languages ]"))
1541 showModules :: GHCi ()
1543 loaded_mods <- getLoadedModules
1544 -- we want *loaded* modules only, see #1734
1545 let show_one ms = do m <- GHC.showModule ms; io (putStrLn m)
1546 mapM_ show_one loaded_mods
1548 getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
1549 getLoadedModules = do
1550 graph <- GHC.getModuleGraph
1551 filterM (GHC.isLoaded . GHC.ms_mod_name) graph
1553 showBindings :: GHCi ()
1555 bindings <- GHC.getBindings
1556 docs <- pprTypeAndContents
1557 [ id | AnId id <- sortBy compareTyThings bindings]
1558 printForUserPartWay docs
1560 compareTyThings :: TyThing -> TyThing -> Ordering
1561 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1563 printTyThing :: TyThing -> GHCi ()
1564 printTyThing tyth = do dflags <- getDynFlags
1565 let pefas = dopt Opt_PrintExplicitForalls dflags
1566 printForUser (pprTyThing pefas tyth)
1568 showBkptTable :: GHCi ()
1571 printForUser $ prettyLocations (breaks st)
1573 showContext :: GHCi ()
1575 resumes <- GHC.getResumeContext
1576 printForUser $ vcat (map pp_resume (reverse resumes))
1579 ptext (sLit "--> ") <> text (GHC.resumeStmt resume)
1580 $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume))
1582 showPackages :: GHCi ()
1584 pkg_flags <- fmap packageFlags getDynFlags
1585 io $ putStrLn $ showSDoc $ vcat $
1586 text ("active package flags:"++if null pkg_flags then " none" else "")
1587 : map showFlag pkg_flags
1588 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1589 io $ putStrLn $ showSDoc $ vcat $
1590 text "packages currently loaded:"
1591 : map (nest 2 . text . packageIdString)
1592 (sortBy (compare `on` packageIdFS) pkg_ids)
1593 where showFlag (ExposePackage p) = text $ " -package " ++ p
1594 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1595 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1597 showLanguages :: GHCi ()
1599 dflags <- getDynFlags
1600 io $ putStrLn $ showSDoc $ vcat $
1601 text "active language flags:" :
1602 [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags]
1604 -- -----------------------------------------------------------------------------
1607 completeCmd, completeMacro, completeIdentifier, completeModule,
1608 completeHomeModule, completeSetOptions, completeShowOptions,
1609 completeHomeModuleOrFile, completeExpression
1610 :: CompletionFunc GHCi
1612 ghciCompleteWord :: CompletionFunc GHCi
1613 ghciCompleteWord line@(left,_) = case firstWord of
1614 ':':cmd | null rest -> completeCmd line
1616 completion <- lookupCompletion cmd
1618 "import" -> completeModule line
1619 _ -> completeExpression line
1621 (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
1622 lookupCompletion ('!':_) = return completeFilename
1623 lookupCompletion c = do
1624 maybe_cmd <- liftIO $ lookupCommand' c
1626 Just (_,_,f) -> return f
1627 Nothing -> return completeFilename
1629 completeCmd = wrapCompleter " " $ \w -> do
1630 cmds <- liftIO $ readIORef macros_ref
1631 return (filter (w `isPrefixOf`) (map (':':)
1632 (map cmdName (builtin_commands ++ cmds))))
1634 completeMacro = wrapIdentCompleter $ \w -> do
1635 cmds <- liftIO $ readIORef macros_ref
1636 return (filter (w `isPrefixOf`) (map cmdName cmds))
1638 completeIdentifier = wrapIdentCompleter $ \w -> do
1639 rdrs <- GHC.getRdrNamesInScope
1640 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1642 completeModule = wrapIdentCompleter $ \w -> do
1643 dflags <- GHC.getSessionDynFlags
1644 let pkg_mods = allExposedModules dflags
1645 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
1646 return $ filter (w `isPrefixOf`)
1647 $ map (showSDoc.ppr) $ loaded_mods ++ pkg_mods
1649 completeHomeModule = wrapIdentCompleter listHomeModules
1651 listHomeModules :: String -> GHCi [String]
1652 listHomeModules w = do
1653 g <- GHC.getModuleGraph
1654 let home_mods = map GHC.ms_mod_name g
1655 return $ sort $ filter (w `isPrefixOf`)
1656 $ map (showSDoc.ppr) home_mods
1658 completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
1659 return (filter (w `isPrefixOf`) options)
1660 where options = "args":"prog":"prompt":"editor":"stop":flagList
1661 flagList = map head $ group $ sort allFlags
1663 completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
1664 return (filter (w `isPrefixOf`) options)
1665 where options = ["args", "prog", "prompt", "editor", "stop",
1666 "modules", "bindings", "linker", "breaks",
1667 "context", "packages", "languages"]
1669 completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
1670 $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
1673 unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
1674 unionComplete f1 f2 line = do
1679 wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
1680 wrapCompleter breakChars fun = completeWord Nothing breakChars
1681 $ fmap (map simpleCompletion) . fmap sort . fun
1683 wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
1684 wrapIdentCompleter = wrapCompleter word_break_chars
1686 allExposedModules :: DynFlags -> [ModuleName]
1687 allExposedModules dflags
1688 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1690 pkg_db = pkgIdMap (pkgState dflags)
1692 completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
1695 -- ---------------------------------------------------------------------------
1696 -- User code exception handling
1698 -- This is the exception handler for exceptions generated by the
1699 -- user's code and exceptions coming from children sessions;
1700 -- it normally just prints out the exception. The
1701 -- handler must be recursive, in case showing the exception causes
1702 -- more exceptions to be raised.
1704 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1705 -- raising another exception. We therefore don't put the recursive
1706 -- handler arond the flushing operation, so if stderr is closed
1707 -- GHCi will just die gracefully rather than going into an infinite loop.
1708 handler :: SomeException -> GHCi Bool
1710 handler exception = do
1712 io installSignalHandlers
1713 ghciHandle handler (showException exception >> return False)
1715 showException :: SomeException -> GHCi ()
1717 io $ case fromException se of
1718 Just Interrupted -> putStrLn "Interrupted."
1719 -- omit the location for CmdLineError:
1720 Just (CmdLineError s) -> putStrLn s
1722 Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
1723 Just other_ghc_ex -> print other_ghc_ex
1724 Nothing -> putStrLn ("*** Exception: " ++ show se)
1726 -----------------------------------------------------------------------------
1727 -- recursive exception handlers
1729 -- Don't forget to unblock async exceptions in the handler, or if we're
1730 -- in an exception loop (eg. let a = error a in a) the ^C exception
1731 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1733 ghciHandle :: MonadException m => (SomeException -> m a) -> m a -> m a
1734 ghciHandle h m = Haskeline.catch m $ \e -> unblock (h e)
1736 ghciTry :: GHCi a -> GHCi (Either SomeException a)
1737 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
1739 -- ----------------------------------------------------------------------------
1742 -- TODO: won't work if home dir is encoded.
1743 -- (changeDirectory may not work either in that case.)
1744 expandPath :: MonadIO m => String -> InputT m String
1745 expandPath path = do
1746 exp_path <- liftIO $ expandPathIO path
1747 enc <- fmap BS.unpack $ Encoding.encode exp_path
1750 expandPathIO :: String -> IO String
1752 case dropWhile isSpace path of
1754 tilde <- getHomeDirectory -- will fail if HOME not defined
1755 return (tilde ++ '/':d)
1759 wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
1760 wantInterpretedModule str = do
1761 modl <- lookupModule str
1762 dflags <- getDynFlags
1763 when (GHC.modulePackageId modl /= thisPackage dflags) $
1764 ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
1765 is_interpreted <- GHC.moduleIsInterpreted modl
1766 when (not is_interpreted) $
1767 ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
1770 wantNameFromInterpretedModule :: GHC.GhcMonad m
1771 => (Name -> SDoc -> m ())
1775 wantNameFromInterpretedModule noCanDo str and_then =
1776 handleSourceError (GHC.printExceptionAndWarnings) $ do
1777 names <- GHC.parseName str
1781 let modl = ASSERT( isExternalName n ) GHC.nameModule n
1782 if not (GHC.isExternalName n)
1783 then noCanDo n $ ppr n <>
1784 text " is not defined in an interpreted module"
1786 is_interpreted <- GHC.moduleIsInterpreted modl
1787 if not is_interpreted
1788 then noCanDo n $ text "module " <> ppr modl <>
1789 text " is not interpreted"
1792 -- -----------------------------------------------------------------------------
1793 -- commands for debugger
1795 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1796 sprintCmd = pprintCommand False False
1797 printCmd = pprintCommand True False
1798 forceCmd = pprintCommand False True
1800 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1801 pprintCommand bind force str = do
1802 pprintClosureCommand bind force str
1804 stepCmd :: String -> GHCi ()
1805 stepCmd [] = doContinue (const True) GHC.SingleStep
1806 stepCmd expression = runStmt expression GHC.SingleStep >> return ()
1808 stepLocalCmd :: String -> GHCi ()
1809 stepLocalCmd [] = do
1810 mb_span <- getCurrentBreakSpan
1812 Nothing -> stepCmd []
1814 Just mod <- getCurrentBreakModule
1815 current_toplevel_decl <- enclosingTickSpan mod loc
1816 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1818 stepLocalCmd expression = stepCmd expression
1820 stepModuleCmd :: String -> GHCi ()
1821 stepModuleCmd [] = do
1822 mb_span <- getCurrentBreakSpan
1824 Nothing -> stepCmd []
1826 Just span <- getCurrentBreakSpan
1827 let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span
1828 doContinue f GHC.SingleStep
1830 stepModuleCmd expression = stepCmd expression
1832 -- | Returns the span of the largest tick containing the srcspan given
1833 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1834 enclosingTickSpan mod src = do
1835 ticks <- getTickArray mod
1836 let line = srcSpanStartLine src
1837 ASSERT (inRange (bounds ticks) line) do
1838 let enclosing_spans = [ span | (_,span) <- ticks ! line
1839 , srcSpanEnd span >= srcSpanEnd src]
1840 return . head . sortBy leftmost_largest $ enclosing_spans
1842 traceCmd :: String -> GHCi ()
1843 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1844 traceCmd expression = runStmt expression GHC.RunAndLogSteps >> return ()
1846 continueCmd :: String -> GHCi ()
1847 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1849 -- doContinue :: SingleStep -> GHCi ()
1850 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1851 doContinue pred step = do
1852 runResult <- resume pred step
1853 _ <- afterRunStmt pred runResult
1856 abandonCmd :: String -> GHCi ()
1857 abandonCmd = noArgs $ do
1858 b <- GHC.abandon -- the prompt will change to indicate the new context
1859 when (not b) $ io $ putStrLn "There is no computation running."
1862 deleteCmd :: String -> GHCi ()
1863 deleteCmd argLine = do
1864 deleteSwitch $ words argLine
1866 deleteSwitch :: [String] -> GHCi ()
1868 io $ putStrLn "The delete command requires at least one argument."
1869 -- delete all break points
1870 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1871 deleteSwitch idents = do
1872 mapM_ deleteOneBreak idents
1874 deleteOneBreak :: String -> GHCi ()
1876 | all isDigit str = deleteBreak (read str)
1877 | otherwise = return ()
1879 historyCmd :: String -> GHCi ()
1881 | null arg = history 20
1882 | all isDigit arg = history (read arg)
1883 | otherwise = io $ putStrLn "Syntax: :history [num]"
1886 resumes <- GHC.getResumeContext
1888 [] -> io $ putStrLn "Not stopped at a breakpoint"
1890 let hist = GHC.resumeHistory r
1891 (took,rest) = splitAt num hist
1893 [] -> io $ putStrLn $
1894 "Empty history. Perhaps you forgot to use :trace?"
1896 spans <- mapM GHC.getHistorySpan took
1897 let nums = map (printf "-%-3d:") [(1::Int)..]
1898 names = map GHC.historyEnclosingDecl took
1899 printForUser (vcat(zipWith3
1900 (\x y z -> x <+> y <+> z)
1902 (map (bold . ppr) names)
1903 (map (parens . ppr) spans)))
1904 io $ putStrLn $ if null rest then "<end of history>" else "..."
1906 bold :: SDoc -> SDoc
1907 bold c | do_bold = text start_bold <> c <> text end_bold
1910 backCmd :: String -> GHCi ()
1911 backCmd = noArgs $ do
1912 (names, _, span) <- GHC.back
1913 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span
1914 printTypeOfNames names
1915 -- run the command set with ":set stop <cmd>"
1917 enqueueCommands [stop st]
1919 forwardCmd :: String -> GHCi ()
1920 forwardCmd = noArgs $ do
1921 (names, ix, span) <- GHC.forward
1922 printForUser $ (if (ix == 0)
1923 then ptext (sLit "Stopped at")
1924 else ptext (sLit "Logged breakpoint at")) <+> ppr span
1925 printTypeOfNames names
1926 -- run the command set with ":set stop <cmd>"
1928 enqueueCommands [stop st]
1930 -- handle the "break" command
1931 breakCmd :: String -> GHCi ()
1932 breakCmd argLine = do
1933 breakSwitch $ words argLine
1935 breakSwitch :: [String] -> GHCi ()
1937 io $ putStrLn "The break command requires at least one argument."
1938 breakSwitch (arg1:rest)
1939 | looksLikeModuleName arg1 && not (null rest) = do
1940 mod <- wantInterpretedModule arg1
1941 breakByModule mod rest
1942 | all isDigit arg1 = do
1943 (toplevel, _) <- GHC.getContext
1945 (mod : _) -> breakByModuleLine mod (read arg1) rest
1947 io $ putStrLn "Cannot find default module for breakpoint."
1948 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1949 | otherwise = do -- try parsing it as an identifier
1950 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1951 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1952 if GHC.isGoodSrcLoc loc
1953 then ASSERT( isExternalName name )
1954 findBreakAndSet (GHC.nameModule name) $
1955 findBreakByCoord (Just (GHC.srcLocFile loc))
1956 (GHC.srcLocLine loc,
1958 else noCanDo name $ text "can't find its location: " <> ppr loc
1960 noCanDo n why = printForUser $
1961 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1963 breakByModule :: Module -> [String] -> GHCi ()
1964 breakByModule mod (arg1:rest)
1965 | all isDigit arg1 = do -- looks like a line number
1966 breakByModuleLine mod (read arg1) rest
1970 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1971 breakByModuleLine mod line args
1972 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1973 | [col] <- args, all isDigit col =
1974 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1975 | otherwise = breakSyntax
1978 breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1980 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1981 findBreakAndSet mod lookupTickTree = do
1982 tickArray <- getTickArray mod
1983 (breakArray, _) <- getModBreak mod
1984 case lookupTickTree tickArray of
1985 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1986 Just (tick, span) -> do
1987 success <- io $ setBreakFlag True breakArray tick
1991 recordBreak $ BreakLocation
1998 text "Breakpoint " <> ppr nm <>
2000 then text " was already set at " <> ppr span
2001 else text " activated at " <> ppr span
2003 printForUser $ text "Breakpoint could not be activated at"
2006 -- When a line number is specified, the current policy for choosing
2007 -- the best breakpoint is this:
2008 -- - the leftmost complete subexpression on the specified line, or
2009 -- - the leftmost subexpression starting on the specified line, or
2010 -- - the rightmost subexpression enclosing the specified line
2012 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2013 findBreakByLine line arr
2014 | not (inRange (bounds arr) line) = Nothing
2016 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
2017 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2018 listToMaybe (sortBy (rightmost `on` snd) ticks)
2022 starts_here = [ tick | tick@(_,span) <- ticks,
2023 GHC.srcSpanStartLine span == line ]
2025 (complete,incomplete) = partition ends_here starts_here
2026 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2028 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2029 -> Maybe (BreakIndex,SrcSpan)
2030 findBreakByCoord mb_file (line, col) arr
2031 | not (inRange (bounds arr) line) = Nothing
2033 listToMaybe (sortBy (rightmost `on` snd) contains ++
2034 sortBy (leftmost_smallest `on` snd) after_here)
2038 -- the ticks that span this coordinate
2039 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2040 is_correct_file span ]
2042 is_correct_file span
2043 | Just f <- mb_file = GHC.srcSpanFile span == f
2046 after_here = [ tick | tick@(_,span) <- ticks,
2047 GHC.srcSpanStartLine span == line,
2048 GHC.srcSpanStartCol span >= col ]
2050 -- For now, use ANSI bold on terminals that we know support it.
2051 -- Otherwise, we add a line of carets under the active expression instead.
2052 -- In particular, on Windows and when running the testsuite (which sets
2053 -- TERM to vt100 for other reasons) we get carets.
2054 -- We really ought to use a proper termcap/terminfo library.
2056 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2057 where mTerm = System.Environment.getEnv "TERM"
2058 `catchIO` \_ -> return "TERM not set"
2060 start_bold :: String
2061 start_bold = "\ESC[1m"
2063 end_bold = "\ESC[0m"
2065 listCmd :: String -> InputT GHCi ()
2067 mb_span <- lift getCurrentBreakSpan
2070 printForUser' $ text "Not stopped at a breakpoint; nothing to list"
2072 | GHC.isGoodSrcSpan span -> listAround span True
2074 do resumes <- GHC.getResumeContext
2076 [] -> panic "No resumes"
2078 do let traceIt = case GHC.resumeHistory r of
2079 [] -> text "rerunning with :trace,"
2081 doWhat = traceIt <+> text ":back then :list"
2082 printForUser' (text "Unable to list source for" <+>
2084 $$ text "Try" <+> doWhat)
2085 listCmd str = list2 (words str)
2087 list2 :: [String] -> InputT GHCi ()
2088 list2 [arg] | all isDigit arg = do
2089 (toplevel, _) <- GHC.getContext
2091 [] -> outputStrLn "No module to list"
2092 (mod : _) -> listModuleLine mod (read arg)
2093 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2094 mod <- wantInterpretedModule arg1
2095 listModuleLine mod (read arg2)
2097 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2098 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2099 if GHC.isGoodSrcLoc loc
2101 tickArray <- ASSERT( isExternalName name )
2102 lift $ getTickArray (GHC.nameModule name)
2103 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2104 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2107 Nothing -> listAround (GHC.srcLocSpan loc) False
2108 Just (_,span) -> listAround span False
2110 noCanDo name $ text "can't find its location: " <>
2113 noCanDo n why = printForUser' $
2114 text "cannot list source code for " <> ppr n <> text ": " <> why
2116 outputStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2118 listModuleLine :: Module -> Int -> InputT GHCi ()
2119 listModuleLine modl line = do
2120 graph <- GHC.getModuleGraph
2121 let this = filter ((== modl) . GHC.ms_mod) graph
2123 [] -> panic "listModuleLine"
2125 let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
2126 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2127 listAround (GHC.srcLocSpan loc) False
2129 -- | list a section of a source file around a particular SrcSpan.
2130 -- If the highlight flag is True, also highlight the span using
2131 -- start_bold\/end_bold.
2133 -- GHC files are UTF-8, so we can implement this by:
2134 -- 1) read the file in as a BS and syntax highlight it as before
2135 -- 2) convert the BS to String using utf-string, and write it out.
2136 -- It would be better if we could convert directly between UTF-8 and the
2137 -- console encoding, of course.
2138 listAround :: MonadIO m => SrcSpan -> Bool -> InputT m ()
2139 listAround span do_highlight = do
2140 contents <- liftIO $ BS.readFile (unpackFS file)
2142 lines = BS.split '\n' contents
2143 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2144 drop (line1 - 1 - pad_before) $ lines
2145 fst_line = max 1 (line1 - pad_before)
2146 line_nos = [ fst_line .. ]
2148 highlighted | do_highlight = zipWith highlight line_nos these_lines
2149 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2151 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2152 prefixed = zipWith ($) highlighted bs_line_nos
2154 let output = BS.intercalate (BS.pack "\n") prefixed
2155 utf8Decoded <- liftIO $ BS.useAsCStringLen output
2156 $ \(p,n) -> utf8DecodeString (castPtr p) n
2157 outputStrLn utf8Decoded
2159 file = GHC.srcSpanFile span
2160 line1 = GHC.srcSpanStartLine span
2161 col1 = GHC.srcSpanStartCol span
2162 line2 = GHC.srcSpanEndLine span
2163 col2 = GHC.srcSpanEndCol span
2165 pad_before | line1 == 1 = 0
2169 highlight | do_bold = highlight_bold
2170 | otherwise = highlight_carets
2172 highlight_bold no line prefix
2173 | no == line1 && no == line2
2174 = let (a,r) = BS.splitAt col1 line
2175 (b,c) = BS.splitAt (col2-col1) r
2177 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2179 = let (a,b) = BS.splitAt col1 line in
2180 BS.concat [prefix, a, BS.pack start_bold, b]
2182 = let (a,b) = BS.splitAt col2 line in
2183 BS.concat [prefix, a, BS.pack end_bold, b]
2184 | otherwise = BS.concat [prefix, line]
2186 highlight_carets no line prefix
2187 | no == line1 && no == line2
2188 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2189 BS.replicate (col2-col1) '^']
2191 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2194 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2196 | otherwise = BS.concat [prefix, line]
2198 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2199 nl = BS.singleton '\n'
2201 -- --------------------------------------------------------------------------
2204 getTickArray :: Module -> GHCi TickArray
2205 getTickArray modl = do
2207 let arrmap = tickarrays st
2208 case lookupModuleEnv arrmap modl of
2209 Just arr -> return arr
2211 (_breakArray, ticks) <- getModBreak modl
2212 let arr = mkTickArray (assocs ticks)
2213 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2216 discardTickArrays :: GHCi ()
2217 discardTickArrays = do
2219 setGHCiState st{tickarrays = emptyModuleEnv}
2221 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2223 = accumArray (flip (:)) [] (1, max_line)
2224 [ (line, (nm,span)) | (nm,span) <- ticks,
2225 line <- srcSpanLines span ]
2227 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2228 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2229 GHC.srcSpanEndLine span ]
2231 lookupModule :: GHC.GhcMonad m => String -> m Module
2232 lookupModule modName
2233 = GHC.lookupModule (GHC.mkModuleName modName) Nothing
2235 -- don't reset the counter back to zero?
2236 discardActiveBreakPoints :: GHCi ()
2237 discardActiveBreakPoints = do
2239 mapM_ (turnOffBreak.snd) (breaks st)
2240 setGHCiState $ st { breaks = [] }
2242 deleteBreak :: Int -> GHCi ()
2243 deleteBreak identity = do
2245 let oldLocations = breaks st
2246 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2248 then printForUser (text "Breakpoint" <+> ppr identity <+>
2249 text "does not exist")
2251 mapM_ (turnOffBreak.snd) this
2252 setGHCiState $ st { breaks = rest }
2254 turnOffBreak :: BreakLocation -> GHCi Bool
2255 turnOffBreak loc = do
2256 (arr, _) <- getModBreak (breakModule loc)
2257 io $ setBreakFlag False arr (breakTick loc)
2259 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2260 getModBreak mod = do
2261 Just mod_info <- GHC.getModuleInfo mod
2262 let modBreaks = GHC.modInfoModBreaks mod_info
2263 let array = GHC.modBreaks_flags modBreaks
2264 let ticks = GHC.modBreaks_locs modBreaks
2265 return (array, ticks)
2267 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2268 setBreakFlag toggle array index
2269 | toggle = GHC.setBreakOn array index
2270 | otherwise = GHC.setBreakOff array index