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 )
32 -- import PackageConfig
35 import HscTypes ( handleFlagWarnings )
36 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
37 import Outputable hiding (printForUser, printForUserPartWay)
38 import Module -- for ModuleEnv
42 -- Other random utilities
45 import BasicTypes hiding (isTopLevel)
46 import Panic hiding (showException)
52 import Maybes ( orElse, expectJust )
57 #ifndef mingw32_HOST_OS
58 import System.Posix hiding (getEnv)
60 import qualified System.Win32
63 import System.Console.Haskeline as Haskeline
64 import qualified System.Console.Haskeline.Encoding as Encoding
65 import Control.Monad.Trans
69 import Exception hiding (catch, block, unblock)
71 -- import Control.Concurrent
73 import System.FilePath
74 import qualified Data.ByteString.Char8 as BS
78 import System.Environment
79 import System.Exit ( exitWith, ExitCode(..) )
80 import System.Directory
82 import System.IO.Error as IO
85 import Control.Monad as Monad
88 import GHC.Exts ( unsafeCoerce# )
90 #if __GLASGOW_HASKELL__ >= 611
91 import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
92 import GHC.IO.Handle ( hFlushAll )
94 import GHC.IOBase ( IOErrorType(InvalidArgument) )
99 import Data.IORef ( IORef, readIORef, writeIORef )
101 -----------------------------------------------------------------------------
103 ghciWelcomeMsg :: String
104 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
105 ": http://www.haskell.org/ghc/ :? for help"
107 cmdName :: Command -> String
110 GLOBAL_VAR(macros_ref, [], [Command])
112 builtin_commands :: [Command]
114 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
115 ("?", keepGoing help, noCompletion),
116 ("add", keepGoingPaths addModule, completeFilename),
117 ("abandon", keepGoing abandonCmd, noCompletion),
118 ("break", keepGoing breakCmd, completeIdentifier),
119 ("back", keepGoing backCmd, noCompletion),
120 ("browse", keepGoing' (browseCmd False), completeModule),
121 ("browse!", keepGoing' (browseCmd True), completeModule),
122 ("cd", keepGoing' changeDirectory, completeFilename),
123 ("check", keepGoing' checkModule, completeHomeModule),
124 ("continue", keepGoing continueCmd, noCompletion),
125 ("cmd", keepGoing cmdCmd, completeExpression),
126 ("ctags", keepGoing createCTagsWithLineNumbersCmd, completeFilename),
127 ("ctags!", keepGoing createCTagsWithRegExesCmd, completeFilename),
128 ("def", keepGoing (defineMacro False), completeExpression),
129 ("def!", keepGoing (defineMacro True), completeExpression),
130 ("delete", keepGoing deleteCmd, noCompletion),
131 ("edit", keepGoing editFile, completeFilename),
132 ("etags", keepGoing createETagsFileCmd, completeFilename),
133 ("force", keepGoing forceCmd, completeExpression),
134 ("forward", keepGoing forwardCmd, noCompletion),
135 ("help", keepGoing help, noCompletion),
136 ("history", keepGoing historyCmd, noCompletion),
137 ("info", keepGoing' info, completeIdentifier),
138 ("kind", keepGoing' kindOfType, completeIdentifier),
139 ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),
140 ("list", keepGoing' listCmd, noCompletion),
141 ("module", keepGoing setContext, completeModule),
142 ("main", keepGoing runMain, completeFilename),
143 ("print", keepGoing printCmd, completeExpression),
144 ("quit", quit, noCompletion),
145 ("reload", keepGoing' reloadModule, noCompletion),
146 ("run", keepGoing runRun, 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 " :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 canonicalizePath' :: FilePath -> IO (Maybe FilePath)
389 canonicalizePath' fp = liftM Just (canonicalizePath fp)
390 `catchIO` \_ -> return Nothing
392 sourceConfigFile :: FilePath -> GHCi ()
393 sourceConfigFile file = do
394 exists <- io $ doesFileExist file
396 dir_ok <- io $ checkPerms (getDirectory file)
397 file_ok <- io $ checkPerms file
398 when (dir_ok && file_ok) $ do
399 either_hdl <- io $ IO.try (openFile file ReadMode)
402 -- NOTE: this assumes that runInputT won't affect the terminal;
403 -- can we assume this will always be the case?
404 -- This would be a good place for runFileInputT.
405 Right hdl -> runInputTWithPrefs defaultPrefs defaultSettings $ do
406 runCommands $ fileLoop hdl
408 getDirectory f = case takeDirectory f of "" -> "."; d -> d
410 when (read_dot_files) $ do
411 mcfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
412 mcfgs <- io $ mapM canonicalizePath' (catMaybes mcfgs0)
413 mapM_ sourceConfigFile $ nub $ catMaybes mcfgs
414 -- nub, because we don't want to read .ghci twice if the
417 -- Perform a :load for files given on the GHCi command line
418 -- When in -e mode, if the load fails then we want to stop
419 -- immediately rather than going on to evaluate the expression.
420 when (not (null paths)) $ do
421 ok <- ghciHandle (\e -> do showException e; return Failed) $
422 -- TODO: this is a hack.
423 runInputTWithPrefs defaultPrefs defaultSettings $ do
424 let (filePaths, phases) = unzip paths
425 filePaths' <- mapM (Encoding.decode . BS.pack) filePaths
426 loadModule (zip filePaths' phases)
427 when (isJust maybe_exprs && failed ok) $
428 io (exitWith (ExitFailure 1))
430 -- if verbosity is greater than 0, or we are connected to a
431 -- terminal, display the prompt in the interactive loop.
432 is_tty <- io (hIsTerminalDevice stdin)
433 dflags <- getDynFlags
434 let show_prompt = verbosity dflags > 0 || is_tty
439 -- enter the interactive loop
440 runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
442 -- just evaluate the expression we were given
443 enqueueCommands exprs
444 let handle e = do st <- getGHCiState
445 -- flush the interpreter's stdout/stderr on exit (#3890)
447 -- Jump through some hoops to get the
448 -- current progname in the exception text:
449 -- <progname>: <exception>
450 io $ withProgName (progname st)
451 -- this used to be topHandlerFastExit, see #2228
453 runInputTWithPrefs defaultPrefs defaultSettings $ do
454 runCommands' handle (return Nothing)
457 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
459 runGHCiInput :: InputT GHCi a -> GHCi a
461 histFile <- io $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
463 let settings = setComplete ghciCompleteWord
464 $ defaultSettings {historyFile = histFile}
467 nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
468 nextInputLine show_prompt is_tty
470 prompt <- if show_prompt then lift mkPrompt else return ""
473 when show_prompt $ lift mkPrompt >>= liftIO . putStr
476 -- NOTE: We only read .ghci files if they are owned by the current user,
477 -- and aren't world writable. Otherwise, we could be accidentally
478 -- running code planted by a malicious third party.
480 -- Furthermore, We only read ./.ghci if . is owned by the current user
481 -- and isn't writable by anyone else. I think this is sufficient: we
482 -- don't need to check .. and ../.. etc. because "." always refers to
483 -- the same directory while a process is running.
485 checkPerms :: String -> IO Bool
486 #ifdef mingw32_HOST_OS
491 handleIO (\_ -> return False) $ do
492 st <- getFileStatus name
494 if fileOwner st /= me then do
495 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
498 let mode = fileMode st
499 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
500 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
502 putStrLn $ "*** WARNING: " ++ name ++
503 " is writable by someone else, IGNORING!"
508 fileLoop :: MonadIO m => Handle -> InputT m (Maybe String)
510 l <- liftIO $ IO.try $ hGetLine hdl
512 Left e | isEOFError e -> return Nothing
513 | InvalidArgument <- etype -> return Nothing
514 | otherwise -> liftIO $ ioError e
515 where etype = ioeGetErrorType e
516 -- treat InvalidArgument in the same way as EOF:
517 -- this can happen if the user closed stdin, or
518 -- perhaps did getContents which closes stdin at
520 Right l -> return (Just l)
522 mkPrompt :: GHCi String
524 (toplevs,exports) <- GHC.getContext
525 resumes <- GHC.getResumeContext
526 -- st <- getGHCiState
532 let ix = GHC.resumeHistoryIx r
534 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
536 let hist = GHC.resumeHistory r !! (ix-1)
537 span <- GHC.getHistorySpan hist
538 return (brackets (ppr (negate ix) <> char ':'
539 <+> ppr span) <> space)
541 dots | _:rs <- resumes, not (null rs) = text "... "
548 -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
549 -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
550 -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
551 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
552 hsep (map (ppr . GHC.moduleName) exports)
554 deflt_prompt = dots <> context_bit <> modules_bit
556 f ('%':'s':xs) = deflt_prompt <> f xs
557 f ('%':'%':xs) = char '%' <> f xs
558 f (x:xs) = char x <> f xs
562 return (showSDoc (f (prompt st)))
565 queryQueue :: GHCi (Maybe String)
570 c:cs -> do setGHCiState st{ cmdqueue = cs }
573 runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
574 runCommands = runCommands' handler
576 runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
577 -> InputT GHCi (Maybe String) -> InputT GHCi ()
578 runCommands' eh getCmd = do
579 b <- ghandle (\e -> case fromException e of
580 Just UserInterrupt -> return False
581 _ -> case fromException e of
583 do liftIO (print (ghc_e :: GhcException))
586 liftIO (Exception.throwIO e))
587 (runOneCommand eh getCmd)
588 if b then return () else runCommands' eh getCmd
590 runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
592 runOneCommand eh getCmd = do
593 mb_cmd <- noSpace (lift queryQueue)
594 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
596 Nothing -> return True
597 Just c -> ghciHandle (lift . eh) $
598 handleSourceError printErrorAndKeepGoing
601 printErrorAndKeepGoing err = do
602 GHC.printExceptionAndWarnings err
605 noSpace q = q >>= maybe (return Nothing)
606 (\c->case removeSpaces c of
608 ":{" -> multiLineCmd q
609 c -> return (Just c) )
611 st <- lift getGHCiState
613 lift $ setGHCiState st{ prompt = "%s| " }
614 mb_cmd <- collectCommand q ""
615 lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p }
617 -- we can't use removeSpaces for the sublines here, so
618 -- multiline commands are somewhat more brittle against
619 -- fileformat errors (such as \r in dos input on unix),
620 -- we get rid of any extra spaces for the ":}" test;
621 -- we also avoid silent failure if ":}" is not found;
622 -- and since there is no (?) valid occurrence of \r (as
623 -- opposed to its String representation, "\r") inside a
624 -- ghci command, we replace any such with ' ' (argh:-(
625 collectCommand q c = q >>=
626 maybe (liftIO (ioError collectError))
627 (\l->if removeSpaces l == ":}"
628 then return (Just $ removeSpaces c)
629 else collectCommand q (c ++ "\n" ++ map normSpace l))
630 where normSpace '\r' = ' '
632 -- QUESTION: is userError the one to use here?
633 collectError = userError "unterminated multiline command :{ .. :}"
634 doCommand (':' : cmd) = specialCommand cmd
635 doCommand stmt = do _ <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion
638 enqueueCommands :: [String] -> GHCi ()
639 enqueueCommands cmds = do
641 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
644 runStmt :: String -> SingleStep -> GHCi Bool
646 | null (filter (not.isSpace) stmt) = return False
647 | ["import", mod] <- words stmt = keepGoing' setContext ('+':mod)
650 #if __GLASGOW_HASKELL__ >= 611
651 -- In the new IO library, read handles buffer data even if the Handle
652 -- is set to NoBuffering. This causes problems for GHCi where there
653 -- are really two stdin Handles. So we flush any bufferred data in
654 -- GHCi's stdin Handle here (only relevant if stdin is attached to
655 -- a file, otherwise the read buffer can't be flushed).
656 _ <- liftIO $ IO.try $ hFlushAll stdin
658 result <- GhciMonad.runStmt stmt step
659 afterRunStmt (const True) result
661 --afterRunStmt :: GHC.RunResult -> GHCi Bool
662 -- False <=> the statement failed to compile
663 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
664 afterRunStmt _ (GHC.RunException e) = throw e
665 afterRunStmt step_here run_result = do
666 resumes <- GHC.getResumeContext
668 GHC.RunOk names -> do
669 show_types <- isOptionSet ShowType
670 when show_types $ printTypeOfNames names
671 GHC.RunBreak _ names mb_info
672 | isNothing mb_info ||
673 step_here (GHC.resumeSpan $ head resumes) -> do
674 mb_id_loc <- toBreakIdAndLocation mb_info
675 let breakCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
677 then printStoppedAtBreakInfo (head resumes) names
678 else enqueueCommands [breakCmd]
679 -- run the command set with ":set stop <cmd>"
681 enqueueCommands [stop st]
683 | otherwise -> resume step_here GHC.SingleStep >>=
684 afterRunStmt step_here >> return ()
688 io installSignalHandlers
689 b <- isOptionSet RevertCAFs
692 return (case run_result of GHC.RunOk _ -> True; _ -> False)
694 toBreakIdAndLocation ::
695 Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
696 toBreakIdAndLocation Nothing = return Nothing
697 toBreakIdAndLocation (Just info) = do
698 let mod = GHC.breakInfo_module info
699 nm = GHC.breakInfo_number info
701 return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
702 breakModule loc == mod,
703 breakTick loc == nm ]
705 printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
706 printStoppedAtBreakInfo resume names = do
707 printForUser $ ptext (sLit "Stopped at") <+>
708 ppr (GHC.resumeSpan resume)
709 -- printTypeOfNames session names
710 let namesSorted = sortBy compareNames names
711 tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
712 docs <- pprTypeAndContents [id | AnId id <- tythings]
713 printForUserPartWay docs
715 printTypeOfNames :: [Name] -> GHCi ()
716 printTypeOfNames names
717 = mapM_ (printTypeOfName ) $ sortBy compareNames names
719 compareNames :: Name -> Name -> Ordering
720 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
721 where compareWith n = (getOccString n, getSrcSpan n)
723 printTypeOfName :: Name -> GHCi ()
725 = do maybe_tything <- GHC.lookupName n
726 case maybe_tything of
728 Just thing -> printTyThing thing
731 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
733 specialCommand :: String -> InputT GHCi Bool
734 specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
735 specialCommand str = do
736 let (cmd,rest) = break isSpace str
737 maybe_cmd <- lift $ lookupCommand cmd
739 GotCommand (_,f,_) -> f (dropWhile isSpace rest)
741 do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
745 do liftIO $ hPutStr stdout ("there is no last command to perform\n"
749 lookupCommand :: String -> GHCi (MaybeCommand)
750 lookupCommand "" = do
752 case last_command st of
753 Just c -> return $ GotCommand c
754 Nothing -> return NoLastCommand
755 lookupCommand str = do
756 mc <- io $ lookupCommand' str
758 setGHCiState st{ last_command = mc }
760 Just c -> GotCommand c
761 Nothing -> BadCommand
763 lookupCommand' :: String -> IO (Maybe Command)
764 lookupCommand' ":" = return Nothing
765 lookupCommand' str' = do
766 macros <- readIORef macros_ref
767 let{ (str, cmds) = case str' of
768 ':' : rest -> (rest, builtin_commands)
769 _ -> (str', macros ++ builtin_commands) }
770 -- look for exact match first, then the first prefix match
771 return $ case [ c | c <- cmds, str == cmdName c ] of
773 [] -> case [ c | c@(s,_,_) <- cmds, str `isPrefixOf` s ] of
777 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
778 getCurrentBreakSpan = do
779 resumes <- GHC.getResumeContext
783 let ix = GHC.resumeHistoryIx r
785 then return (Just (GHC.resumeSpan r))
787 let hist = GHC.resumeHistory r !! (ix-1)
788 span <- GHC.getHistorySpan hist
791 getCurrentBreakModule :: GHCi (Maybe Module)
792 getCurrentBreakModule = do
793 resumes <- GHC.getResumeContext
797 let ix = GHC.resumeHistoryIx r
799 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
801 let hist = GHC.resumeHistory r !! (ix-1)
802 return $ Just $ GHC.getHistoryModule hist
804 -----------------------------------------------------------------------------
807 noArgs :: GHCi () -> String -> GHCi ()
809 noArgs _ _ = io $ putStrLn "This command takes no arguments"
811 help :: String -> GHCi ()
812 help _ = io (putStr helpText)
814 info :: String -> InputT GHCi ()
815 info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
816 info s = handleSourceError GHC.printExceptionAndWarnings $ do
817 { let names = words s
818 ; dflags <- getDynFlags
819 ; let pefas = dopt Opt_PrintExplicitForalls dflags
820 ; mapM_ (infoThing pefas) names }
822 infoThing pefas str = do
823 names <- GHC.parseName str
824 mb_stuffs <- mapM GHC.getInfo names
825 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
826 unqual <- GHC.getPrintUnqual
827 outputStrLn $ showSDocForUser unqual $
828 vcat (intersperse (text "") $
829 map (pprInfo pefas) filtered)
831 -- Filter out names whose parent is also there Good
832 -- example is '[]', which is both a type and data
833 -- constructor in the same type
834 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
835 filterOutChildren get_thing xs
836 = filterOut has_parent xs
838 all_names = mkNameSet (map (getName . get_thing) xs)
839 has_parent x = case pprTyThingParent_maybe (get_thing x) of
840 Just p -> getName p `elemNameSet` all_names
843 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
844 pprInfo pefas (thing, fixity, insts)
845 = pprTyThingInContextLoc pefas thing
846 $$ show_fixity fixity
847 $$ vcat (map GHC.pprInstance insts)
850 | fix == GHC.defaultFixity = empty
851 | otherwise = ppr fix <+> ppr (GHC.getName thing)
853 runMain :: String -> GHCi ()
854 runMain s = case toArgs s of
855 Left err -> io (hPutStrLn stderr err)
857 do dflags <- getDynFlags
858 case mainFunIs dflags of
859 Nothing -> doWithArgs args "main"
860 Just f -> doWithArgs args f
862 runRun :: String -> GHCi ()
863 runRun s = case toCmdArgs s of
864 Left err -> io (hPutStrLn stderr err)
865 Right (cmd, args) -> doWithArgs args cmd
867 doWithArgs :: [String] -> String -> GHCi ()
868 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
869 show args ++ " (" ++ cmd ++ ")"]
871 addModule :: [FilePath] -> InputT GHCi ()
873 lift revertCAFs -- always revert CAFs on load/add.
874 files <- mapM expandPath files
875 targets <- mapM (\m -> GHC.guessTarget m Nothing) files
876 -- remove old targets with the same id; e.g. for :add *M
877 mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
878 mapM_ GHC.addTarget targets
879 prev_context <- GHC.getContext
880 ok <- trySuccess $ GHC.load LoadAllTargets
881 afterLoad ok False prev_context
883 changeDirectory :: String -> InputT GHCi ()
884 changeDirectory "" = do
885 -- :cd on its own changes to the user's home directory
886 either_dir <- liftIO $ IO.try getHomeDirectory
889 Right dir -> changeDirectory dir
890 changeDirectory dir = do
891 graph <- GHC.getModuleGraph
892 when (not (null graph)) $
893 outputStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
894 prev_context <- GHC.getContext
896 _ <- GHC.load LoadAllTargets
897 lift $ setContextAfterLoad prev_context False []
898 GHC.workingDirectoryChanged
899 dir <- expandPath dir
900 liftIO $ setCurrentDirectory dir
902 trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
904 handleSourceError (\e -> do GHC.printExceptionAndWarnings e
908 editFile :: String -> GHCi ()
910 do file <- if null str then chooseEditFile else return str
914 $ ghcError (CmdLineError "editor not set, use :set editor")
915 _ <- io $ system (cmd ++ ' ':file)
918 -- The user didn't specify a file so we pick one for them.
919 -- Our strategy is to pick the first module that failed to load,
920 -- or otherwise the first target.
922 -- XXX: Can we figure out what happened if the depndecy analysis fails
923 -- (e.g., because the porgrammeer mistyped the name of a module)?
924 -- XXX: Can we figure out the location of an error to pass to the editor?
925 -- XXX: if we could figure out the list of errors that occured during the
926 -- last load/reaload, then we could start the editor focused on the first
928 chooseEditFile :: GHCi String
930 do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
932 graph <- GHC.getModuleGraph
933 failed_graph <- filterM hasFailed graph
934 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
936 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
939 case pick (order failed_graph) of
940 Just file -> return file
942 do targets <- GHC.getTargets
943 case msum (map fromTarget targets) of
944 Just file -> return file
945 Nothing -> ghcError (CmdLineError "No files to edit.")
947 where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
948 fromTarget _ = Nothing -- when would we get a module target?
950 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
951 defineMacro _ (':':_) =
952 io $ putStrLn "macro name cannot start with a colon"
953 defineMacro overwrite s = do
954 let (macro_name, definition) = break isSpace s
955 macros <- io (readIORef macros_ref)
956 let defined = map cmdName macros
959 then io $ putStrLn "no macros defined"
960 else io $ putStr ("the following macros are defined:\n" ++
963 if (not overwrite && macro_name `elem` defined)
964 then ghcError (CmdLineError
965 ("macro '" ++ macro_name ++ "' is already defined"))
968 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
970 -- give the expression a type signature, so we can be sure we're getting
971 -- something of the right type.
972 let new_expr = '(' : definition ++ ") :: String -> IO String"
974 -- compile the expression
975 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
976 hv <- GHC.compileExpr new_expr
977 io (writeIORef macros_ref --
978 (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)]))
980 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
982 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
983 -- make sure we force any exceptions in the result, while we are still
984 -- inside the exception handler for commands:
985 seqList str (return ())
986 enqueueCommands (lines str)
989 undefineMacro :: String -> GHCi ()
990 undefineMacro str = mapM_ undef (words str)
991 where undef macro_name = do
992 cmds <- io (readIORef macros_ref)
993 if (macro_name `notElem` map cmdName cmds)
994 then ghcError (CmdLineError
995 ("macro '" ++ macro_name ++ "' is not defined"))
997 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
999 cmdCmd :: String -> GHCi ()
1001 let expr = '(' : str ++ ") :: IO String"
1002 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1003 hv <- GHC.compileExpr expr
1004 cmds <- io $ (unsafeCoerce# hv :: IO String)
1005 enqueueCommands (lines cmds)
1008 loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
1009 loadModule fs = timeIt (loadModule' fs)
1011 loadModule_ :: [FilePath] -> InputT GHCi ()
1012 loadModule_ fs = loadModule (zip fs (repeat Nothing)) >> return ()
1014 loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
1015 loadModule' files = do
1016 prev_context <- GHC.getContext
1020 lift discardActiveBreakPoints
1022 _ <- GHC.load LoadAllTargets
1024 let (filenames, phases) = unzip files
1025 exp_filenames <- mapM expandPath filenames
1026 let files' = zip exp_filenames phases
1027 targets <- mapM (uncurry GHC.guessTarget) files'
1029 -- NOTE: we used to do the dependency anal first, so that if it
1030 -- fails we didn't throw away the current set of modules. This would
1031 -- require some re-working of the GHC interface, so we'll leave it
1032 -- as a ToDo for now.
1034 GHC.setTargets targets
1035 doLoad False prev_context LoadAllTargets
1037 checkModule :: String -> InputT GHCi ()
1039 let modl = GHC.mkModuleName m
1040 prev_context <- GHC.getContext
1041 ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do
1042 r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
1043 outputStrLn (showSDoc (
1044 case GHC.moduleInfo r of
1045 cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1047 (local,global) = ASSERT( all isExternalName scope )
1048 partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1050 (text "global names: " <+> ppr global) $$
1051 (text "local names: " <+> ppr local)
1054 afterLoad (successIf ok) False prev_context
1056 reloadModule :: String -> InputT GHCi ()
1058 prev_context <- GHC.getContext
1059 _ <- doLoad True prev_context $
1060 if null m then LoadAllTargets
1061 else LoadUpTo (GHC.mkModuleName m)
1064 doLoad :: Bool -> ([Module],[Module]) -> LoadHowMuch -> InputT GHCi SuccessFlag
1065 doLoad retain_context prev_context howmuch = do
1066 -- turn off breakpoints before we load: we can't turn them off later, because
1067 -- the ModBreaks will have gone away.
1068 lift discardActiveBreakPoints
1069 ok <- trySuccess $ GHC.load howmuch
1070 afterLoad ok retain_context prev_context
1073 afterLoad :: SuccessFlag -> Bool -> ([Module],[Module]) -> InputT GHCi ()
1074 afterLoad ok retain_context prev_context = do
1075 lift revertCAFs -- always revert CAFs on load.
1076 lift discardTickArrays
1077 loaded_mod_summaries <- getLoadedModules
1078 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1079 loaded_mod_names = map GHC.moduleName loaded_mods
1080 modulesLoadedMsg ok loaded_mod_names
1082 lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
1085 setContextAfterLoad :: ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi ()
1086 setContextAfterLoad prev keep_ctxt [] = do
1087 prel_mod <- getPrelude
1088 setContextKeepingPackageModules prev keep_ctxt ([], [prel_mod])
1089 setContextAfterLoad prev keep_ctxt ms = do
1090 -- load a target if one is available, otherwise load the topmost module.
1091 targets <- GHC.getTargets
1092 case [ m | Just m <- map (findTarget ms) targets ] of
1094 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1095 load_this (last graph')
1100 = case filter (`matches` t) ms of
1104 summary `matches` Target (TargetModule m) _ _
1105 = GHC.ms_mod_name summary == m
1106 summary `matches` Target (TargetFile f _) _ _
1107 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1111 load_this summary | m <- GHC.ms_mod summary = do
1112 b <- GHC.moduleIsInterpreted m
1113 if b then setContextKeepingPackageModules prev keep_ctxt ([m], [])
1115 prel_mod <- getPrelude
1116 setContextKeepingPackageModules prev keep_ctxt ([],[prel_mod,m])
1118 -- | Keep any package modules (except Prelude) when changing the context.
1119 setContextKeepingPackageModules
1120 :: ([Module],[Module]) -- previous context
1121 -> Bool -- re-execute :module commands
1122 -> ([Module],[Module]) -- new context
1124 setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do
1125 let (_,bs0) = prev_context
1126 prel_mod <- getPrelude
1127 let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1128 let bs1 = if null as then nub (prel_mod : bs) else bs
1129 GHC.setContext as (nub (bs1 ++ pkg_modules))
1133 mapM_ (playCtxtCmd False) (remembered_ctx st)
1136 setGHCiState st{ remembered_ctx = [] }
1138 isHomeModule :: Module -> Bool
1139 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1141 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi ()
1142 modulesLoadedMsg ok mods = do
1143 dflags <- getDynFlags
1144 when (verbosity dflags > 0) $ do
1146 | null mods = text "none."
1147 | otherwise = hsep (
1148 punctuate comma (map ppr mods)) <> text "."
1151 outputStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))
1153 outputStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas))
1156 typeOfExpr :: String -> InputT GHCi ()
1158 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1159 ty <- GHC.exprType str
1160 dflags <- getDynFlags
1161 let pefas = dopt Opt_PrintExplicitForalls dflags
1162 printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]
1164 kindOfType :: String -> InputT GHCi ()
1166 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1167 ty <- GHC.typeKind str
1168 printForUser $ text str <+> dcolon <+> ppr ty
1170 quit :: String -> InputT GHCi Bool
1171 quit _ = return True
1173 shellEscape :: String -> GHCi Bool
1174 shellEscape str = io (system str >> return False)
1176 -----------------------------------------------------------------------------
1177 -- Browsing a module's contents
1179 browseCmd :: Bool -> String -> InputT GHCi ()
1182 ['*':s] | looksLikeModuleName s -> do
1183 m <- lift $ wantInterpretedModule s
1184 browseModule bang m False
1185 [s] | looksLikeModuleName s -> do
1186 m <- lift $ lookupModule s
1187 browseModule bang m True
1189 (as,bs) <- GHC.getContext
1190 -- Guess which module the user wants to browse. Pick
1191 -- modules that are interpreted first. The most
1192 -- recently-added module occurs last, it seems.
1194 (as@(_:_), _) -> browseModule bang (last as) True
1195 ([], bs@(_:_)) -> browseModule bang (last bs) True
1196 ([], []) -> ghcError (CmdLineError ":browse: no current module")
1197 _ -> ghcError (CmdLineError "syntax: :browse <module>")
1199 -- without bang, show items in context of their parents and omit children
1200 -- with bang, show class methods and data constructors separately, and
1201 -- indicate import modules, to aid qualifying unqualified names
1202 -- with sorted, sort items alphabetically
1203 browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
1204 browseModule bang modl exports_only = do
1205 -- :browse! reports qualifiers wrt current context
1206 current_unqual <- GHC.getPrintUnqual
1207 -- Temporarily set the context to the module we're interested in,
1208 -- just so we can get an appropriate PrintUnqualified
1209 (as,bs) <- GHC.getContext
1210 prel_mod <- lift getPrelude
1211 if exports_only then GHC.setContext [] [prel_mod,modl]
1212 else GHC.setContext [modl] []
1213 target_unqual <- GHC.getPrintUnqual
1214 GHC.setContext as bs
1216 let unqual = if bang then current_unqual else target_unqual
1218 mb_mod_info <- GHC.getModuleInfo modl
1220 Nothing -> ghcError (CmdLineError ("unknown module: " ++
1221 GHC.moduleNameString (GHC.moduleName modl)))
1223 dflags <- getDynFlags
1225 | exports_only = GHC.modInfoExports mod_info
1226 | otherwise = GHC.modInfoTopLevelScope mod_info
1229 -- sort alphabetically name, but putting
1230 -- locally-defined identifiers first.
1231 -- We would like to improve this; see #1799.
1232 sorted_names = loc_sort local ++ occ_sort external
1234 (local,external) = ASSERT( all isExternalName names )
1235 partition ((==modl) . nameModule) names
1236 occ_sort = sortBy (compare `on` nameOccName)
1237 -- try to sort by src location. If the first name in
1238 -- our list has a good source location, then they all should.
1240 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1241 = sortBy (compare `on` nameSrcSpan) names
1245 mb_things <- mapM GHC.lookupName sorted_names
1246 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1248 rdr_env <- GHC.getGRE
1250 let pefas = dopt Opt_PrintExplicitForalls dflags
1251 things | bang = catMaybes mb_things
1252 | otherwise = filtered_things
1253 pretty | bang = pprTyThing
1254 | otherwise = pprTyThingInContext
1256 labels [] = text "-- not currently imported"
1257 labels l = text $ intercalate "\n" $ map qualifier l
1258 qualifier = maybe "-- defined locally"
1259 (("-- imported via "++) . intercalate ", "
1260 . map GHC.moduleNameString)
1261 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1262 modNames = map (importInfo . GHC.getName) things
1264 -- annotate groups of imports with their import modules
1265 -- the default ordering is somewhat arbitrary, so we group
1266 -- by header and sort groups; the names themselves should
1267 -- really come in order of source appearance.. (trac #1799)
1268 annotate mts = concatMap (\(m,ts)->labels m:ts)
1269 $ sortBy cmpQualifiers $ group mts
1270 where cmpQualifiers =
1271 compare `on` (map (fmap (map moduleNameFS)) . fst)
1273 group mts@((m,_):_) = (m,map snd g) : group ng
1274 where (g,ng) = partition ((==m).fst) mts
1276 let prettyThings = map (pretty pefas) things
1277 prettyThings' | bang = annotate $ zip modNames prettyThings
1278 | otherwise = prettyThings
1279 outputStrLn $ showSDocForUser unqual (vcat prettyThings')
1280 -- ToDo: modInfoInstances currently throws an exception for
1281 -- package modules. When it works, we can do this:
1282 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1284 -----------------------------------------------------------------------------
1285 -- Setting the module context
1287 setContext :: String -> GHCi ()
1289 | all sensible strs = do
1290 playCtxtCmd True (cmd, as, bs)
1292 setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] }
1293 | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1295 (cmd, strs, as, bs) =
1297 '+':stuff -> rest AddModules stuff
1298 '-':stuff -> rest RemModules stuff
1299 stuff -> rest SetContext stuff
1301 rest cmd stuff = (cmd, strs, as, bs)
1302 where strs = words stuff
1303 (as,bs) = partitionWith starred strs
1305 sensible ('*':m) = looksLikeModuleName m
1306 sensible m = looksLikeModuleName m
1308 starred ('*':m) = Left m
1311 playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi ()
1312 playCtxtCmd fail (cmd, as, bs)
1314 (as',bs') <- do_checks fail
1315 (prev_as,prev_bs) <- GHC.getContext
1319 prel_mod <- getPrelude
1320 let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs'
1324 let as_to_add = as' \\ (prev_as ++ prev_bs)
1325 bs_to_add = bs' \\ (prev_as ++ prev_bs)
1326 return (prev_as ++ as_to_add, prev_bs ++ bs_to_add)
1328 let new_as = prev_as \\ (as' ++ bs')
1329 new_bs = prev_bs \\ (as' ++ bs')
1330 return (new_as, new_bs)
1331 GHC.setContext new_as new_bs
1334 as' <- mapM wantInterpretedModule as
1335 bs' <- mapM lookupModule bs
1337 do_checks False = do
1338 as' <- mapM (trymaybe . wantInterpretedModule) as
1339 bs' <- mapM (trymaybe . lookupModule) bs
1340 return (catMaybes as', catMaybes bs')
1345 Left _ -> return Nothing
1346 Right a -> return (Just a)
1348 ----------------------------------------------------------------------------
1351 -- set options in the interpreter. Syntax is exactly the same as the
1352 -- ghc command line, except that certain options aren't available (-C,
1355 -- This is pretty fragile: most options won't work as expected. ToDo:
1356 -- figure out which ones & disallow them.
1358 setCmd :: String -> GHCi ()
1360 = do st <- getGHCiState
1361 let opts = options st
1362 io $ putStrLn (showSDoc (
1363 text "options currently set: " <>
1366 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1368 dflags <- getDynFlags
1369 io $ putStrLn (showSDoc (
1370 vcat (text "GHCi-specific dynamic flag settings:"
1371 :map (flagSetting dflags) ghciFlags)
1373 io $ putStrLn (showSDoc (
1374 vcat (text "other dynamic, non-language, flag settings:"
1375 :map (flagSetting dflags) nonLanguageDynFlags)
1377 where flagSetting dflags (str, f, _)
1378 | dopt f dflags = text " " <> text "-f" <> text str
1379 | otherwise = text " " <> text "-fno-" <> text str
1380 (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags)
1382 nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions)
1384 flags = [Opt_PrintExplicitForalls
1385 ,Opt_PrintBindResult
1386 ,Opt_BreakOnException
1388 ,Opt_PrintEvldWithShow
1391 = case getCmd str of
1392 Right ("args", rest) ->
1394 Left err -> io (hPutStrLn stderr err)
1395 Right args -> setArgs args
1396 Right ("prog", rest) ->
1398 Right [prog] -> setProg prog
1399 _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")
1400 Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1401 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1402 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1403 _ -> case toArgs str of
1404 Left err -> io (hPutStrLn stderr err)
1405 Right wds -> setOptions wds
1407 setArgs, setOptions :: [String] -> GHCi ()
1408 setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
1412 setGHCiState st{ args = args }
1416 setGHCiState st{ progname = prog }
1420 setGHCiState st{ editor = cmd }
1422 setStop str@(c:_) | isDigit c
1423 = do let (nm_str,rest) = break (not.isDigit) str
1426 let old_breaks = breaks st
1427 if all ((/= nm) . fst) old_breaks
1428 then printForUser (text "Breakpoint" <+> ppr nm <+>
1429 text "does not exist")
1431 let new_breaks = map fn old_breaks
1432 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1433 | otherwise = (i,loc)
1434 setGHCiState st{ breaks = new_breaks }
1437 setGHCiState st{ stop = cmd }
1439 setPrompt value = do
1442 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1444 '\"' : _ -> case reads value of
1445 [(value', xs)] | all isSpace xs ->
1446 setGHCiState (st { prompt = value' })
1448 io $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
1449 _ -> setGHCiState (st { prompt = value })
1452 do -- first, deal with the GHCi opts (+s, +t, etc.)
1453 let (plus_opts, minus_opts) = partitionWith isPlus wds
1454 mapM_ setOpt plus_opts
1455 -- then, dynamic flags
1456 newDynFlags minus_opts
1458 newDynFlags :: [String] -> GHCi ()
1459 newDynFlags minus_opts = do
1460 dflags <- getDynFlags
1461 let pkg_flags = packageFlags dflags
1462 (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
1463 handleFlagWarnings dflags' warns
1465 if (not (null leftovers))
1466 then ghcError $ errorsToGhcException leftovers
1469 new_pkgs <- setDynFlags dflags'
1471 -- if the package flags changed, we should reset the context
1472 -- and link the new packages.
1473 dflags <- getDynFlags
1474 when (packageFlags dflags /= pkg_flags) $ do
1475 io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
1477 _ <- GHC.load LoadAllTargets
1478 io (linkPackages dflags new_pkgs)
1479 -- package flags changed, we can't re-use any of the old context
1480 setContextAfterLoad ([],[]) False []
1484 unsetOptions :: String -> GHCi ()
1486 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1487 let opts = words str
1488 (minus_opts, rest1) = partition isMinus opts
1489 (plus_opts, rest2) = partitionWith isPlus rest1
1491 if (not (null rest2))
1492 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1495 mapM_ unsetOpt plus_opts
1497 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1498 no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
1500 no_flags <- mapM no_flag minus_opts
1501 newDynFlags no_flags
1503 isMinus :: String -> Bool
1504 isMinus ('-':_) = True
1507 isPlus :: String -> Either String String
1508 isPlus ('+':opt) = Left opt
1509 isPlus other = Right other
1511 setOpt, unsetOpt :: String -> GHCi ()
1514 = case strToGHCiOpt str of
1515 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1516 Just o -> setOption o
1519 = case strToGHCiOpt str of
1520 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1521 Just o -> unsetOption o
1523 strToGHCiOpt :: String -> (Maybe GHCiOption)
1524 strToGHCiOpt "s" = Just ShowTiming
1525 strToGHCiOpt "t" = Just ShowType
1526 strToGHCiOpt "r" = Just RevertCAFs
1527 strToGHCiOpt _ = Nothing
1529 optToStr :: GHCiOption -> String
1530 optToStr ShowTiming = "s"
1531 optToStr ShowType = "t"
1532 optToStr RevertCAFs = "r"
1534 -- ---------------------------------------------------------------------------
1537 showCmd :: String -> GHCi ()
1541 ["args"] -> io $ putStrLn (show (args st))
1542 ["prog"] -> io $ putStrLn (show (progname st))
1543 ["prompt"] -> io $ putStrLn (show (prompt st))
1544 ["editor"] -> io $ putStrLn (show (editor st))
1545 ["stop"] -> io $ putStrLn (show (stop st))
1546 ["modules" ] -> showModules
1547 ["bindings"] -> showBindings
1548 ["linker"] -> io showLinkerState
1549 ["breaks"] -> showBkptTable
1550 ["context"] -> showContext
1551 ["packages"] -> showPackages
1552 ["languages"] -> showLanguages
1553 _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
1554 " | breaks | context | packages | languages ]"))
1556 showModules :: GHCi ()
1558 loaded_mods <- getLoadedModules
1559 -- we want *loaded* modules only, see #1734
1560 let show_one ms = do m <- GHC.showModule ms; io (putStrLn m)
1561 mapM_ show_one loaded_mods
1563 getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
1564 getLoadedModules = do
1565 graph <- GHC.getModuleGraph
1566 filterM (GHC.isLoaded . GHC.ms_mod_name) graph
1568 showBindings :: GHCi ()
1570 bindings <- GHC.getBindings
1571 docs <- pprTypeAndContents
1572 [ id | AnId id <- sortBy compareTyThings bindings]
1573 printForUserPartWay docs
1575 compareTyThings :: TyThing -> TyThing -> Ordering
1576 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1578 printTyThing :: TyThing -> GHCi ()
1579 printTyThing tyth = do dflags <- getDynFlags
1580 let pefas = dopt Opt_PrintExplicitForalls dflags
1581 printForUser (pprTyThing pefas tyth)
1583 showBkptTable :: GHCi ()
1586 printForUser $ prettyLocations (breaks st)
1588 showContext :: GHCi ()
1590 resumes <- GHC.getResumeContext
1591 printForUser $ vcat (map pp_resume (reverse resumes))
1594 ptext (sLit "--> ") <> text (GHC.resumeStmt resume)
1595 $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume))
1597 showPackages :: GHCi ()
1599 pkg_flags <- fmap packageFlags getDynFlags
1600 io $ putStrLn $ showSDoc $ vcat $
1601 text ("active package flags:"++if null pkg_flags then " none" else "")
1602 : map showFlag pkg_flags
1603 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1604 io $ putStrLn $ showSDoc $ vcat $
1605 text "packages currently loaded:"
1606 : map (nest 2 . text . packageIdString)
1607 (sortBy (compare `on` packageIdFS) pkg_ids)
1608 where showFlag (ExposePackage p) = text $ " -package " ++ p
1609 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1610 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1611 showFlag (ExposePackageId p) = text $ " -package-id " ++ p
1613 showLanguages :: GHCi ()
1615 dflags <- getDynFlags
1616 io $ putStrLn $ showSDoc $ vcat $
1617 text "active language flags:" :
1618 [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags]
1620 -- -----------------------------------------------------------------------------
1623 completeCmd, completeMacro, completeIdentifier, completeModule,
1624 completeHomeModule, completeSetOptions, completeShowOptions,
1625 completeHomeModuleOrFile, completeExpression
1626 :: CompletionFunc GHCi
1628 ghciCompleteWord :: CompletionFunc GHCi
1629 ghciCompleteWord line@(left,_) = case firstWord of
1630 ':':cmd | null rest -> completeCmd line
1632 completion <- lookupCompletion cmd
1634 "import" -> completeModule line
1635 _ -> completeExpression line
1637 (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
1638 lookupCompletion ('!':_) = return completeFilename
1639 lookupCompletion c = do
1640 maybe_cmd <- liftIO $ lookupCommand' c
1642 Just (_,_,f) -> return f
1643 Nothing -> return completeFilename
1645 completeCmd = wrapCompleter " " $ \w -> do
1646 macros <- liftIO $ readIORef macros_ref
1647 let macro_names = map (':':) . map cmdName $ macros
1648 let command_names = map (':':) . map cmdName $ builtin_commands
1649 let{ candidates = case w of
1650 ':' : ':' : _ -> map (':':) command_names
1651 _ -> nub $ macro_names ++ command_names }
1652 return $ filter (w `isPrefixOf`) candidates
1654 completeMacro = wrapIdentCompleter $ \w -> do
1655 cmds <- liftIO $ readIORef macros_ref
1656 return (filter (w `isPrefixOf`) (map cmdName cmds))
1658 completeIdentifier = wrapIdentCompleter $ \w -> do
1659 rdrs <- GHC.getRdrNamesInScope
1660 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1662 completeModule = wrapIdentCompleter $ \w -> do
1663 dflags <- GHC.getSessionDynFlags
1664 let pkg_mods = allExposedModules dflags
1665 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
1666 return $ filter (w `isPrefixOf`)
1667 $ map (showSDoc.ppr) $ loaded_mods ++ pkg_mods
1669 completeHomeModule = wrapIdentCompleter listHomeModules
1671 listHomeModules :: String -> GHCi [String]
1672 listHomeModules w = do
1673 g <- GHC.getModuleGraph
1674 let home_mods = map GHC.ms_mod_name g
1675 return $ sort $ filter (w `isPrefixOf`)
1676 $ map (showSDoc.ppr) home_mods
1678 completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
1679 return (filter (w `isPrefixOf`) options)
1680 where options = "args":"prog":"prompt":"editor":"stop":flagList
1681 flagList = map head $ group $ sort allFlags
1683 completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
1684 return (filter (w `isPrefixOf`) options)
1685 where options = ["args", "prog", "prompt", "editor", "stop",
1686 "modules", "bindings", "linker", "breaks",
1687 "context", "packages", "languages"]
1689 completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
1690 $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
1693 unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
1694 unionComplete f1 f2 line = do
1699 wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
1700 wrapCompleter breakChars fun = completeWord Nothing breakChars
1701 $ fmap (map simpleCompletion) . fmap sort . fun
1703 wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
1704 wrapIdentCompleter = wrapCompleter word_break_chars
1706 allExposedModules :: DynFlags -> [ModuleName]
1707 allExposedModules dflags
1708 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1710 pkg_db = pkgIdMap (pkgState dflags)
1712 completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
1715 -- ---------------------------------------------------------------------------
1716 -- User code exception handling
1718 -- This is the exception handler for exceptions generated by the
1719 -- user's code and exceptions coming from children sessions;
1720 -- it normally just prints out the exception. The
1721 -- handler must be recursive, in case showing the exception causes
1722 -- more exceptions to be raised.
1724 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1725 -- raising another exception. We therefore don't put the recursive
1726 -- handler arond the flushing operation, so if stderr is closed
1727 -- GHCi will just die gracefully rather than going into an infinite loop.
1728 handler :: SomeException -> GHCi Bool
1730 handler exception = do
1732 io installSignalHandlers
1733 ghciHandle handler (showException exception >> return False)
1735 showException :: SomeException -> GHCi ()
1737 io $ case fromException se of
1738 -- omit the location for CmdLineError:
1739 Just (CmdLineError s) -> putStrLn s
1741 Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
1742 Just other_ghc_ex -> print other_ghc_ex
1744 case fromException se of
1745 Just UserInterrupt -> putStrLn "Interrupted."
1746 _other -> putStrLn ("*** Exception: " ++ show se)
1748 -----------------------------------------------------------------------------
1749 -- recursive exception handlers
1751 -- Don't forget to unblock async exceptions in the handler, or if we're
1752 -- in an exception loop (eg. let a = error a in a) the ^C exception
1753 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1755 ghciHandle :: MonadException m => (SomeException -> m a) -> m a -> m a
1756 ghciHandle h m = Haskeline.catch m $ \e -> unblock (h e)
1758 ghciTry :: GHCi a -> GHCi (Either SomeException a)
1759 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
1761 -- ----------------------------------------------------------------------------
1764 -- TODO: won't work if home dir is encoded.
1765 -- (changeDirectory may not work either in that case.)
1766 expandPath :: MonadIO m => String -> InputT m String
1767 expandPath path = do
1768 exp_path <- liftIO $ expandPathIO path
1769 enc <- fmap BS.unpack $ Encoding.encode exp_path
1772 expandPathIO :: String -> IO String
1774 case dropWhile isSpace path of
1776 tilde <- getHomeDirectory -- will fail if HOME not defined
1777 return (tilde ++ '/':d)
1781 wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
1782 wantInterpretedModule str = do
1783 modl <- lookupModule str
1784 dflags <- getDynFlags
1785 when (GHC.modulePackageId modl /= thisPackage dflags) $
1786 ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
1787 is_interpreted <- GHC.moduleIsInterpreted modl
1788 when (not is_interpreted) $
1789 ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
1792 wantNameFromInterpretedModule :: GHC.GhcMonad m
1793 => (Name -> SDoc -> m ())
1797 wantNameFromInterpretedModule noCanDo str and_then =
1798 handleSourceError (GHC.printExceptionAndWarnings) $ do
1799 names <- GHC.parseName str
1803 let modl = ASSERT( isExternalName n ) GHC.nameModule n
1804 if not (GHC.isExternalName n)
1805 then noCanDo n $ ppr n <>
1806 text " is not defined in an interpreted module"
1808 is_interpreted <- GHC.moduleIsInterpreted modl
1809 if not is_interpreted
1810 then noCanDo n $ text "module " <> ppr modl <>
1811 text " is not interpreted"
1814 -- -----------------------------------------------------------------------------
1815 -- commands for debugger
1817 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1818 sprintCmd = pprintCommand False False
1819 printCmd = pprintCommand True False
1820 forceCmd = pprintCommand False True
1822 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1823 pprintCommand bind force str = do
1824 pprintClosureCommand bind force str
1826 stepCmd :: String -> GHCi ()
1827 stepCmd [] = doContinue (const True) GHC.SingleStep
1828 stepCmd expression = runStmt expression GHC.SingleStep >> return ()
1830 stepLocalCmd :: String -> GHCi ()
1831 stepLocalCmd [] = do
1832 mb_span <- getCurrentBreakSpan
1834 Nothing -> stepCmd []
1836 Just mod <- getCurrentBreakModule
1837 current_toplevel_decl <- enclosingTickSpan mod loc
1838 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1840 stepLocalCmd expression = stepCmd expression
1842 stepModuleCmd :: String -> GHCi ()
1843 stepModuleCmd [] = do
1844 mb_span <- getCurrentBreakSpan
1846 Nothing -> stepCmd []
1848 Just span <- getCurrentBreakSpan
1849 let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span
1850 doContinue f GHC.SingleStep
1852 stepModuleCmd expression = stepCmd expression
1854 -- | Returns the span of the largest tick containing the srcspan given
1855 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1856 enclosingTickSpan mod src = do
1857 ticks <- getTickArray mod
1858 let line = srcSpanStartLine src
1859 ASSERT (inRange (bounds ticks) line) do
1860 let enclosing_spans = [ span | (_,span) <- ticks ! line
1861 , srcSpanEnd span >= srcSpanEnd src]
1862 return . head . sortBy leftmost_largest $ enclosing_spans
1864 traceCmd :: String -> GHCi ()
1865 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1866 traceCmd expression = runStmt expression GHC.RunAndLogSteps >> return ()
1868 continueCmd :: String -> GHCi ()
1869 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1871 -- doContinue :: SingleStep -> GHCi ()
1872 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1873 doContinue pred step = do
1874 runResult <- resume pred step
1875 _ <- afterRunStmt pred runResult
1878 abandonCmd :: String -> GHCi ()
1879 abandonCmd = noArgs $ do
1880 b <- GHC.abandon -- the prompt will change to indicate the new context
1881 when (not b) $ io $ putStrLn "There is no computation running."
1884 deleteCmd :: String -> GHCi ()
1885 deleteCmd argLine = do
1886 deleteSwitch $ words argLine
1888 deleteSwitch :: [String] -> GHCi ()
1890 io $ putStrLn "The delete command requires at least one argument."
1891 -- delete all break points
1892 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1893 deleteSwitch idents = do
1894 mapM_ deleteOneBreak idents
1896 deleteOneBreak :: String -> GHCi ()
1898 | all isDigit str = deleteBreak (read str)
1899 | otherwise = return ()
1901 historyCmd :: String -> GHCi ()
1903 | null arg = history 20
1904 | all isDigit arg = history (read arg)
1905 | otherwise = io $ putStrLn "Syntax: :history [num]"
1908 resumes <- GHC.getResumeContext
1910 [] -> io $ putStrLn "Not stopped at a breakpoint"
1912 let hist = GHC.resumeHistory r
1913 (took,rest) = splitAt num hist
1915 [] -> io $ putStrLn $
1916 "Empty history. Perhaps you forgot to use :trace?"
1918 spans <- mapM GHC.getHistorySpan took
1919 let nums = map (printf "-%-3d:") [(1::Int)..]
1920 names = map GHC.historyEnclosingDecl took
1921 printForUser (vcat(zipWith3
1922 (\x y z -> x <+> y <+> z)
1924 (map (bold . ppr) names)
1925 (map (parens . ppr) spans)))
1926 io $ putStrLn $ if null rest then "<end of history>" else "..."
1928 bold :: SDoc -> SDoc
1929 bold c | do_bold = text start_bold <> c <> text end_bold
1932 backCmd :: String -> GHCi ()
1933 backCmd = noArgs $ do
1934 (names, _, span) <- GHC.back
1935 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span
1936 printTypeOfNames names
1937 -- run the command set with ":set stop <cmd>"
1939 enqueueCommands [stop st]
1941 forwardCmd :: String -> GHCi ()
1942 forwardCmd = noArgs $ do
1943 (names, ix, span) <- GHC.forward
1944 printForUser $ (if (ix == 0)
1945 then ptext (sLit "Stopped at")
1946 else ptext (sLit "Logged breakpoint at")) <+> ppr span
1947 printTypeOfNames names
1948 -- run the command set with ":set stop <cmd>"
1950 enqueueCommands [stop st]
1952 -- handle the "break" command
1953 breakCmd :: String -> GHCi ()
1954 breakCmd argLine = do
1955 breakSwitch $ words argLine
1957 breakSwitch :: [String] -> GHCi ()
1959 io $ putStrLn "The break command requires at least one argument."
1960 breakSwitch (arg1:rest)
1961 | looksLikeModuleName arg1 && not (null rest) = do
1962 mod <- wantInterpretedModule arg1
1963 breakByModule mod rest
1964 | all isDigit arg1 = do
1965 (toplevel, _) <- GHC.getContext
1967 (mod : _) -> breakByModuleLine mod (read arg1) rest
1969 io $ putStrLn "Cannot find default module for breakpoint."
1970 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1971 | otherwise = do -- try parsing it as an identifier
1972 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1973 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1974 if GHC.isGoodSrcLoc loc
1975 then ASSERT( isExternalName name )
1976 findBreakAndSet (GHC.nameModule name) $
1977 findBreakByCoord (Just (GHC.srcLocFile loc))
1978 (GHC.srcLocLine loc,
1980 else noCanDo name $ text "can't find its location: " <> ppr loc
1982 noCanDo n why = printForUser $
1983 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1985 breakByModule :: Module -> [String] -> GHCi ()
1986 breakByModule mod (arg1:rest)
1987 | all isDigit arg1 = do -- looks like a line number
1988 breakByModuleLine mod (read arg1) rest
1992 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1993 breakByModuleLine mod line args
1994 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1995 | [col] <- args, all isDigit col =
1996 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1997 | otherwise = breakSyntax
2000 breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
2002 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
2003 findBreakAndSet mod lookupTickTree = do
2004 tickArray <- getTickArray mod
2005 (breakArray, _) <- getModBreak mod
2006 case lookupTickTree tickArray of
2007 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
2008 Just (tick, span) -> do
2009 success <- io $ setBreakFlag True breakArray tick
2013 recordBreak $ BreakLocation
2020 text "Breakpoint " <> ppr nm <>
2022 then text " was already set at " <> ppr span
2023 else text " activated at " <> ppr span
2025 printForUser $ text "Breakpoint could not be activated at"
2028 -- When a line number is specified, the current policy for choosing
2029 -- the best breakpoint is this:
2030 -- - the leftmost complete subexpression on the specified line, or
2031 -- - the leftmost subexpression starting on the specified line, or
2032 -- - the rightmost subexpression enclosing the specified line
2034 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2035 findBreakByLine line arr
2036 | not (inRange (bounds arr) line) = Nothing
2038 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
2039 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2040 listToMaybe (sortBy (rightmost `on` snd) ticks)
2044 starts_here = [ tick | tick@(_,span) <- ticks,
2045 GHC.srcSpanStartLine span == line ]
2047 (complete,incomplete) = partition ends_here starts_here
2048 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2050 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2051 -> Maybe (BreakIndex,SrcSpan)
2052 findBreakByCoord mb_file (line, col) arr
2053 | not (inRange (bounds arr) line) = Nothing
2055 listToMaybe (sortBy (rightmost `on` snd) contains ++
2056 sortBy (leftmost_smallest `on` snd) after_here)
2060 -- the ticks that span this coordinate
2061 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2062 is_correct_file span ]
2064 is_correct_file span
2065 | Just f <- mb_file = GHC.srcSpanFile span == f
2068 after_here = [ tick | tick@(_,span) <- ticks,
2069 GHC.srcSpanStartLine span == line,
2070 GHC.srcSpanStartCol span >= col ]
2072 -- For now, use ANSI bold on terminals that we know support it.
2073 -- Otherwise, we add a line of carets under the active expression instead.
2074 -- In particular, on Windows and when running the testsuite (which sets
2075 -- TERM to vt100 for other reasons) we get carets.
2076 -- We really ought to use a proper termcap/terminfo library.
2078 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2079 where mTerm = System.Environment.getEnv "TERM"
2080 `catchIO` \_ -> return "TERM not set"
2082 start_bold :: String
2083 start_bold = "\ESC[1m"
2085 end_bold = "\ESC[0m"
2087 listCmd :: String -> InputT GHCi ()
2089 mb_span <- lift getCurrentBreakSpan
2092 printForUser $ text "Not stopped at a breakpoint; nothing to list"
2094 | GHC.isGoodSrcSpan span -> listAround span True
2096 do resumes <- GHC.getResumeContext
2098 [] -> panic "No resumes"
2100 do let traceIt = case GHC.resumeHistory r of
2101 [] -> text "rerunning with :trace,"
2103 doWhat = traceIt <+> text ":back then :list"
2104 printForUser (text "Unable to list source for" <+>
2106 $$ text "Try" <+> doWhat)
2107 listCmd str = list2 (words str)
2109 list2 :: [String] -> InputT GHCi ()
2110 list2 [arg] | all isDigit arg = do
2111 (toplevel, _) <- GHC.getContext
2113 [] -> outputStrLn "No module to list"
2114 (mod : _) -> listModuleLine mod (read arg)
2115 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2116 mod <- wantInterpretedModule arg1
2117 listModuleLine mod (read arg2)
2119 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2120 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2121 if GHC.isGoodSrcLoc loc
2123 tickArray <- ASSERT( isExternalName name )
2124 lift $ getTickArray (GHC.nameModule name)
2125 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2126 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2129 Nothing -> listAround (GHC.srcLocSpan loc) False
2130 Just (_,span) -> listAround span False
2132 noCanDo name $ text "can't find its location: " <>
2135 noCanDo n why = printForUser $
2136 text "cannot list source code for " <> ppr n <> text ": " <> why
2138 outputStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2140 listModuleLine :: Module -> Int -> InputT GHCi ()
2141 listModuleLine modl line = do
2142 graph <- GHC.getModuleGraph
2143 let this = filter ((== modl) . GHC.ms_mod) graph
2145 [] -> panic "listModuleLine"
2147 let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
2148 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2149 listAround (GHC.srcLocSpan loc) False
2151 -- | list a section of a source file around a particular SrcSpan.
2152 -- If the highlight flag is True, also highlight the span using
2153 -- start_bold\/end_bold.
2155 -- GHC files are UTF-8, so we can implement this by:
2156 -- 1) read the file in as a BS and syntax highlight it as before
2157 -- 2) convert the BS to String using utf-string, and write it out.
2158 -- It would be better if we could convert directly between UTF-8 and the
2159 -- console encoding, of course.
2160 listAround :: MonadIO m => SrcSpan -> Bool -> InputT m ()
2161 listAround span do_highlight = do
2162 contents <- liftIO $ BS.readFile (unpackFS file)
2164 lines = BS.split '\n' contents
2165 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2166 drop (line1 - 1 - pad_before) $ lines
2167 fst_line = max 1 (line1 - pad_before)
2168 line_nos = [ fst_line .. ]
2170 highlighted | do_highlight = zipWith highlight line_nos these_lines
2171 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2173 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2174 prefixed = zipWith ($) highlighted bs_line_nos
2176 let output = BS.intercalate (BS.pack "\n") prefixed
2177 utf8Decoded <- liftIO $ BS.useAsCStringLen output
2178 $ \(p,n) -> utf8DecodeString (castPtr p) n
2179 outputStrLn utf8Decoded
2181 file = GHC.srcSpanFile span
2182 line1 = GHC.srcSpanStartLine span
2183 col1 = GHC.srcSpanStartCol span - 1
2184 line2 = GHC.srcSpanEndLine span
2185 col2 = GHC.srcSpanEndCol span - 1
2187 pad_before | line1 == 1 = 0
2191 highlight | do_bold = highlight_bold
2192 | otherwise = highlight_carets
2194 highlight_bold no line prefix
2195 | no == line1 && no == line2
2196 = let (a,r) = BS.splitAt col1 line
2197 (b,c) = BS.splitAt (col2-col1) r
2199 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2201 = let (a,b) = BS.splitAt col1 line in
2202 BS.concat [prefix, a, BS.pack start_bold, b]
2204 = let (a,b) = BS.splitAt col2 line in
2205 BS.concat [prefix, a, BS.pack end_bold, b]
2206 | otherwise = BS.concat [prefix, line]
2208 highlight_carets no line prefix
2209 | no == line1 && no == line2
2210 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2211 BS.replicate (col2-col1) '^']
2213 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2216 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2218 | otherwise = BS.concat [prefix, line]
2220 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2221 nl = BS.singleton '\n'
2223 -- --------------------------------------------------------------------------
2226 getTickArray :: Module -> GHCi TickArray
2227 getTickArray modl = do
2229 let arrmap = tickarrays st
2230 case lookupModuleEnv arrmap modl of
2231 Just arr -> return arr
2233 (_breakArray, ticks) <- getModBreak modl
2234 let arr = mkTickArray (assocs ticks)
2235 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2238 discardTickArrays :: GHCi ()
2239 discardTickArrays = do
2241 setGHCiState st{tickarrays = emptyModuleEnv}
2243 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2245 = accumArray (flip (:)) [] (1, max_line)
2246 [ (line, (nm,span)) | (nm,span) <- ticks,
2247 line <- srcSpanLines span ]
2249 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2250 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2251 GHC.srcSpanEndLine span ]
2253 lookupModule :: GHC.GhcMonad m => String -> m Module
2254 lookupModule modName
2255 = GHC.lookupModule (GHC.mkModuleName modName) Nothing
2257 -- don't reset the counter back to zero?
2258 discardActiveBreakPoints :: GHCi ()
2259 discardActiveBreakPoints = do
2261 mapM_ (turnOffBreak.snd) (breaks st)
2262 setGHCiState $ st { breaks = [] }
2264 deleteBreak :: Int -> GHCi ()
2265 deleteBreak identity = do
2267 let oldLocations = breaks st
2268 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2270 then printForUser (text "Breakpoint" <+> ppr identity <+>
2271 text "does not exist")
2273 mapM_ (turnOffBreak.snd) this
2274 setGHCiState $ st { breaks = rest }
2276 turnOffBreak :: BreakLocation -> GHCi Bool
2277 turnOffBreak loc = do
2278 (arr, _) <- getModBreak (breakModule loc)
2279 io $ setBreakFlag False arr (breakTick loc)
2281 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2282 getModBreak mod = do
2283 Just mod_info <- GHC.getModuleInfo mod
2284 let modBreaks = GHC.modInfoModBreaks mod_info
2285 let array = GHC.modBreaks_flags modBreaks
2286 let ticks = GHC.modBreaks_locs modBreaks
2287 return (array, ticks)
2289 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2290 setBreakFlag toggle array index
2291 | toggle = GHC.setBreakOn array index
2292 | otherwise = GHC.setBreakOff array index