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 ( implicitTyThings, 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 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
402 runCommands $ fileLoop hdl
404 getDirectory f = case takeDirectory f of "" -> "."; d -> d
406 when (read_dot_files) $ do
407 cfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
408 cfgs <- io $ mapM canonicalizePath (catMaybes cfgs0)
409 mapM_ sourceConfigFile (nub cfgs)
410 -- nub, because we don't want to read .ghci twice if the
413 -- Perform a :load for files given on the GHCi command line
414 -- When in -e mode, if the load fails then we want to stop
415 -- immediately rather than going on to evaluate the expression.
416 when (not (null paths)) $ do
417 ok <- ghciHandle (\e -> do showException e; return Failed) $
418 -- TODO: this is a hack.
419 runInputTWithPrefs defaultPrefs defaultSettings $ do
420 let (filePaths, phases) = unzip paths
421 filePaths' <- mapM (Encoding.decode . BS.pack) filePaths
422 loadModule (zip filePaths' phases)
423 when (isJust maybe_exprs && failed ok) $
424 io (exitWith (ExitFailure 1))
426 -- if verbosity is greater than 0, or we are connected to a
427 -- terminal, display the prompt in the interactive loop.
428 is_tty <- io (hIsTerminalDevice stdin)
429 dflags <- getDynFlags
430 let show_prompt = verbosity dflags > 0 || is_tty
435 -- enter the interactive loop
436 runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
438 -- just evaluate the expression we were given
439 enqueueCommands exprs
440 let handle e = do st <- getGHCiState
441 -- Jump through some hoops to get the
442 -- current progname in the exception text:
443 -- <progname>: <exception>
444 io $ withProgName (progname st)
445 -- this used to be topHandlerFastExit, see #2228
447 runInputTWithPrefs defaultPrefs defaultSettings $ do
448 runCommands' handle (return Nothing)
451 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
453 runGHCiInput :: InputT GHCi a -> GHCi a
455 histFile <- io $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
457 let settings = setComplete ghciCompleteWord
458 $ defaultSettings {historyFile = histFile}
461 nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
462 nextInputLine show_prompt is_tty
464 prompt <- if show_prompt then lift mkPrompt else return ""
467 when show_prompt $ lift mkPrompt >>= liftIO . putStr
470 -- NOTE: We only read .ghci files if they are owned by the current user,
471 -- and aren't world writable. Otherwise, we could be accidentally
472 -- running code planted by a malicious third party.
474 -- Furthermore, We only read ./.ghci if . is owned by the current user
475 -- and isn't writable by anyone else. I think this is sufficient: we
476 -- don't need to check .. and ../.. etc. because "." always refers to
477 -- the same directory while a process is running.
479 checkPerms :: String -> IO Bool
480 #ifdef mingw32_HOST_OS
485 handleIO (\_ -> return False) $ do
486 st <- getFileStatus name
488 if fileOwner st /= me then do
489 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
492 let mode = fileMode st
493 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
494 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
496 putStrLn $ "*** WARNING: " ++ name ++
497 " is writable by someone else, IGNORING!"
502 fileLoop :: MonadIO m => Handle -> InputT m (Maybe String)
504 l <- liftIO $ IO.try $ hGetLine hdl
506 Left e | isEOFError e -> return Nothing
507 | InvalidArgument <- etype -> return Nothing
508 | otherwise -> liftIO $ ioError e
509 where etype = ioeGetErrorType e
510 -- treat InvalidArgument in the same way as EOF:
511 -- this can happen if the user closed stdin, or
512 -- perhaps did getContents which closes stdin at
514 Right l -> return (Just l)
516 mkPrompt :: GHCi String
518 (toplevs,exports) <- GHC.getContext
519 resumes <- GHC.getResumeContext
520 -- st <- getGHCiState
526 let ix = GHC.resumeHistoryIx r
528 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
530 let hist = GHC.resumeHistory r !! (ix-1)
531 span <- GHC.getHistorySpan hist
532 return (brackets (ppr (negate ix) <> char ':'
533 <+> ppr span) <> space)
535 dots | _:rs <- resumes, not (null rs) = text "... "
542 -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
543 -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
544 -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
545 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
546 hsep (map (ppr . GHC.moduleName) exports)
548 deflt_prompt = dots <> context_bit <> modules_bit
550 f ('%':'s':xs) = deflt_prompt <> f xs
551 f ('%':'%':xs) = char '%' <> f xs
552 f (x:xs) = char x <> f xs
556 return (showSDoc (f (prompt st)))
559 queryQueue :: GHCi (Maybe String)
564 c:cs -> do setGHCiState st{ cmdqueue = cs }
567 runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
568 runCommands = runCommands' handler
570 runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
571 -> InputT GHCi (Maybe String) -> InputT GHCi ()
572 runCommands' eh getCmd = do
573 b <- handleGhcException (\e -> case e of
574 Interrupted -> return False
575 _other -> liftIO (print e) >> return True)
576 (runOneCommand eh getCmd)
577 if b then return () else runCommands' eh getCmd
579 runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
581 runOneCommand eh getCmd = do
582 mb_cmd <- noSpace (lift queryQueue)
583 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
585 Nothing -> return True
586 Just c -> ghciHandle (lift . eh) $
587 handleSourceError printErrorAndKeepGoing
590 printErrorAndKeepGoing err = do
591 GHC.printExceptionAndWarnings err
594 noSpace q = q >>= maybe (return Nothing)
595 (\c->case removeSpaces c of
597 ":{" -> multiLineCmd q
598 c -> return (Just c) )
600 st <- lift getGHCiState
602 lift $ setGHCiState st{ prompt = "%s| " }
603 mb_cmd <- collectCommand q ""
604 lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p }
606 -- we can't use removeSpaces for the sublines here, so
607 -- multiline commands are somewhat more brittle against
608 -- fileformat errors (such as \r in dos input on unix),
609 -- we get rid of any extra spaces for the ":}" test;
610 -- we also avoid silent failure if ":}" is not found;
611 -- and since there is no (?) valid occurrence of \r (as
612 -- opposed to its String representation, "\r") inside a
613 -- ghci command, we replace any such with ' ' (argh:-(
614 collectCommand q c = q >>=
615 maybe (liftIO (ioError collectError))
616 (\l->if removeSpaces l == ":}"
617 then return (Just $ removeSpaces c)
618 else collectCommand q (c++map normSpace l))
619 where normSpace '\r' = ' '
621 -- QUESTION: is userError the one to use here?
622 collectError = userError "unterminated multiline command :{ .. :}"
623 doCommand (':' : cmd) = specialCommand cmd
624 doCommand stmt = do _ <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion
627 enqueueCommands :: [String] -> GHCi ()
628 enqueueCommands cmds = do
630 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
633 runStmt :: String -> SingleStep -> GHCi Bool
635 | null (filter (not.isSpace) stmt) = return False
636 | ["import", mod] <- words stmt = keepGoing' setContext ('+':mod)
639 #if __GLASGOW_HASKELL__ >= 611
640 -- In the new IO library, read handles buffer data even if the Handle
641 -- is set to NoBuffering. This causes problems for GHCi where there
642 -- are really two stdin Handles. So we flush any bufferred data in
643 -- GHCi's stdin Handle here (only relevant if stdin is attached to
644 -- a file, otherwise the read buffer can't be flushed).
645 _ <- liftIO $ IO.try $ hFlushAll stdin
647 result <- GhciMonad.runStmt stmt step
648 afterRunStmt (const True) result
650 --afterRunStmt :: GHC.RunResult -> GHCi Bool
651 -- False <=> the statement failed to compile
652 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
653 afterRunStmt _ (GHC.RunException e) = throw e
654 afterRunStmt step_here run_result = do
655 resumes <- GHC.getResumeContext
657 GHC.RunOk names -> do
658 show_types <- isOptionSet ShowType
659 when show_types $ printTypeOfNames names
660 GHC.RunBreak _ names mb_info
661 | isNothing mb_info ||
662 step_here (GHC.resumeSpan $ head resumes) -> do
663 mb_id_loc <- toBreakIdAndLocation mb_info
664 let breakCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
666 then printStoppedAtBreakInfo (head resumes) names
667 else enqueueCommands [breakCmd]
668 -- run the command set with ":set stop <cmd>"
670 enqueueCommands [stop st]
672 | otherwise -> resume step_here GHC.SingleStep >>=
673 afterRunStmt step_here >> return ()
677 io installSignalHandlers
678 b <- isOptionSet RevertCAFs
681 return (case run_result of GHC.RunOk _ -> True; _ -> False)
683 toBreakIdAndLocation ::
684 Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
685 toBreakIdAndLocation Nothing = return Nothing
686 toBreakIdAndLocation (Just info) = do
687 let mod = GHC.breakInfo_module info
688 nm = GHC.breakInfo_number info
690 return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
691 breakModule loc == mod,
692 breakTick loc == nm ]
694 printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
695 printStoppedAtBreakInfo resume names = do
696 printForUser $ ptext (sLit "Stopped at") <+>
697 ppr (GHC.resumeSpan resume)
698 -- printTypeOfNames session names
699 let namesSorted = sortBy compareNames names
700 tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
701 docs <- pprTypeAndContents [id | AnId id <- tythings]
702 printForUserPartWay docs
704 printTypeOfNames :: [Name] -> GHCi ()
705 printTypeOfNames names
706 = mapM_ (printTypeOfName ) $ sortBy compareNames names
708 compareNames :: Name -> Name -> Ordering
709 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
710 where compareWith n = (getOccString n, getSrcSpan n)
712 printTypeOfName :: Name -> GHCi ()
714 = do maybe_tything <- GHC.lookupName n
715 case maybe_tything of
717 Just thing -> printTyThing thing
720 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
722 specialCommand :: String -> InputT GHCi Bool
723 specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
724 specialCommand str = do
725 let (cmd,rest) = break isSpace str
726 maybe_cmd <- lift $ lookupCommand cmd
728 GotCommand (_,f,_) -> f (dropWhile isSpace rest)
730 do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
734 do liftIO $ hPutStr stdout ("there is no last command to perform\n"
738 lookupCommand :: String -> GHCi (MaybeCommand)
739 lookupCommand "" = do
741 case last_command st of
742 Just c -> return $ GotCommand c
743 Nothing -> return NoLastCommand
744 lookupCommand str = do
745 mc <- io $ lookupCommand' str
747 setGHCiState st{ last_command = mc }
749 Just c -> GotCommand c
750 Nothing -> BadCommand
752 lookupCommand' :: String -> IO (Maybe Command)
753 lookupCommand' ":" = return Nothing
754 lookupCommand' str' = do
755 macros <- readIORef macros_ref
756 let{ (str, cmds) = case str' of
757 ':' : rest -> (rest, builtin_commands)
758 _ -> (str', macros ++ builtin_commands) }
759 -- look for exact match first, then the first prefix match
760 return $ case [ c | c <- cmds, str == cmdName c ] of
762 [] -> case [ c | c@(s,_,_) <- cmds, str `isPrefixOf` s ] of
766 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
767 getCurrentBreakSpan = do
768 resumes <- GHC.getResumeContext
772 let ix = GHC.resumeHistoryIx r
774 then return (Just (GHC.resumeSpan r))
776 let hist = GHC.resumeHistory r !! (ix-1)
777 span <- GHC.getHistorySpan hist
780 getCurrentBreakModule :: GHCi (Maybe Module)
781 getCurrentBreakModule = do
782 resumes <- GHC.getResumeContext
786 let ix = GHC.resumeHistoryIx r
788 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
790 let hist = GHC.resumeHistory r !! (ix-1)
791 return $ Just $ GHC.getHistoryModule hist
793 -----------------------------------------------------------------------------
796 noArgs :: GHCi () -> String -> GHCi ()
798 noArgs _ _ = io $ putStrLn "This command takes no arguments"
800 help :: String -> GHCi ()
801 help _ = io (putStr helpText)
803 info :: String -> InputT GHCi ()
804 info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
805 info s = handleSourceError GHC.printExceptionAndWarnings $ do
806 { let names = words s
807 ; dflags <- getDynFlags
808 ; let pefas = dopt Opt_PrintExplicitForalls dflags
809 ; mapM_ (infoThing pefas) names }
811 infoThing pefas str = do
812 names <- GHC.parseName str
813 mb_stuffs <- mapM GHC.getInfo names
814 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
815 unqual <- GHC.getPrintUnqual
816 outputStrLn $ showSDocForUser unqual $
817 vcat (intersperse (text "") $
818 map (pprInfo pefas) filtered)
820 -- Filter out names whose parent is also there Good
821 -- example is '[]', which is both a type and data
822 -- constructor in the same type
823 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
824 filterOutChildren get_thing xs
825 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
827 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
829 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
830 pprInfo pefas (thing, fixity, insts)
831 = pprTyThingInContextLoc pefas thing
832 $$ show_fixity fixity
833 $$ vcat (map GHC.pprInstance insts)
836 | fix == GHC.defaultFixity = empty
837 | otherwise = ppr fix <+> ppr (GHC.getName thing)
839 runMain :: String -> GHCi ()
840 runMain s = case toArgs s of
841 Left err -> io (hPutStrLn stderr err)
843 do dflags <- getDynFlags
844 case mainFunIs dflags of
845 Nothing -> doWithArgs args "main"
846 Just f -> doWithArgs args f
848 runRun :: String -> GHCi ()
849 runRun s = case toCmdArgs s of
850 Left err -> io (hPutStrLn stderr err)
851 Right (cmd, args) -> doWithArgs args cmd
853 doWithArgs :: [String] -> String -> GHCi ()
854 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
855 show args ++ " (" ++ cmd ++ ")"]
857 addModule :: [FilePath] -> InputT GHCi ()
859 lift revertCAFs -- always revert CAFs on load/add.
860 files <- mapM expandPath files
861 targets <- mapM (\m -> GHC.guessTarget m Nothing) files
862 -- remove old targets with the same id; e.g. for :add *M
863 mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
864 mapM_ GHC.addTarget targets
865 prev_context <- GHC.getContext
866 ok <- trySuccess $ GHC.load LoadAllTargets
867 afterLoad ok False prev_context
869 changeDirectory :: String -> InputT GHCi ()
870 changeDirectory "" = do
871 -- :cd on its own changes to the user's home directory
872 either_dir <- liftIO $ IO.try getHomeDirectory
875 Right dir -> changeDirectory dir
876 changeDirectory dir = do
877 graph <- GHC.getModuleGraph
878 when (not (null graph)) $
879 outputStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
880 prev_context <- GHC.getContext
882 _ <- GHC.load LoadAllTargets
883 lift $ setContextAfterLoad prev_context False []
884 GHC.workingDirectoryChanged
885 dir <- expandPath dir
886 liftIO $ setCurrentDirectory dir
888 trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
890 handleSourceError (\e -> do GHC.printExceptionAndWarnings e
894 editFile :: String -> GHCi ()
896 do file <- if null str then chooseEditFile else return str
900 $ ghcError (CmdLineError "editor not set, use :set editor")
901 _ <- io $ system (cmd ++ ' ':file)
904 -- The user didn't specify a file so we pick one for them.
905 -- Our strategy is to pick the first module that failed to load,
906 -- or otherwise the first target.
908 -- XXX: Can we figure out what happened if the depndecy analysis fails
909 -- (e.g., because the porgrammeer mistyped the name of a module)?
910 -- XXX: Can we figure out the location of an error to pass to the editor?
911 -- XXX: if we could figure out the list of errors that occured during the
912 -- last load/reaload, then we could start the editor focused on the first
914 chooseEditFile :: GHCi String
916 do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
918 graph <- GHC.getModuleGraph
919 failed_graph <- filterM hasFailed graph
920 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
922 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
925 case pick (order failed_graph) of
926 Just file -> return file
928 do targets <- GHC.getTargets
929 case msum (map fromTarget targets) of
930 Just file -> return file
931 Nothing -> ghcError (CmdLineError "No files to edit.")
933 where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
934 fromTarget _ = Nothing -- when would we get a module target?
936 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
937 defineMacro _ (':':_) =
938 io $ putStrLn "macro name cannot start with a colon"
939 defineMacro overwrite s = do
940 let (macro_name, definition) = break isSpace s
941 macros <- io (readIORef macros_ref)
942 let defined = map cmdName macros
945 then io $ putStrLn "no macros defined"
946 else io $ putStr ("the following macros are defined:\n" ++
949 if (not overwrite && macro_name `elem` defined)
950 then ghcError (CmdLineError
951 ("macro '" ++ macro_name ++ "' is already defined"))
954 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
956 -- give the expression a type signature, so we can be sure we're getting
957 -- something of the right type.
958 let new_expr = '(' : definition ++ ") :: String -> IO String"
960 -- compile the expression
961 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
962 hv <- GHC.compileExpr new_expr
963 io (writeIORef macros_ref --
964 (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)]))
966 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
968 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
969 -- make sure we force any exceptions in the result, while we are still
970 -- inside the exception handler for commands:
971 seqList str (return ())
972 enqueueCommands (lines str)
975 undefineMacro :: String -> GHCi ()
976 undefineMacro str = mapM_ undef (words str)
977 where undef macro_name = do
978 cmds <- io (readIORef macros_ref)
979 if (macro_name `notElem` map cmdName cmds)
980 then ghcError (CmdLineError
981 ("macro '" ++ macro_name ++ "' is not defined"))
983 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
985 cmdCmd :: String -> GHCi ()
987 let expr = '(' : str ++ ") :: IO String"
988 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
989 hv <- GHC.compileExpr expr
990 cmds <- io $ (unsafeCoerce# hv :: IO String)
991 enqueueCommands (lines cmds)
994 loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
995 loadModule fs = timeIt (loadModule' fs)
997 loadModule_ :: [FilePath] -> InputT GHCi ()
998 loadModule_ fs = loadModule (zip fs (repeat Nothing)) >> return ()
1000 loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
1001 loadModule' files = do
1002 prev_context <- GHC.getContext
1006 lift discardActiveBreakPoints
1008 _ <- GHC.load LoadAllTargets
1010 let (filenames, phases) = unzip files
1011 exp_filenames <- mapM expandPath filenames
1012 let files' = zip exp_filenames phases
1013 targets <- mapM (uncurry GHC.guessTarget) files'
1015 -- NOTE: we used to do the dependency anal first, so that if it
1016 -- fails we didn't throw away the current set of modules. This would
1017 -- require some re-working of the GHC interface, so we'll leave it
1018 -- as a ToDo for now.
1020 GHC.setTargets targets
1021 doLoad False prev_context LoadAllTargets
1023 checkModule :: String -> InputT GHCi ()
1025 let modl = GHC.mkModuleName m
1026 prev_context <- GHC.getContext
1027 ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do
1028 r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
1029 outputStrLn (showSDoc (
1030 case GHC.moduleInfo r of
1031 cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1033 (local,global) = ASSERT( all isExternalName scope )
1034 partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1036 (text "global names: " <+> ppr global) $$
1037 (text "local names: " <+> ppr local)
1040 afterLoad (successIf ok) False prev_context
1042 reloadModule :: String -> InputT GHCi ()
1044 prev_context <- GHC.getContext
1045 _ <- doLoad True prev_context $
1046 if null m then LoadAllTargets
1047 else LoadUpTo (GHC.mkModuleName m)
1050 doLoad :: Bool -> ([Module],[Module]) -> LoadHowMuch -> InputT GHCi SuccessFlag
1051 doLoad retain_context prev_context howmuch = do
1052 -- turn off breakpoints before we load: we can't turn them off later, because
1053 -- the ModBreaks will have gone away.
1054 lift discardActiveBreakPoints
1055 ok <- trySuccess $ GHC.load howmuch
1056 afterLoad ok retain_context prev_context
1059 afterLoad :: SuccessFlag -> Bool -> ([Module],[Module]) -> InputT GHCi ()
1060 afterLoad ok retain_context prev_context = do
1061 lift revertCAFs -- always revert CAFs on load.
1062 lift discardTickArrays
1063 loaded_mod_summaries <- getLoadedModules
1064 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1065 loaded_mod_names = map GHC.moduleName loaded_mods
1066 modulesLoadedMsg ok loaded_mod_names
1068 lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
1071 setContextAfterLoad :: ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi ()
1072 setContextAfterLoad prev keep_ctxt [] = do
1073 prel_mod <- getPrelude
1074 setContextKeepingPackageModules prev keep_ctxt ([], [prel_mod])
1075 setContextAfterLoad prev keep_ctxt ms = do
1076 -- load a target if one is available, otherwise load the topmost module.
1077 targets <- GHC.getTargets
1078 case [ m | Just m <- map (findTarget ms) targets ] of
1080 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1081 load_this (last graph')
1086 = case filter (`matches` t) ms of
1090 summary `matches` Target (TargetModule m) _ _
1091 = GHC.ms_mod_name summary == m
1092 summary `matches` Target (TargetFile f _) _ _
1093 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1097 load_this summary | m <- GHC.ms_mod summary = do
1098 b <- GHC.moduleIsInterpreted m
1099 if b then setContextKeepingPackageModules prev keep_ctxt ([m], [])
1101 prel_mod <- getPrelude
1102 setContextKeepingPackageModules prev keep_ctxt ([],[prel_mod,m])
1104 -- | Keep any package modules (except Prelude) when changing the context.
1105 setContextKeepingPackageModules
1106 :: ([Module],[Module]) -- previous context
1107 -> Bool -- re-execute :module commands
1108 -> ([Module],[Module]) -- new context
1110 setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do
1111 let (_,bs0) = prev_context
1112 prel_mod <- getPrelude
1113 let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1114 let bs1 = if null as then nub (prel_mod : bs) else bs
1115 GHC.setContext as (nub (bs1 ++ pkg_modules))
1119 mapM_ (playCtxtCmd False) (remembered_ctx st)
1122 setGHCiState st{ remembered_ctx = [] }
1124 isHomeModule :: Module -> Bool
1125 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1127 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi ()
1128 modulesLoadedMsg ok mods = do
1129 dflags <- getDynFlags
1130 when (verbosity dflags > 0) $ do
1132 | null mods = text "none."
1133 | otherwise = hsep (
1134 punctuate comma (map ppr mods)) <> text "."
1137 outputStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))
1139 outputStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas))
1142 typeOfExpr :: String -> InputT GHCi ()
1144 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1145 ty <- GHC.exprType str
1146 dflags <- getDynFlags
1147 let pefas = dopt Opt_PrintExplicitForalls dflags
1148 printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]
1150 kindOfType :: String -> InputT GHCi ()
1152 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1153 ty <- GHC.typeKind str
1154 printForUser $ text str <+> dcolon <+> ppr ty
1156 quit :: String -> InputT GHCi Bool
1157 quit _ = return True
1159 shellEscape :: String -> GHCi Bool
1160 shellEscape str = io (system str >> return False)
1162 -----------------------------------------------------------------------------
1163 -- Browsing a module's contents
1165 browseCmd :: Bool -> String -> InputT GHCi ()
1168 ['*':s] | looksLikeModuleName s -> do
1169 m <- lift $ wantInterpretedModule s
1170 browseModule bang m False
1171 [s] | looksLikeModuleName s -> do
1172 m <- lift $ lookupModule s
1173 browseModule bang m True
1175 (as,bs) <- GHC.getContext
1176 -- Guess which module the user wants to browse. Pick
1177 -- modules that are interpreted first. The most
1178 -- recently-added module occurs last, it seems.
1180 (as@(_:_), _) -> browseModule bang (last as) True
1181 ([], bs@(_:_)) -> browseModule bang (last bs) True
1182 ([], []) -> ghcError (CmdLineError ":browse: no current module")
1183 _ -> ghcError (CmdLineError "syntax: :browse <module>")
1185 -- without bang, show items in context of their parents and omit children
1186 -- with bang, show class methods and data constructors separately, and
1187 -- indicate import modules, to aid qualifying unqualified names
1188 -- with sorted, sort items alphabetically
1189 browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
1190 browseModule bang modl exports_only = do
1191 -- :browse! reports qualifiers wrt current context
1192 current_unqual <- GHC.getPrintUnqual
1193 -- Temporarily set the context to the module we're interested in,
1194 -- just so we can get an appropriate PrintUnqualified
1195 (as,bs) <- GHC.getContext
1196 prel_mod <- lift getPrelude
1197 if exports_only then GHC.setContext [] [prel_mod,modl]
1198 else GHC.setContext [modl] []
1199 target_unqual <- GHC.getPrintUnqual
1200 GHC.setContext as bs
1202 let unqual = if bang then current_unqual else target_unqual
1204 mb_mod_info <- GHC.getModuleInfo modl
1206 Nothing -> ghcError (CmdLineError ("unknown module: " ++
1207 GHC.moduleNameString (GHC.moduleName modl)))
1209 dflags <- getDynFlags
1211 | exports_only = GHC.modInfoExports mod_info
1212 | otherwise = GHC.modInfoTopLevelScope mod_info
1215 -- sort alphabetically name, but putting
1216 -- locally-defined identifiers first.
1217 -- We would like to improve this; see #1799.
1218 sorted_names = loc_sort local ++ occ_sort external
1220 (local,external) = ASSERT( all isExternalName names )
1221 partition ((==modl) . nameModule) names
1222 occ_sort = sortBy (compare `on` nameOccName)
1223 -- try to sort by src location. If the first name in
1224 -- our list has a good source location, then they all should.
1226 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1227 = sortBy (compare `on` nameSrcSpan) names
1231 mb_things <- mapM GHC.lookupName sorted_names
1232 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1234 rdr_env <- GHC.getGRE
1236 let pefas = dopt Opt_PrintExplicitForalls dflags
1237 things | bang = catMaybes mb_things
1238 | otherwise = filtered_things
1239 pretty | bang = pprTyThing
1240 | otherwise = pprTyThingInContext
1242 labels [] = text "-- not currently imported"
1243 labels l = text $ intercalate "\n" $ map qualifier l
1244 qualifier = maybe "-- defined locally"
1245 (("-- imported via "++) . intercalate ", "
1246 . map GHC.moduleNameString)
1247 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1248 modNames = map (importInfo . GHC.getName) things
1250 -- annotate groups of imports with their import modules
1251 -- the default ordering is somewhat arbitrary, so we group
1252 -- by header and sort groups; the names themselves should
1253 -- really come in order of source appearance.. (trac #1799)
1254 annotate mts = concatMap (\(m,ts)->labels m:ts)
1255 $ sortBy cmpQualifiers $ group mts
1256 where cmpQualifiers =
1257 compare `on` (map (fmap (map moduleNameFS)) . fst)
1259 group mts@((m,_):_) = (m,map snd g) : group ng
1260 where (g,ng) = partition ((==m).fst) mts
1262 let prettyThings = map (pretty pefas) things
1263 prettyThings' | bang = annotate $ zip modNames prettyThings
1264 | otherwise = prettyThings
1265 outputStrLn $ showSDocForUser unqual (vcat prettyThings')
1266 -- ToDo: modInfoInstances currently throws an exception for
1267 -- package modules. When it works, we can do this:
1268 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1270 -----------------------------------------------------------------------------
1271 -- Setting the module context
1273 setContext :: String -> GHCi ()
1275 | all sensible strs = do
1276 playCtxtCmd True (cmd, as, bs)
1278 setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] }
1279 | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1281 (cmd, strs, as, bs) =
1283 '+':stuff -> rest AddModules stuff
1284 '-':stuff -> rest RemModules stuff
1285 stuff -> rest SetContext stuff
1287 rest cmd stuff = (cmd, strs, as, bs)
1288 where strs = words stuff
1289 (as,bs) = partitionWith starred strs
1291 sensible ('*':m) = looksLikeModuleName m
1292 sensible m = looksLikeModuleName m
1294 starred ('*':m) = Left m
1297 playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi ()
1298 playCtxtCmd fail (cmd, as, bs)
1300 (as',bs') <- do_checks fail
1301 (prev_as,prev_bs) <- GHC.getContext
1305 prel_mod <- getPrelude
1306 let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs'
1310 let as_to_add = as' \\ (prev_as ++ prev_bs)
1311 bs_to_add = bs' \\ (prev_as ++ prev_bs)
1312 return (prev_as ++ as_to_add, prev_bs ++ bs_to_add)
1314 let new_as = prev_as \\ (as' ++ bs')
1315 new_bs = prev_bs \\ (as' ++ bs')
1316 return (new_as, new_bs)
1317 GHC.setContext new_as new_bs
1320 as' <- mapM wantInterpretedModule as
1321 bs' <- mapM lookupModule bs
1323 do_checks False = do
1324 as' <- mapM (trymaybe . wantInterpretedModule) as
1325 bs' <- mapM (trymaybe . lookupModule) bs
1326 return (catMaybes as', catMaybes bs')
1331 Left _ -> return Nothing
1332 Right a -> return (Just a)
1334 ----------------------------------------------------------------------------
1337 -- set options in the interpreter. Syntax is exactly the same as the
1338 -- ghc command line, except that certain options aren't available (-C,
1341 -- This is pretty fragile: most options won't work as expected. ToDo:
1342 -- figure out which ones & disallow them.
1344 setCmd :: String -> GHCi ()
1346 = do st <- getGHCiState
1347 let opts = options st
1348 io $ putStrLn (showSDoc (
1349 text "options currently set: " <>
1352 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1354 dflags <- getDynFlags
1355 io $ putStrLn (showSDoc (
1356 vcat (text "GHCi-specific dynamic flag settings:"
1357 :map (flagSetting dflags) ghciFlags)
1359 io $ putStrLn (showSDoc (
1360 vcat (text "other dynamic, non-language, flag settings:"
1361 :map (flagSetting dflags) nonLanguageDynFlags)
1363 where flagSetting dflags (str, f, _)
1364 | dopt f dflags = text " " <> text "-f" <> text str
1365 | otherwise = text " " <> text "-fno-" <> text str
1366 (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags)
1368 nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions)
1370 flags = [Opt_PrintExplicitForalls
1371 ,Opt_PrintBindResult
1372 ,Opt_BreakOnException
1374 ,Opt_PrintEvldWithShow
1377 = case getCmd str of
1378 Right ("args", rest) ->
1380 Left err -> io (hPutStrLn stderr err)
1381 Right args -> setArgs args
1382 Right ("prog", rest) ->
1384 Right [prog] -> setProg prog
1385 _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")
1386 Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1387 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1388 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1389 _ -> case toArgs str of
1390 Left err -> io (hPutStrLn stderr err)
1391 Right wds -> setOptions wds
1393 setArgs, setOptions :: [String] -> GHCi ()
1394 setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
1398 setGHCiState st{ args = args }
1402 setGHCiState st{ progname = prog }
1406 setGHCiState st{ editor = cmd }
1408 setStop str@(c:_) | isDigit c
1409 = do let (nm_str,rest) = break (not.isDigit) str
1412 let old_breaks = breaks st
1413 if all ((/= nm) . fst) old_breaks
1414 then printForUser (text "Breakpoint" <+> ppr nm <+>
1415 text "does not exist")
1417 let new_breaks = map fn old_breaks
1418 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1419 | otherwise = (i,loc)
1420 setGHCiState st{ breaks = new_breaks }
1423 setGHCiState st{ stop = cmd }
1425 setPrompt value = do
1428 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1430 '\"' : _ -> case reads value of
1431 [(value', xs)] | all isSpace xs ->
1432 setGHCiState (st { prompt = value' })
1434 io $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
1435 _ -> setGHCiState (st { prompt = value })
1438 do -- first, deal with the GHCi opts (+s, +t, etc.)
1439 let (plus_opts, minus_opts) = partitionWith isPlus wds
1440 mapM_ setOpt plus_opts
1441 -- then, dynamic flags
1442 newDynFlags minus_opts
1444 newDynFlags :: [String] -> GHCi ()
1445 newDynFlags minus_opts = do
1446 dflags <- getDynFlags
1447 let pkg_flags = packageFlags dflags
1448 (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
1449 handleFlagWarnings dflags' warns
1451 if (not (null leftovers))
1452 then ghcError $ errorsToGhcException leftovers
1455 new_pkgs <- setDynFlags dflags'
1457 -- if the package flags changed, we should reset the context
1458 -- and link the new packages.
1459 dflags <- getDynFlags
1460 when (packageFlags dflags /= pkg_flags) $ do
1461 io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
1463 _ <- GHC.load LoadAllTargets
1464 io (linkPackages dflags new_pkgs)
1465 -- package flags changed, we can't re-use any of the old context
1466 setContextAfterLoad ([],[]) False []
1470 unsetOptions :: String -> GHCi ()
1472 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1473 let opts = words str
1474 (minus_opts, rest1) = partition isMinus opts
1475 (plus_opts, rest2) = partitionWith isPlus rest1
1477 if (not (null rest2))
1478 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1481 mapM_ unsetOpt plus_opts
1483 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1484 no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
1486 no_flags <- mapM no_flag minus_opts
1487 newDynFlags no_flags
1489 isMinus :: String -> Bool
1490 isMinus ('-':_) = True
1493 isPlus :: String -> Either String String
1494 isPlus ('+':opt) = Left opt
1495 isPlus other = Right other
1497 setOpt, unsetOpt :: String -> GHCi ()
1500 = case strToGHCiOpt str of
1501 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1502 Just o -> setOption o
1505 = case strToGHCiOpt str of
1506 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1507 Just o -> unsetOption o
1509 strToGHCiOpt :: String -> (Maybe GHCiOption)
1510 strToGHCiOpt "s" = Just ShowTiming
1511 strToGHCiOpt "t" = Just ShowType
1512 strToGHCiOpt "r" = Just RevertCAFs
1513 strToGHCiOpt _ = Nothing
1515 optToStr :: GHCiOption -> String
1516 optToStr ShowTiming = "s"
1517 optToStr ShowType = "t"
1518 optToStr RevertCAFs = "r"
1520 -- ---------------------------------------------------------------------------
1523 showCmd :: String -> GHCi ()
1527 ["args"] -> io $ putStrLn (show (args st))
1528 ["prog"] -> io $ putStrLn (show (progname st))
1529 ["prompt"] -> io $ putStrLn (show (prompt st))
1530 ["editor"] -> io $ putStrLn (show (editor st))
1531 ["stop"] -> io $ putStrLn (show (stop st))
1532 ["modules" ] -> showModules
1533 ["bindings"] -> showBindings
1534 ["linker"] -> io showLinkerState
1535 ["breaks"] -> showBkptTable
1536 ["context"] -> showContext
1537 ["packages"] -> showPackages
1538 ["languages"] -> showLanguages
1539 _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
1540 " | breaks | context | packages | languages ]"))
1542 showModules :: GHCi ()
1544 loaded_mods <- getLoadedModules
1545 -- we want *loaded* modules only, see #1734
1546 let show_one ms = do m <- GHC.showModule ms; io (putStrLn m)
1547 mapM_ show_one loaded_mods
1549 getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
1550 getLoadedModules = do
1551 graph <- GHC.getModuleGraph
1552 filterM (GHC.isLoaded . GHC.ms_mod_name) graph
1554 showBindings :: GHCi ()
1556 bindings <- GHC.getBindings
1557 docs <- pprTypeAndContents
1558 [ id | AnId id <- sortBy compareTyThings bindings]
1559 printForUserPartWay docs
1561 compareTyThings :: TyThing -> TyThing -> Ordering
1562 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1564 printTyThing :: TyThing -> GHCi ()
1565 printTyThing tyth = do dflags <- getDynFlags
1566 let pefas = dopt Opt_PrintExplicitForalls dflags
1567 printForUser (pprTyThing pefas tyth)
1569 showBkptTable :: GHCi ()
1572 printForUser $ prettyLocations (breaks st)
1574 showContext :: GHCi ()
1576 resumes <- GHC.getResumeContext
1577 printForUser $ vcat (map pp_resume (reverse resumes))
1580 ptext (sLit "--> ") <> text (GHC.resumeStmt resume)
1581 $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume))
1583 showPackages :: GHCi ()
1585 pkg_flags <- fmap packageFlags getDynFlags
1586 io $ putStrLn $ showSDoc $ vcat $
1587 text ("active package flags:"++if null pkg_flags then " none" else "")
1588 : map showFlag pkg_flags
1589 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1590 io $ putStrLn $ showSDoc $ vcat $
1591 text "packages currently loaded:"
1592 : map (nest 2 . text . packageIdString)
1593 (sortBy (compare `on` packageIdFS) pkg_ids)
1594 where showFlag (ExposePackage p) = text $ " -package " ++ p
1595 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1596 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1597 showFlag (ExposePackageId p) = text $ " -package-id " ++ p
1599 showLanguages :: GHCi ()
1601 dflags <- getDynFlags
1602 io $ putStrLn $ showSDoc $ vcat $
1603 text "active language flags:" :
1604 [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags]
1606 -- -----------------------------------------------------------------------------
1609 completeCmd, completeMacro, completeIdentifier, completeModule,
1610 completeHomeModule, completeSetOptions, completeShowOptions,
1611 completeHomeModuleOrFile, completeExpression
1612 :: CompletionFunc GHCi
1614 ghciCompleteWord :: CompletionFunc GHCi
1615 ghciCompleteWord line@(left,_) = case firstWord of
1616 ':':cmd | null rest -> completeCmd line
1618 completion <- lookupCompletion cmd
1620 "import" -> completeModule line
1621 _ -> completeExpression line
1623 (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
1624 lookupCompletion ('!':_) = return completeFilename
1625 lookupCompletion c = do
1626 maybe_cmd <- liftIO $ lookupCommand' c
1628 Just (_,_,f) -> return f
1629 Nothing -> return completeFilename
1631 completeCmd = wrapCompleter " " $ \w -> do
1632 macros <- liftIO $ readIORef macros_ref
1633 let macro_names = map (':':) . map cmdName $ macros
1634 let command_names = map (':':) . map cmdName $ builtin_commands
1635 let{ candidates = case w of
1636 ':' : ':' : _ -> map (':':) command_names
1637 _ -> nub $ macro_names ++ command_names }
1638 return $ filter (w `isPrefixOf`) candidates
1640 completeMacro = wrapIdentCompleter $ \w -> do
1641 cmds <- liftIO $ readIORef macros_ref
1642 return (filter (w `isPrefixOf`) (map cmdName cmds))
1644 completeIdentifier = wrapIdentCompleter $ \w -> do
1645 rdrs <- GHC.getRdrNamesInScope
1646 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1648 completeModule = wrapIdentCompleter $ \w -> do
1649 dflags <- GHC.getSessionDynFlags
1650 let pkg_mods = allExposedModules dflags
1651 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
1652 return $ filter (w `isPrefixOf`)
1653 $ map (showSDoc.ppr) $ loaded_mods ++ pkg_mods
1655 completeHomeModule = wrapIdentCompleter listHomeModules
1657 listHomeModules :: String -> GHCi [String]
1658 listHomeModules w = do
1659 g <- GHC.getModuleGraph
1660 let home_mods = map GHC.ms_mod_name g
1661 return $ sort $ filter (w `isPrefixOf`)
1662 $ map (showSDoc.ppr) home_mods
1664 completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
1665 return (filter (w `isPrefixOf`) options)
1666 where options = "args":"prog":"prompt":"editor":"stop":flagList
1667 flagList = map head $ group $ sort allFlags
1669 completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
1670 return (filter (w `isPrefixOf`) options)
1671 where options = ["args", "prog", "prompt", "editor", "stop",
1672 "modules", "bindings", "linker", "breaks",
1673 "context", "packages", "languages"]
1675 completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
1676 $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
1679 unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
1680 unionComplete f1 f2 line = do
1685 wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
1686 wrapCompleter breakChars fun = completeWord Nothing breakChars
1687 $ fmap (map simpleCompletion) . fmap sort . fun
1689 wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
1690 wrapIdentCompleter = wrapCompleter word_break_chars
1692 allExposedModules :: DynFlags -> [ModuleName]
1693 allExposedModules dflags
1694 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1696 pkg_db = pkgIdMap (pkgState dflags)
1698 completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
1701 -- ---------------------------------------------------------------------------
1702 -- User code exception handling
1704 -- This is the exception handler for exceptions generated by the
1705 -- user's code and exceptions coming from children sessions;
1706 -- it normally just prints out the exception. The
1707 -- handler must be recursive, in case showing the exception causes
1708 -- more exceptions to be raised.
1710 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1711 -- raising another exception. We therefore don't put the recursive
1712 -- handler arond the flushing operation, so if stderr is closed
1713 -- GHCi will just die gracefully rather than going into an infinite loop.
1714 handler :: SomeException -> GHCi Bool
1716 handler exception = do
1718 io installSignalHandlers
1719 ghciHandle handler (showException exception >> return False)
1721 showException :: SomeException -> GHCi ()
1723 io $ case fromException se of
1724 Just Interrupted -> putStrLn "Interrupted."
1725 -- omit the location for CmdLineError:
1726 Just (CmdLineError s) -> putStrLn s
1728 Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
1729 Just other_ghc_ex -> print other_ghc_ex
1730 Nothing -> putStrLn ("*** Exception: " ++ show se)
1732 -----------------------------------------------------------------------------
1733 -- recursive exception handlers
1735 -- Don't forget to unblock async exceptions in the handler, or if we're
1736 -- in an exception loop (eg. let a = error a in a) the ^C exception
1737 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1739 ghciHandle :: MonadException m => (SomeException -> m a) -> m a -> m a
1740 ghciHandle h m = Haskeline.catch m $ \e -> unblock (h e)
1742 ghciTry :: GHCi a -> GHCi (Either SomeException a)
1743 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
1745 -- ----------------------------------------------------------------------------
1748 -- TODO: won't work if home dir is encoded.
1749 -- (changeDirectory may not work either in that case.)
1750 expandPath :: MonadIO m => String -> InputT m String
1751 expandPath path = do
1752 exp_path <- liftIO $ expandPathIO path
1753 enc <- fmap BS.unpack $ Encoding.encode exp_path
1756 expandPathIO :: String -> IO String
1758 case dropWhile isSpace path of
1760 tilde <- getHomeDirectory -- will fail if HOME not defined
1761 return (tilde ++ '/':d)
1765 wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
1766 wantInterpretedModule str = do
1767 modl <- lookupModule str
1768 dflags <- getDynFlags
1769 when (GHC.modulePackageId modl /= thisPackage dflags) $
1770 ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
1771 is_interpreted <- GHC.moduleIsInterpreted modl
1772 when (not is_interpreted) $
1773 ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
1776 wantNameFromInterpretedModule :: GHC.GhcMonad m
1777 => (Name -> SDoc -> m ())
1781 wantNameFromInterpretedModule noCanDo str and_then =
1782 handleSourceError (GHC.printExceptionAndWarnings) $ do
1783 names <- GHC.parseName str
1787 let modl = ASSERT( isExternalName n ) GHC.nameModule n
1788 if not (GHC.isExternalName n)
1789 then noCanDo n $ ppr n <>
1790 text " is not defined in an interpreted module"
1792 is_interpreted <- GHC.moduleIsInterpreted modl
1793 if not is_interpreted
1794 then noCanDo n $ text "module " <> ppr modl <>
1795 text " is not interpreted"
1798 -- -----------------------------------------------------------------------------
1799 -- commands for debugger
1801 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1802 sprintCmd = pprintCommand False False
1803 printCmd = pprintCommand True False
1804 forceCmd = pprintCommand False True
1806 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1807 pprintCommand bind force str = do
1808 pprintClosureCommand bind force str
1810 stepCmd :: String -> GHCi ()
1811 stepCmd [] = doContinue (const True) GHC.SingleStep
1812 stepCmd expression = runStmt expression GHC.SingleStep >> return ()
1814 stepLocalCmd :: String -> GHCi ()
1815 stepLocalCmd [] = do
1816 mb_span <- getCurrentBreakSpan
1818 Nothing -> stepCmd []
1820 Just mod <- getCurrentBreakModule
1821 current_toplevel_decl <- enclosingTickSpan mod loc
1822 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1824 stepLocalCmd expression = stepCmd expression
1826 stepModuleCmd :: String -> GHCi ()
1827 stepModuleCmd [] = do
1828 mb_span <- getCurrentBreakSpan
1830 Nothing -> stepCmd []
1832 Just span <- getCurrentBreakSpan
1833 let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span
1834 doContinue f GHC.SingleStep
1836 stepModuleCmd expression = stepCmd expression
1838 -- | Returns the span of the largest tick containing the srcspan given
1839 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1840 enclosingTickSpan mod src = do
1841 ticks <- getTickArray mod
1842 let line = srcSpanStartLine src
1843 ASSERT (inRange (bounds ticks) line) do
1844 let enclosing_spans = [ span | (_,span) <- ticks ! line
1845 , srcSpanEnd span >= srcSpanEnd src]
1846 return . head . sortBy leftmost_largest $ enclosing_spans
1848 traceCmd :: String -> GHCi ()
1849 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1850 traceCmd expression = runStmt expression GHC.RunAndLogSteps >> return ()
1852 continueCmd :: String -> GHCi ()
1853 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1855 -- doContinue :: SingleStep -> GHCi ()
1856 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1857 doContinue pred step = do
1858 runResult <- resume pred step
1859 _ <- afterRunStmt pred runResult
1862 abandonCmd :: String -> GHCi ()
1863 abandonCmd = noArgs $ do
1864 b <- GHC.abandon -- the prompt will change to indicate the new context
1865 when (not b) $ io $ putStrLn "There is no computation running."
1868 deleteCmd :: String -> GHCi ()
1869 deleteCmd argLine = do
1870 deleteSwitch $ words argLine
1872 deleteSwitch :: [String] -> GHCi ()
1874 io $ putStrLn "The delete command requires at least one argument."
1875 -- delete all break points
1876 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1877 deleteSwitch idents = do
1878 mapM_ deleteOneBreak idents
1880 deleteOneBreak :: String -> GHCi ()
1882 | all isDigit str = deleteBreak (read str)
1883 | otherwise = return ()
1885 historyCmd :: String -> GHCi ()
1887 | null arg = history 20
1888 | all isDigit arg = history (read arg)
1889 | otherwise = io $ putStrLn "Syntax: :history [num]"
1892 resumes <- GHC.getResumeContext
1894 [] -> io $ putStrLn "Not stopped at a breakpoint"
1896 let hist = GHC.resumeHistory r
1897 (took,rest) = splitAt num hist
1899 [] -> io $ putStrLn $
1900 "Empty history. Perhaps you forgot to use :trace?"
1902 spans <- mapM GHC.getHistorySpan took
1903 let nums = map (printf "-%-3d:") [(1::Int)..]
1904 names = map GHC.historyEnclosingDecl took
1905 printForUser (vcat(zipWith3
1906 (\x y z -> x <+> y <+> z)
1908 (map (bold . ppr) names)
1909 (map (parens . ppr) spans)))
1910 io $ putStrLn $ if null rest then "<end of history>" else "..."
1912 bold :: SDoc -> SDoc
1913 bold c | do_bold = text start_bold <> c <> text end_bold
1916 backCmd :: String -> GHCi ()
1917 backCmd = noArgs $ do
1918 (names, _, span) <- GHC.back
1919 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span
1920 printTypeOfNames names
1921 -- run the command set with ":set stop <cmd>"
1923 enqueueCommands [stop st]
1925 forwardCmd :: String -> GHCi ()
1926 forwardCmd = noArgs $ do
1927 (names, ix, span) <- GHC.forward
1928 printForUser $ (if (ix == 0)
1929 then ptext (sLit "Stopped at")
1930 else ptext (sLit "Logged breakpoint at")) <+> ppr span
1931 printTypeOfNames names
1932 -- run the command set with ":set stop <cmd>"
1934 enqueueCommands [stop st]
1936 -- handle the "break" command
1937 breakCmd :: String -> GHCi ()
1938 breakCmd argLine = do
1939 breakSwitch $ words argLine
1941 breakSwitch :: [String] -> GHCi ()
1943 io $ putStrLn "The break command requires at least one argument."
1944 breakSwitch (arg1:rest)
1945 | looksLikeModuleName arg1 && not (null rest) = do
1946 mod <- wantInterpretedModule arg1
1947 breakByModule mod rest
1948 | all isDigit arg1 = do
1949 (toplevel, _) <- GHC.getContext
1951 (mod : _) -> breakByModuleLine mod (read arg1) rest
1953 io $ putStrLn "Cannot find default module for breakpoint."
1954 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1955 | otherwise = do -- try parsing it as an identifier
1956 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1957 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1958 if GHC.isGoodSrcLoc loc
1959 then ASSERT( isExternalName name )
1960 findBreakAndSet (GHC.nameModule name) $
1961 findBreakByCoord (Just (GHC.srcLocFile loc))
1962 (GHC.srcLocLine loc,
1964 else noCanDo name $ text "can't find its location: " <> ppr loc
1966 noCanDo n why = printForUser $
1967 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1969 breakByModule :: Module -> [String] -> GHCi ()
1970 breakByModule mod (arg1:rest)
1971 | all isDigit arg1 = do -- looks like a line number
1972 breakByModuleLine mod (read arg1) rest
1976 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1977 breakByModuleLine mod line args
1978 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1979 | [col] <- args, all isDigit col =
1980 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1981 | otherwise = breakSyntax
1984 breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1986 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1987 findBreakAndSet mod lookupTickTree = do
1988 tickArray <- getTickArray mod
1989 (breakArray, _) <- getModBreak mod
1990 case lookupTickTree tickArray of
1991 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1992 Just (tick, span) -> do
1993 success <- io $ setBreakFlag True breakArray tick
1997 recordBreak $ BreakLocation
2004 text "Breakpoint " <> ppr nm <>
2006 then text " was already set at " <> ppr span
2007 else text " activated at " <> ppr span
2009 printForUser $ text "Breakpoint could not be activated at"
2012 -- When a line number is specified, the current policy for choosing
2013 -- the best breakpoint is this:
2014 -- - the leftmost complete subexpression on the specified line, or
2015 -- - the leftmost subexpression starting on the specified line, or
2016 -- - the rightmost subexpression enclosing the specified line
2018 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2019 findBreakByLine line arr
2020 | not (inRange (bounds arr) line) = Nothing
2022 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
2023 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2024 listToMaybe (sortBy (rightmost `on` snd) ticks)
2028 starts_here = [ tick | tick@(_,span) <- ticks,
2029 GHC.srcSpanStartLine span == line ]
2031 (complete,incomplete) = partition ends_here starts_here
2032 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2034 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2035 -> Maybe (BreakIndex,SrcSpan)
2036 findBreakByCoord mb_file (line, col) arr
2037 | not (inRange (bounds arr) line) = Nothing
2039 listToMaybe (sortBy (rightmost `on` snd) contains ++
2040 sortBy (leftmost_smallest `on` snd) after_here)
2044 -- the ticks that span this coordinate
2045 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2046 is_correct_file span ]
2048 is_correct_file span
2049 | Just f <- mb_file = GHC.srcSpanFile span == f
2052 after_here = [ tick | tick@(_,span) <- ticks,
2053 GHC.srcSpanStartLine span == line,
2054 GHC.srcSpanStartCol span >= col ]
2056 -- For now, use ANSI bold on terminals that we know support it.
2057 -- Otherwise, we add a line of carets under the active expression instead.
2058 -- In particular, on Windows and when running the testsuite (which sets
2059 -- TERM to vt100 for other reasons) we get carets.
2060 -- We really ought to use a proper termcap/terminfo library.
2062 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2063 where mTerm = System.Environment.getEnv "TERM"
2064 `catchIO` \_ -> return "TERM not set"
2066 start_bold :: String
2067 start_bold = "\ESC[1m"
2069 end_bold = "\ESC[0m"
2071 listCmd :: String -> InputT GHCi ()
2073 mb_span <- lift getCurrentBreakSpan
2076 printForUser $ text "Not stopped at a breakpoint; nothing to list"
2078 | GHC.isGoodSrcSpan span -> listAround span True
2080 do resumes <- GHC.getResumeContext
2082 [] -> panic "No resumes"
2084 do let traceIt = case GHC.resumeHistory r of
2085 [] -> text "rerunning with :trace,"
2087 doWhat = traceIt <+> text ":back then :list"
2088 printForUser (text "Unable to list source for" <+>
2090 $$ text "Try" <+> doWhat)
2091 listCmd str = list2 (words str)
2093 list2 :: [String] -> InputT GHCi ()
2094 list2 [arg] | all isDigit arg = do
2095 (toplevel, _) <- GHC.getContext
2097 [] -> outputStrLn "No module to list"
2098 (mod : _) -> listModuleLine mod (read arg)
2099 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2100 mod <- wantInterpretedModule arg1
2101 listModuleLine mod (read arg2)
2103 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2104 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2105 if GHC.isGoodSrcLoc loc
2107 tickArray <- ASSERT( isExternalName name )
2108 lift $ getTickArray (GHC.nameModule name)
2109 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2110 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2113 Nothing -> listAround (GHC.srcLocSpan loc) False
2114 Just (_,span) -> listAround span False
2116 noCanDo name $ text "can't find its location: " <>
2119 noCanDo n why = printForUser $
2120 text "cannot list source code for " <> ppr n <> text ": " <> why
2122 outputStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2124 listModuleLine :: Module -> Int -> InputT GHCi ()
2125 listModuleLine modl line = do
2126 graph <- GHC.getModuleGraph
2127 let this = filter ((== modl) . GHC.ms_mod) graph
2129 [] -> panic "listModuleLine"
2131 let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
2132 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2133 listAround (GHC.srcLocSpan loc) False
2135 -- | list a section of a source file around a particular SrcSpan.
2136 -- If the highlight flag is True, also highlight the span using
2137 -- start_bold\/end_bold.
2139 -- GHC files are UTF-8, so we can implement this by:
2140 -- 1) read the file in as a BS and syntax highlight it as before
2141 -- 2) convert the BS to String using utf-string, and write it out.
2142 -- It would be better if we could convert directly between UTF-8 and the
2143 -- console encoding, of course.
2144 listAround :: MonadIO m => SrcSpan -> Bool -> InputT m ()
2145 listAround span do_highlight = do
2146 contents <- liftIO $ BS.readFile (unpackFS file)
2148 lines = BS.split '\n' contents
2149 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2150 drop (line1 - 1 - pad_before) $ lines
2151 fst_line = max 1 (line1 - pad_before)
2152 line_nos = [ fst_line .. ]
2154 highlighted | do_highlight = zipWith highlight line_nos these_lines
2155 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2157 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2158 prefixed = zipWith ($) highlighted bs_line_nos
2160 let output = BS.intercalate (BS.pack "\n") prefixed
2161 utf8Decoded <- liftIO $ BS.useAsCStringLen output
2162 $ \(p,n) -> utf8DecodeString (castPtr p) n
2163 outputStrLn utf8Decoded
2165 file = GHC.srcSpanFile span
2166 line1 = GHC.srcSpanStartLine span
2167 col1 = GHC.srcSpanStartCol span
2168 line2 = GHC.srcSpanEndLine span
2169 col2 = GHC.srcSpanEndCol span
2171 pad_before | line1 == 1 = 0
2175 highlight | do_bold = highlight_bold
2176 | otherwise = highlight_carets
2178 highlight_bold no line prefix
2179 | no == line1 && no == line2
2180 = let (a,r) = BS.splitAt col1 line
2181 (b,c) = BS.splitAt (col2-col1) r
2183 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2185 = let (a,b) = BS.splitAt col1 line in
2186 BS.concat [prefix, a, BS.pack start_bold, b]
2188 = let (a,b) = BS.splitAt col2 line in
2189 BS.concat [prefix, a, BS.pack end_bold, b]
2190 | otherwise = BS.concat [prefix, line]
2192 highlight_carets no line prefix
2193 | no == line1 && no == line2
2194 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2195 BS.replicate (col2-col1) '^']
2197 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2200 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2202 | otherwise = BS.concat [prefix, line]
2204 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2205 nl = BS.singleton '\n'
2207 -- --------------------------------------------------------------------------
2210 getTickArray :: Module -> GHCi TickArray
2211 getTickArray modl = do
2213 let arrmap = tickarrays st
2214 case lookupModuleEnv arrmap modl of
2215 Just arr -> return arr
2217 (_breakArray, ticks) <- getModBreak modl
2218 let arr = mkTickArray (assocs ticks)
2219 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2222 discardTickArrays :: GHCi ()
2223 discardTickArrays = do
2225 setGHCiState st{tickarrays = emptyModuleEnv}
2227 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2229 = accumArray (flip (:)) [] (1, max_line)
2230 [ (line, (nm,span)) | (nm,span) <- ticks,
2231 line <- srcSpanLines span ]
2233 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2234 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2235 GHC.srcSpanEndLine span ]
2237 lookupModule :: GHC.GhcMonad m => String -> m Module
2238 lookupModule modName
2239 = GHC.lookupModule (GHC.mkModuleName modName) Nothing
2241 -- don't reset the counter back to zero?
2242 discardActiveBreakPoints :: GHCi ()
2243 discardActiveBreakPoints = do
2245 mapM_ (turnOffBreak.snd) (breaks st)
2246 setGHCiState $ st { breaks = [] }
2248 deleteBreak :: Int -> GHCi ()
2249 deleteBreak identity = do
2251 let oldLocations = breaks st
2252 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2254 then printForUser (text "Breakpoint" <+> ppr identity <+>
2255 text "does not exist")
2257 mapM_ (turnOffBreak.snd) this
2258 setGHCiState $ st { breaks = rest }
2260 turnOffBreak :: BreakLocation -> GHCi Bool
2261 turnOffBreak loc = do
2262 (arr, _) <- getModBreak (breakModule loc)
2263 io $ setBreakFlag False arr (breakTick loc)
2265 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2266 getModBreak mod = do
2267 Just mod_info <- GHC.getModuleInfo mod
2268 let modBreaks = GHC.modInfoModBreaks mod_info
2269 let array = GHC.modBreaks_flags modBreaks
2270 let ticks = GHC.modBreaks_locs modBreaks
2271 return (array, ticks)
2273 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2274 setBreakFlag toggle array index
2275 | toggle = GHC.setBreakOn array index
2276 | otherwise = GHC.setBreakOff array index