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
403 runCommands $ fileLoop hdl
405 getDirectory f = case takeDirectory f of "" -> "."; d -> d
407 when (read_dot_files) $ do
408 cfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
409 cfgs <- io $ mapM canonicalizePath (catMaybes cfgs0)
410 mapM_ sourceConfigFile (nub cfgs)
411 -- nub, because we don't want to read .ghci twice if the
414 -- Perform a :load for files given on the GHCi command line
415 -- When in -e mode, if the load fails then we want to stop
416 -- immediately rather than going on to evaluate the expression.
417 when (not (null paths)) $ do
418 ok <- ghciHandle (\e -> do showException e; return Failed) $
419 -- TODO: this is a hack.
420 runInputTWithPrefs defaultPrefs defaultSettings $ do
421 let (filePaths, phases) = unzip paths
422 filePaths' <- mapM (Encoding.decode . BS.pack) filePaths
423 loadModule (zip filePaths' phases)
424 when (isJust maybe_exprs && failed ok) $
425 io (exitWith (ExitFailure 1))
427 -- if verbosity is greater than 0, or we are connected to a
428 -- terminal, display the prompt in the interactive loop.
429 is_tty <- io (hIsTerminalDevice stdin)
430 dflags <- getDynFlags
431 let show_prompt = verbosity dflags > 0 || is_tty
436 -- enter the interactive loop
437 runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
439 -- just evaluate the expression we were given
440 enqueueCommands exprs
441 let handle e = do st <- getGHCiState
442 -- Jump through some hoops to get the
443 -- current progname in the exception text:
444 -- <progname>: <exception>
445 io $ withProgName (progname st)
446 -- this used to be topHandlerFastExit, see #2228
448 runInputTWithPrefs defaultPrefs defaultSettings $ do
450 runCommands' handle (return Nothing)
453 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
455 runGHCiInput :: InputT GHCi a -> GHCi a
457 histFile <- io $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
459 let settings = setComplete ghciCompleteWord
460 $ defaultSettings {historyFile = histFile}
461 runInputT settings $ do
465 nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
466 nextInputLine show_prompt is_tty
468 prompt <- if show_prompt then lift mkPrompt else return ""
471 when show_prompt $ lift mkPrompt >>= liftIO . putStr
474 -- NOTE: We only read .ghci files if they are owned by the current user,
475 -- and aren't world writable. Otherwise, we could be accidentally
476 -- running code planted by a malicious third party.
478 -- Furthermore, We only read ./.ghci if . is owned by the current user
479 -- and isn't writable by anyone else. I think this is sufficient: we
480 -- don't need to check .. and ../.. etc. because "." always refers to
481 -- the same directory while a process is running.
483 checkPerms :: String -> IO Bool
484 #ifdef mingw32_HOST_OS
489 handleIO (\_ -> return False) $ do
490 st <- getFileStatus name
492 if fileOwner st /= me then do
493 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
496 let mode = fileMode st
497 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
498 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
500 putStrLn $ "*** WARNING: " ++ name ++
501 " is writable by someone else, IGNORING!"
506 fileLoop :: MonadIO m => Handle -> InputT m (Maybe String)
508 l <- liftIO $ IO.try $ hGetLine hdl
510 Left e | isEOFError e -> return Nothing
511 | InvalidArgument <- etype -> return Nothing
512 | otherwise -> liftIO $ ioError e
513 where etype = ioeGetErrorType e
514 -- treat InvalidArgument in the same way as EOF:
515 -- this can happen if the user closed stdin, or
516 -- perhaps did getContents which closes stdin at
518 Right l -> return (Just l)
520 mkPrompt :: GHCi String
522 (toplevs,exports) <- GHC.getContext
523 resumes <- GHC.getResumeContext
524 -- st <- getGHCiState
530 let ix = GHC.resumeHistoryIx r
532 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
534 let hist = GHC.resumeHistory r !! (ix-1)
535 span <- GHC.getHistorySpan hist
536 return (brackets (ppr (negate ix) <> char ':'
537 <+> ppr span) <> space)
539 dots | _:rs <- resumes, not (null rs) = text "... "
546 -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
547 -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
548 -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
549 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
550 hsep (map (ppr . GHC.moduleName) exports)
552 deflt_prompt = dots <> context_bit <> modules_bit
554 f ('%':'s':xs) = deflt_prompt <> f xs
555 f ('%':'%':xs) = char '%' <> f xs
556 f (x:xs) = char x <> f xs
560 return (showSDoc (f (prompt st)))
563 queryQueue :: GHCi (Maybe String)
568 c:cs -> do setGHCiState st{ cmdqueue = cs }
571 runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
572 runCommands = runCommands' handler
574 runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
575 -> InputT GHCi (Maybe String) -> InputT GHCi ()
576 runCommands' eh getCmd = do
577 b <- handleGhcException (\e -> case e of
578 Interrupted -> return False
579 _other -> liftIO (print e) >> return True)
580 (runOneCommand eh getCmd)
581 if b then return () else runCommands' eh getCmd
583 runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
585 runOneCommand eh getCmd = do
586 mb_cmd <- noSpace (lift queryQueue)
587 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
589 Nothing -> return True
590 Just c -> ghciHandle (lift . eh) $
591 handleSourceError printErrorAndKeepGoing
594 printErrorAndKeepGoing err = do
595 GHC.printExceptionAndWarnings err
598 noSpace q = q >>= maybe (return Nothing)
599 (\c->case removeSpaces c of
601 ":{" -> multiLineCmd q
602 c -> return (Just c) )
604 st <- lift getGHCiState
606 lift $ setGHCiState st{ prompt = "%s| " }
607 mb_cmd <- collectCommand q ""
608 lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p }
610 -- we can't use removeSpaces for the sublines here, so
611 -- multiline commands are somewhat more brittle against
612 -- fileformat errors (such as \r in dos input on unix),
613 -- we get rid of any extra spaces for the ":}" test;
614 -- we also avoid silent failure if ":}" is not found;
615 -- and since there is no (?) valid occurrence of \r (as
616 -- opposed to its String representation, "\r") inside a
617 -- ghci command, we replace any such with ' ' (argh:-(
618 collectCommand q c = q >>=
619 maybe (liftIO (ioError collectError))
620 (\l->if removeSpaces l == ":}"
621 then return (Just $ removeSpaces c)
622 else collectCommand q (c++map normSpace l))
623 where normSpace '\r' = ' '
625 -- QUESTION: is userError the one to use here?
626 collectError = userError "unterminated multiline command :{ .. :}"
627 doCommand (':' : cmd) = specialCommand cmd
628 doCommand stmt = do _ <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion
631 enqueueCommands :: [String] -> GHCi ()
632 enqueueCommands cmds = do
634 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
637 runStmt :: String -> SingleStep -> GHCi Bool
639 | null (filter (not.isSpace) stmt) = return False
640 | ["import", mod] <- words stmt = keepGoing' setContext ('+':mod)
643 #if __GLASGOW_HASKELL__ >= 611
644 -- In the new IO library, read handles buffer data even if the Handle
645 -- is set to NoBuffering. This causes problems for GHCi where there
646 -- are really two stdin Handles. So we flush any bufferred data in
647 -- GHCi's stdin Handle here (only relevant if stdin is attached to
648 -- a file, otherwise the read buffer can't be flushed).
649 _ <- liftIO $ IO.try $ hFlushAll stdin
651 result <- GhciMonad.runStmt stmt step
652 afterRunStmt (const True) result
654 --afterRunStmt :: GHC.RunResult -> GHCi Bool
655 -- False <=> the statement failed to compile
656 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
657 afterRunStmt _ (GHC.RunException e) = throw e
658 afterRunStmt step_here run_result = do
659 resumes <- GHC.getResumeContext
661 GHC.RunOk names -> do
662 show_types <- isOptionSet ShowType
663 when show_types $ printTypeOfNames names
664 GHC.RunBreak _ names mb_info
665 | isNothing mb_info ||
666 step_here (GHC.resumeSpan $ head resumes) -> do
667 mb_id_loc <- toBreakIdAndLocation mb_info
668 let breakCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
670 then printStoppedAtBreakInfo (head resumes) names
671 else enqueueCommands [breakCmd]
672 -- run the command set with ":set stop <cmd>"
674 enqueueCommands [stop st]
676 | otherwise -> resume step_here GHC.SingleStep >>=
677 afterRunStmt step_here >> return ()
681 io installSignalHandlers
682 b <- isOptionSet RevertCAFs
685 return (case run_result of GHC.RunOk _ -> True; _ -> False)
687 toBreakIdAndLocation ::
688 Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
689 toBreakIdAndLocation Nothing = return Nothing
690 toBreakIdAndLocation (Just info) = do
691 let mod = GHC.breakInfo_module info
692 nm = GHC.breakInfo_number info
694 return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
695 breakModule loc == mod,
696 breakTick loc == nm ]
698 printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
699 printStoppedAtBreakInfo resume names = do
700 printForUser $ ptext (sLit "Stopped at") <+>
701 ppr (GHC.resumeSpan resume)
702 -- printTypeOfNames session names
703 let namesSorted = sortBy compareNames names
704 tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
705 docs <- pprTypeAndContents [id | AnId id <- tythings]
706 printForUserPartWay docs
708 printTypeOfNames :: [Name] -> GHCi ()
709 printTypeOfNames names
710 = mapM_ (printTypeOfName ) $ sortBy compareNames names
712 compareNames :: Name -> Name -> Ordering
713 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
714 where compareWith n = (getOccString n, getSrcSpan n)
716 printTypeOfName :: Name -> GHCi ()
718 = do maybe_tything <- GHC.lookupName n
719 case maybe_tything of
721 Just thing -> printTyThing thing
724 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
726 specialCommand :: String -> InputT GHCi Bool
727 specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
728 specialCommand str = do
729 let (cmd,rest) = break isSpace str
730 maybe_cmd <- lift $ lookupCommand cmd
732 GotCommand (_,f,_) -> f (dropWhile isSpace rest)
734 do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
738 do liftIO $ hPutStr stdout ("there is no last command to perform\n"
742 lookupCommand :: String -> GHCi (MaybeCommand)
743 lookupCommand "" = do
745 case last_command st of
746 Just c -> return $ GotCommand c
747 Nothing -> return NoLastCommand
748 lookupCommand str = do
749 mc <- io $ lookupCommand' str
751 setGHCiState st{ last_command = mc }
753 Just c -> GotCommand c
754 Nothing -> BadCommand
756 lookupCommand' :: String -> IO (Maybe Command)
757 lookupCommand' ":" = return Nothing
758 lookupCommand' str' = do
759 macros <- readIORef macros_ref
760 let{ (str, cmds) = case str' of
761 ':' : rest -> (rest, builtin_commands)
762 _ -> (str', macros ++ builtin_commands) }
763 -- look for exact match first, then the first prefix match
764 return $ case [ c | c <- cmds, str == cmdName c ] of
766 [] -> case [ c | c@(s,_,_) <- cmds, str `isPrefixOf` s ] of
770 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
771 getCurrentBreakSpan = do
772 resumes <- GHC.getResumeContext
776 let ix = GHC.resumeHistoryIx r
778 then return (Just (GHC.resumeSpan r))
780 let hist = GHC.resumeHistory r !! (ix-1)
781 span <- GHC.getHistorySpan hist
784 getCurrentBreakModule :: GHCi (Maybe Module)
785 getCurrentBreakModule = do
786 resumes <- GHC.getResumeContext
790 let ix = GHC.resumeHistoryIx r
792 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
794 let hist = GHC.resumeHistory r !! (ix-1)
795 return $ Just $ GHC.getHistoryModule hist
797 -----------------------------------------------------------------------------
800 noArgs :: GHCi () -> String -> GHCi ()
802 noArgs _ _ = io $ putStrLn "This command takes no arguments"
804 help :: String -> GHCi ()
805 help _ = io (putStr helpText)
807 info :: String -> InputT GHCi ()
808 info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
809 info s = handleSourceError GHC.printExceptionAndWarnings $ do
810 { let names = words s
811 ; dflags <- getDynFlags
812 ; let pefas = dopt Opt_PrintExplicitForalls dflags
813 ; mapM_ (infoThing pefas) names }
815 infoThing pefas str = do
816 names <- GHC.parseName str
817 mb_stuffs <- mapM GHC.getInfo names
818 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
819 unqual <- GHC.getPrintUnqual
820 outputStrLn $ showSDocForUser unqual $
821 vcat (intersperse (text "") $
822 map (pprInfo pefas) filtered)
824 -- Filter out names whose parent is also there Good
825 -- example is '[]', which is both a type and data
826 -- constructor in the same type
827 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
828 filterOutChildren get_thing xs
829 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
831 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
833 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
834 pprInfo pefas (thing, fixity, insts)
835 = pprTyThingInContextLoc pefas thing
836 $$ show_fixity fixity
837 $$ vcat (map GHC.pprInstance insts)
840 | fix == GHC.defaultFixity = empty
841 | otherwise = ppr fix <+> ppr (GHC.getName thing)
843 runMain :: String -> GHCi ()
844 runMain s = case toArgs s of
845 Left err -> io (hPutStrLn stderr err)
847 do dflags <- getDynFlags
848 case mainFunIs dflags of
849 Nothing -> doWithArgs args "main"
850 Just f -> doWithArgs args f
852 runRun :: String -> GHCi ()
853 runRun s = case toCmdArgs s of
854 Left err -> io (hPutStrLn stderr err)
855 Right (cmd, args) -> doWithArgs args cmd
857 doWithArgs :: [String] -> String -> GHCi ()
858 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
859 show args ++ " (" ++ cmd ++ ")"]
861 addModule :: [FilePath] -> InputT GHCi ()
863 lift revertCAFs -- always revert CAFs on load/add.
864 files <- mapM expandPath files
865 targets <- mapM (\m -> GHC.guessTarget m Nothing) files
866 -- remove old targets with the same id; e.g. for :add *M
867 mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
868 mapM_ GHC.addTarget targets
869 prev_context <- GHC.getContext
870 ok <- trySuccess $ GHC.load LoadAllTargets
871 afterLoad ok False prev_context
873 changeDirectory :: String -> InputT GHCi ()
874 changeDirectory "" = do
875 -- :cd on its own changes to the user's home directory
876 either_dir <- liftIO $ IO.try getHomeDirectory
879 Right dir -> changeDirectory dir
880 changeDirectory dir = do
881 graph <- GHC.getModuleGraph
882 when (not (null graph)) $
883 outputStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
884 prev_context <- GHC.getContext
886 _ <- GHC.load LoadAllTargets
887 lift $ setContextAfterLoad prev_context False []
888 GHC.workingDirectoryChanged
889 dir <- expandPath dir
890 liftIO $ setCurrentDirectory dir
892 trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
894 handleSourceError (\e -> do GHC.printExceptionAndWarnings e
898 editFile :: String -> GHCi ()
900 do file <- if null str then chooseEditFile else return str
904 $ ghcError (CmdLineError "editor not set, use :set editor")
905 _ <- io $ system (cmd ++ ' ':file)
908 -- The user didn't specify a file so we pick one for them.
909 -- Our strategy is to pick the first module that failed to load,
910 -- or otherwise the first target.
912 -- XXX: Can we figure out what happened if the depndecy analysis fails
913 -- (e.g., because the porgrammeer mistyped the name of a module)?
914 -- XXX: Can we figure out the location of an error to pass to the editor?
915 -- XXX: if we could figure out the list of errors that occured during the
916 -- last load/reaload, then we could start the editor focused on the first
918 chooseEditFile :: GHCi String
920 do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
922 graph <- GHC.getModuleGraph
923 failed_graph <- filterM hasFailed graph
924 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
926 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
929 case pick (order failed_graph) of
930 Just file -> return file
932 do targets <- GHC.getTargets
933 case msum (map fromTarget targets) of
934 Just file -> return file
935 Nothing -> ghcError (CmdLineError "No files to edit.")
937 where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
938 fromTarget _ = Nothing -- when would we get a module target?
940 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
941 defineMacro _ (':':_) =
942 io $ putStrLn "macro name cannot start with a colon"
943 defineMacro overwrite s = do
944 let (macro_name, definition) = break isSpace s
945 macros <- io (readIORef macros_ref)
946 let defined = map cmdName macros
949 then io $ putStrLn "no macros defined"
950 else io $ putStr ("the following macros are defined:\n" ++
953 if (not overwrite && macro_name `elem` defined)
954 then ghcError (CmdLineError
955 ("macro '" ++ macro_name ++ "' is already defined"))
958 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
960 -- give the expression a type signature, so we can be sure we're getting
961 -- something of the right type.
962 let new_expr = '(' : definition ++ ") :: String -> IO String"
964 -- compile the expression
965 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
966 hv <- GHC.compileExpr new_expr
967 io (writeIORef macros_ref --
968 (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)]))
970 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
972 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
973 -- make sure we force any exceptions in the result, while we are still
974 -- inside the exception handler for commands:
975 seqList str (return ())
976 enqueueCommands (lines str)
979 undefineMacro :: String -> GHCi ()
980 undefineMacro str = mapM_ undef (words str)
981 where undef macro_name = do
982 cmds <- io (readIORef macros_ref)
983 if (macro_name `notElem` map cmdName cmds)
984 then ghcError (CmdLineError
985 ("macro '" ++ macro_name ++ "' is not defined"))
987 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
989 cmdCmd :: String -> GHCi ()
991 let expr = '(' : str ++ ") :: IO String"
992 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
993 hv <- GHC.compileExpr expr
994 cmds <- io $ (unsafeCoerce# hv :: IO String)
995 enqueueCommands (lines cmds)
998 loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
999 loadModule fs = timeIt (loadModule' fs)
1001 loadModule_ :: [FilePath] -> InputT GHCi ()
1002 loadModule_ fs = loadModule (zip fs (repeat Nothing)) >> return ()
1004 loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
1005 loadModule' files = do
1006 prev_context <- GHC.getContext
1010 lift discardActiveBreakPoints
1012 _ <- GHC.load LoadAllTargets
1014 let (filenames, phases) = unzip files
1015 exp_filenames <- mapM expandPath filenames
1016 let files' = zip exp_filenames phases
1017 targets <- mapM (uncurry GHC.guessTarget) files'
1019 -- NOTE: we used to do the dependency anal first, so that if it
1020 -- fails we didn't throw away the current set of modules. This would
1021 -- require some re-working of the GHC interface, so we'll leave it
1022 -- as a ToDo for now.
1024 GHC.setTargets targets
1025 doLoad False prev_context LoadAllTargets
1027 checkModule :: String -> InputT GHCi ()
1029 let modl = GHC.mkModuleName m
1030 prev_context <- GHC.getContext
1031 ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do
1032 r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
1033 outputStrLn (showSDoc (
1034 case GHC.moduleInfo r of
1035 cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1037 (local,global) = ASSERT( all isExternalName scope )
1038 partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1040 (text "global names: " <+> ppr global) $$
1041 (text "local names: " <+> ppr local)
1044 afterLoad (successIf ok) False prev_context
1046 reloadModule :: String -> InputT GHCi ()
1048 prev_context <- GHC.getContext
1049 _ <- doLoad True prev_context $
1050 if null m then LoadAllTargets
1051 else LoadUpTo (GHC.mkModuleName m)
1054 doLoad :: Bool -> ([Module],[Module]) -> LoadHowMuch -> InputT GHCi SuccessFlag
1055 doLoad retain_context prev_context howmuch = do
1056 -- turn off breakpoints before we load: we can't turn them off later, because
1057 -- the ModBreaks will have gone away.
1058 lift discardActiveBreakPoints
1059 ok <- trySuccess $ GHC.load howmuch
1060 afterLoad ok retain_context prev_context
1063 afterLoad :: SuccessFlag -> Bool -> ([Module],[Module]) -> InputT GHCi ()
1064 afterLoad ok retain_context prev_context = do
1065 lift revertCAFs -- always revert CAFs on load.
1066 lift discardTickArrays
1067 loaded_mod_summaries <- getLoadedModules
1068 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1069 loaded_mod_names = map GHC.moduleName loaded_mods
1070 modulesLoadedMsg ok loaded_mod_names
1072 lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
1075 setContextAfterLoad :: ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi ()
1076 setContextAfterLoad prev keep_ctxt [] = do
1077 prel_mod <- getPrelude
1078 setContextKeepingPackageModules prev keep_ctxt ([], [prel_mod])
1079 setContextAfterLoad prev keep_ctxt ms = do
1080 -- load a target if one is available, otherwise load the topmost module.
1081 targets <- GHC.getTargets
1082 case [ m | Just m <- map (findTarget ms) targets ] of
1084 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1085 load_this (last graph')
1090 = case filter (`matches` t) ms of
1094 summary `matches` Target (TargetModule m) _ _
1095 = GHC.ms_mod_name summary == m
1096 summary `matches` Target (TargetFile f _) _ _
1097 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1101 load_this summary | m <- GHC.ms_mod summary = do
1102 b <- GHC.moduleIsInterpreted m
1103 if b then setContextKeepingPackageModules prev keep_ctxt ([m], [])
1105 prel_mod <- getPrelude
1106 setContextKeepingPackageModules prev keep_ctxt ([],[prel_mod,m])
1108 -- | Keep any package modules (except Prelude) when changing the context.
1109 setContextKeepingPackageModules
1110 :: ([Module],[Module]) -- previous context
1111 -> Bool -- re-execute :module commands
1112 -> ([Module],[Module]) -- new context
1114 setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do
1115 let (_,bs0) = prev_context
1116 prel_mod <- getPrelude
1117 let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1118 let bs1 = if null as then nub (prel_mod : bs) else bs
1119 GHC.setContext as (nub (bs1 ++ pkg_modules))
1123 mapM_ (playCtxtCmd False) (remembered_ctx st)
1126 setGHCiState st{ remembered_ctx = [] }
1128 isHomeModule :: Module -> Bool
1129 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1131 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi ()
1132 modulesLoadedMsg ok mods = do
1133 dflags <- getDynFlags
1134 when (verbosity dflags > 0) $ do
1136 | null mods = text "none."
1137 | otherwise = hsep (
1138 punctuate comma (map ppr mods)) <> text "."
1141 outputStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))
1143 outputStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas))
1146 typeOfExpr :: String -> InputT GHCi ()
1148 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1149 ty <- GHC.exprType str
1150 dflags <- getDynFlags
1151 let pefas = dopt Opt_PrintExplicitForalls dflags
1152 printForUser' $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]
1154 kindOfType :: String -> InputT GHCi ()
1156 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1157 ty <- GHC.typeKind str
1158 printForUser' $ text str <+> dcolon <+> ppr ty
1160 quit :: String -> InputT GHCi Bool
1161 quit _ = return True
1163 shellEscape :: String -> GHCi Bool
1164 shellEscape str = io (system str >> return False)
1166 -----------------------------------------------------------------------------
1167 -- Browsing a module's contents
1169 browseCmd :: Bool -> String -> InputT GHCi ()
1172 ['*':s] | looksLikeModuleName s -> do
1173 m <- lift $ wantInterpretedModule s
1174 browseModule bang m False
1175 [s] | looksLikeModuleName s -> do
1176 m <- lift $ lookupModule s
1177 browseModule bang m True
1179 (as,bs) <- GHC.getContext
1180 -- Guess which module the user wants to browse. Pick
1181 -- modules that are interpreted first. The most
1182 -- recently-added module occurs last, it seems.
1184 (as@(_:_), _) -> browseModule bang (last as) True
1185 ([], bs@(_:_)) -> browseModule bang (last bs) True
1186 ([], []) -> ghcError (CmdLineError ":browse: no current module")
1187 _ -> ghcError (CmdLineError "syntax: :browse <module>")
1189 -- without bang, show items in context of their parents and omit children
1190 -- with bang, show class methods and data constructors separately, and
1191 -- indicate import modules, to aid qualifying unqualified names
1192 -- with sorted, sort items alphabetically
1193 browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
1194 browseModule bang modl exports_only = do
1195 -- :browse! reports qualifiers wrt current context
1196 current_unqual <- GHC.getPrintUnqual
1197 -- Temporarily set the context to the module we're interested in,
1198 -- just so we can get an appropriate PrintUnqualified
1199 (as,bs) <- GHC.getContext
1200 prel_mod <- lift getPrelude
1201 if exports_only then GHC.setContext [] [prel_mod,modl]
1202 else GHC.setContext [modl] []
1203 target_unqual <- GHC.getPrintUnqual
1204 GHC.setContext as bs
1206 let unqual = if bang then current_unqual else target_unqual
1208 mb_mod_info <- GHC.getModuleInfo modl
1210 Nothing -> ghcError (CmdLineError ("unknown module: " ++
1211 GHC.moduleNameString (GHC.moduleName modl)))
1213 dflags <- getDynFlags
1215 | exports_only = GHC.modInfoExports mod_info
1216 | otherwise = GHC.modInfoTopLevelScope mod_info
1219 -- sort alphabetically name, but putting
1220 -- locally-defined identifiers first.
1221 -- We would like to improve this; see #1799.
1222 sorted_names = loc_sort local ++ occ_sort external
1224 (local,external) = ASSERT( all isExternalName names )
1225 partition ((==modl) . nameModule) names
1226 occ_sort = sortBy (compare `on` nameOccName)
1227 -- try to sort by src location. If the first name in
1228 -- our list has a good source location, then they all should.
1230 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1231 = sortBy (compare `on` nameSrcSpan) names
1235 mb_things <- mapM GHC.lookupName sorted_names
1236 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1238 rdr_env <- GHC.getGRE
1240 let pefas = dopt Opt_PrintExplicitForalls dflags
1241 things | bang = catMaybes mb_things
1242 | otherwise = filtered_things
1243 pretty | bang = pprTyThing
1244 | otherwise = pprTyThingInContext
1246 labels [] = text "-- not currently imported"
1247 labels l = text $ intercalate "\n" $ map qualifier l
1248 qualifier = maybe "-- defined locally"
1249 (("-- imported via "++) . intercalate ", "
1250 . map GHC.moduleNameString)
1251 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1252 modNames = map (importInfo . GHC.getName) things
1254 -- annotate groups of imports with their import modules
1255 -- the default ordering is somewhat arbitrary, so we group
1256 -- by header and sort groups; the names themselves should
1257 -- really come in order of source appearance.. (trac #1799)
1258 annotate mts = concatMap (\(m,ts)->labels m:ts)
1259 $ sortBy cmpQualifiers $ group mts
1260 where cmpQualifiers =
1261 compare `on` (map (fmap (map moduleNameFS)) . fst)
1263 group mts@((m,_):_) = (m,map snd g) : group ng
1264 where (g,ng) = partition ((==m).fst) mts
1266 let prettyThings = map (pretty pefas) things
1267 prettyThings' | bang = annotate $ zip modNames prettyThings
1268 | otherwise = prettyThings
1269 outputStrLn $ showSDocForUser unqual (vcat prettyThings')
1270 -- ToDo: modInfoInstances currently throws an exception for
1271 -- package modules. When it works, we can do this:
1272 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1274 -----------------------------------------------------------------------------
1275 -- Setting the module context
1277 setContext :: String -> GHCi ()
1279 | all sensible strs = do
1280 playCtxtCmd True (cmd, as, bs)
1282 setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] }
1283 | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1285 (cmd, strs, as, bs) =
1287 '+':stuff -> rest AddModules stuff
1288 '-':stuff -> rest RemModules stuff
1289 stuff -> rest SetContext stuff
1291 rest cmd stuff = (cmd, strs, as, bs)
1292 where strs = words stuff
1293 (as,bs) = partitionWith starred strs
1295 sensible ('*':m) = looksLikeModuleName m
1296 sensible m = looksLikeModuleName m
1298 starred ('*':m) = Left m
1301 playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi ()
1302 playCtxtCmd fail (cmd, as, bs)
1304 (as',bs') <- do_checks fail
1305 (prev_as,prev_bs) <- GHC.getContext
1309 prel_mod <- getPrelude
1310 let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs'
1314 let as_to_add = as' \\ (prev_as ++ prev_bs)
1315 bs_to_add = bs' \\ (prev_as ++ prev_bs)
1316 return (prev_as ++ as_to_add, prev_bs ++ bs_to_add)
1318 let new_as = prev_as \\ (as' ++ bs')
1319 new_bs = prev_bs \\ (as' ++ bs')
1320 return (new_as, new_bs)
1321 GHC.setContext new_as new_bs
1324 as' <- mapM wantInterpretedModule as
1325 bs' <- mapM lookupModule bs
1327 do_checks False = do
1328 as' <- mapM (trymaybe . wantInterpretedModule) as
1329 bs' <- mapM (trymaybe . lookupModule) bs
1330 return (catMaybes as', catMaybes bs')
1335 Left _ -> return Nothing
1336 Right a -> return (Just a)
1338 ----------------------------------------------------------------------------
1341 -- set options in the interpreter. Syntax is exactly the same as the
1342 -- ghc command line, except that certain options aren't available (-C,
1345 -- This is pretty fragile: most options won't work as expected. ToDo:
1346 -- figure out which ones & disallow them.
1348 setCmd :: String -> GHCi ()
1350 = do st <- getGHCiState
1351 let opts = options st
1352 io $ putStrLn (showSDoc (
1353 text "options currently set: " <>
1356 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1358 dflags <- getDynFlags
1359 io $ putStrLn (showSDoc (
1360 vcat (text "GHCi-specific dynamic flag settings:"
1361 :map (flagSetting dflags) ghciFlags)
1363 io $ putStrLn (showSDoc (
1364 vcat (text "other dynamic, non-language, flag settings:"
1365 :map (flagSetting dflags) nonLanguageDynFlags)
1367 where flagSetting dflags (str, f, _)
1368 | dopt f dflags = text " " <> text "-f" <> text str
1369 | otherwise = text " " <> text "-fno-" <> text str
1370 (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags)
1372 nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions)
1374 flags = [Opt_PrintExplicitForalls
1375 ,Opt_PrintBindResult
1376 ,Opt_BreakOnException
1378 ,Opt_PrintEvldWithShow
1381 = case getCmd str of
1382 Right ("args", rest) ->
1384 Left err -> io (hPutStrLn stderr err)
1385 Right args -> setArgs args
1386 Right ("prog", rest) ->
1388 Right [prog] -> setProg prog
1389 _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")
1390 Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1391 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1392 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1393 _ -> case toArgs str of
1394 Left err -> io (hPutStrLn stderr err)
1395 Right wds -> setOptions wds
1397 setArgs, setOptions :: [String] -> GHCi ()
1398 setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
1402 setGHCiState st{ args = args }
1406 setGHCiState st{ progname = prog }
1410 setGHCiState st{ editor = cmd }
1412 setStop str@(c:_) | isDigit c
1413 = do let (nm_str,rest) = break (not.isDigit) str
1416 let old_breaks = breaks st
1417 if all ((/= nm) . fst) old_breaks
1418 then printForUser (text "Breakpoint" <+> ppr nm <+>
1419 text "does not exist")
1421 let new_breaks = map fn old_breaks
1422 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1423 | otherwise = (i,loc)
1424 setGHCiState st{ breaks = new_breaks }
1427 setGHCiState st{ stop = cmd }
1429 setPrompt value = do
1432 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1434 '\"' : _ -> case reads value of
1435 [(value', xs)] | all isSpace xs ->
1436 setGHCiState (st { prompt = value' })
1438 io $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
1439 _ -> setGHCiState (st { prompt = value })
1442 do -- first, deal with the GHCi opts (+s, +t, etc.)
1443 let (plus_opts, minus_opts) = partitionWith isPlus wds
1444 mapM_ setOpt plus_opts
1445 -- then, dynamic flags
1446 newDynFlags minus_opts
1448 newDynFlags :: [String] -> GHCi ()
1449 newDynFlags minus_opts = do
1450 dflags <- getDynFlags
1451 let pkg_flags = packageFlags dflags
1452 (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
1453 handleFlagWarnings dflags' warns
1455 if (not (null leftovers))
1456 then ghcError $ errorsToGhcException leftovers
1459 new_pkgs <- setDynFlags dflags'
1461 -- if the package flags changed, we should reset the context
1462 -- and link the new packages.
1463 dflags <- getDynFlags
1464 when (packageFlags dflags /= pkg_flags) $ do
1465 io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
1467 _ <- GHC.load LoadAllTargets
1468 io (linkPackages dflags new_pkgs)
1469 -- package flags changed, we can't re-use any of the old context
1470 setContextAfterLoad ([],[]) False []
1474 unsetOptions :: String -> GHCi ()
1476 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1477 let opts = words str
1478 (minus_opts, rest1) = partition isMinus opts
1479 (plus_opts, rest2) = partitionWith isPlus rest1
1481 if (not (null rest2))
1482 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1485 mapM_ unsetOpt plus_opts
1487 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1488 no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
1490 no_flags <- mapM no_flag minus_opts
1491 newDynFlags no_flags
1493 isMinus :: String -> Bool
1494 isMinus ('-':_) = True
1497 isPlus :: String -> Either String String
1498 isPlus ('+':opt) = Left opt
1499 isPlus other = Right other
1501 setOpt, unsetOpt :: String -> GHCi ()
1504 = case strToGHCiOpt str of
1505 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1506 Just o -> setOption o
1509 = case strToGHCiOpt str of
1510 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1511 Just o -> unsetOption o
1513 strToGHCiOpt :: String -> (Maybe GHCiOption)
1514 strToGHCiOpt "s" = Just ShowTiming
1515 strToGHCiOpt "t" = Just ShowType
1516 strToGHCiOpt "r" = Just RevertCAFs
1517 strToGHCiOpt _ = Nothing
1519 optToStr :: GHCiOption -> String
1520 optToStr ShowTiming = "s"
1521 optToStr ShowType = "t"
1522 optToStr RevertCAFs = "r"
1524 -- ---------------------------------------------------------------------------
1527 showCmd :: String -> GHCi ()
1531 ["args"] -> io $ putStrLn (show (args st))
1532 ["prog"] -> io $ putStrLn (show (progname st))
1533 ["prompt"] -> io $ putStrLn (show (prompt st))
1534 ["editor"] -> io $ putStrLn (show (editor st))
1535 ["stop"] -> io $ putStrLn (show (stop st))
1536 ["modules" ] -> showModules
1537 ["bindings"] -> showBindings
1538 ["linker"] -> io showLinkerState
1539 ["breaks"] -> showBkptTable
1540 ["context"] -> showContext
1541 ["packages"] -> showPackages
1542 ["languages"] -> showLanguages
1543 _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
1544 " | breaks | context | packages | languages ]"))
1546 showModules :: GHCi ()
1548 loaded_mods <- getLoadedModules
1549 -- we want *loaded* modules only, see #1734
1550 let show_one ms = do m <- GHC.showModule ms; io (putStrLn m)
1551 mapM_ show_one loaded_mods
1553 getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
1554 getLoadedModules = do
1555 graph <- GHC.getModuleGraph
1556 filterM (GHC.isLoaded . GHC.ms_mod_name) graph
1558 showBindings :: GHCi ()
1560 bindings <- GHC.getBindings
1561 docs <- pprTypeAndContents
1562 [ id | AnId id <- sortBy compareTyThings bindings]
1563 printForUserPartWay docs
1565 compareTyThings :: TyThing -> TyThing -> Ordering
1566 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1568 printTyThing :: TyThing -> GHCi ()
1569 printTyThing tyth = do dflags <- getDynFlags
1570 let pefas = dopt Opt_PrintExplicitForalls dflags
1571 printForUser (pprTyThing pefas tyth)
1573 showBkptTable :: GHCi ()
1576 printForUser $ prettyLocations (breaks st)
1578 showContext :: GHCi ()
1580 resumes <- GHC.getResumeContext
1581 printForUser $ vcat (map pp_resume (reverse resumes))
1584 ptext (sLit "--> ") <> text (GHC.resumeStmt resume)
1585 $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume))
1587 showPackages :: GHCi ()
1589 pkg_flags <- fmap packageFlags getDynFlags
1590 io $ putStrLn $ showSDoc $ vcat $
1591 text ("active package flags:"++if null pkg_flags then " none" else "")
1592 : map showFlag pkg_flags
1593 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1594 io $ putStrLn $ showSDoc $ vcat $
1595 text "packages currently loaded:"
1596 : map (nest 2 . text . packageIdString)
1597 (sortBy (compare `on` packageIdFS) pkg_ids)
1598 where showFlag (ExposePackage p) = text $ " -package " ++ p
1599 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1600 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1601 showFlag (ExposePackageId p) = text $ " -package-id " ++ p
1603 showLanguages :: GHCi ()
1605 dflags <- getDynFlags
1606 io $ putStrLn $ showSDoc $ vcat $
1607 text "active language flags:" :
1608 [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags]
1610 -- -----------------------------------------------------------------------------
1613 completeCmd, completeMacro, completeIdentifier, completeModule,
1614 completeHomeModule, completeSetOptions, completeShowOptions,
1615 completeHomeModuleOrFile, completeExpression
1616 :: CompletionFunc GHCi
1618 ghciCompleteWord :: CompletionFunc GHCi
1619 ghciCompleteWord line@(left,_) = case firstWord of
1620 ':':cmd | null rest -> completeCmd line
1622 completion <- lookupCompletion cmd
1624 "import" -> completeModule line
1625 _ -> completeExpression line
1627 (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
1628 lookupCompletion ('!':_) = return completeFilename
1629 lookupCompletion c = do
1630 maybe_cmd <- liftIO $ lookupCommand' c
1632 Just (_,_,f) -> return f
1633 Nothing -> return completeFilename
1635 completeCmd = wrapCompleter " " $ \w -> do
1636 macros <- liftIO $ readIORef macros_ref
1637 let macro_names = map (':':) . map cmdName $ macros
1638 let command_names = map (':':) . map cmdName $ builtin_commands
1639 let{ candidates = case w of
1640 ':' : ':' : _ -> map (':':) command_names
1641 _ -> nub $ macro_names ++ command_names }
1642 return $ filter (w `isPrefixOf`) candidates
1644 completeMacro = wrapIdentCompleter $ \w -> do
1645 cmds <- liftIO $ readIORef macros_ref
1646 return (filter (w `isPrefixOf`) (map cmdName cmds))
1648 completeIdentifier = wrapIdentCompleter $ \w -> do
1649 rdrs <- GHC.getRdrNamesInScope
1650 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1652 completeModule = wrapIdentCompleter $ \w -> do
1653 dflags <- GHC.getSessionDynFlags
1654 let pkg_mods = allExposedModules dflags
1655 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
1656 return $ filter (w `isPrefixOf`)
1657 $ map (showSDoc.ppr) $ loaded_mods ++ pkg_mods
1659 completeHomeModule = wrapIdentCompleter listHomeModules
1661 listHomeModules :: String -> GHCi [String]
1662 listHomeModules w = do
1663 g <- GHC.getModuleGraph
1664 let home_mods = map GHC.ms_mod_name g
1665 return $ sort $ filter (w `isPrefixOf`)
1666 $ map (showSDoc.ppr) home_mods
1668 completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
1669 return (filter (w `isPrefixOf`) options)
1670 where options = "args":"prog":"prompt":"editor":"stop":flagList
1671 flagList = map head $ group $ sort allFlags
1673 completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
1674 return (filter (w `isPrefixOf`) options)
1675 where options = ["args", "prog", "prompt", "editor", "stop",
1676 "modules", "bindings", "linker", "breaks",
1677 "context", "packages", "languages"]
1679 completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
1680 $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
1683 unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
1684 unionComplete f1 f2 line = do
1689 wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
1690 wrapCompleter breakChars fun = completeWord Nothing breakChars
1691 $ fmap (map simpleCompletion) . fmap sort . fun
1693 wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
1694 wrapIdentCompleter = wrapCompleter word_break_chars
1696 allExposedModules :: DynFlags -> [ModuleName]
1697 allExposedModules dflags
1698 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1700 pkg_db = pkgIdMap (pkgState dflags)
1702 completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
1705 -- ---------------------------------------------------------------------------
1706 -- User code exception handling
1708 -- This is the exception handler for exceptions generated by the
1709 -- user's code and exceptions coming from children sessions;
1710 -- it normally just prints out the exception. The
1711 -- handler must be recursive, in case showing the exception causes
1712 -- more exceptions to be raised.
1714 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1715 -- raising another exception. We therefore don't put the recursive
1716 -- handler arond the flushing operation, so if stderr is closed
1717 -- GHCi will just die gracefully rather than going into an infinite loop.
1718 handler :: SomeException -> GHCi Bool
1720 handler exception = do
1722 io installSignalHandlers
1723 ghciHandle handler (showException exception >> return False)
1725 showException :: SomeException -> GHCi ()
1727 io $ case fromException se of
1728 Just Interrupted -> putStrLn "Interrupted."
1729 -- omit the location for CmdLineError:
1730 Just (CmdLineError s) -> putStrLn s
1732 Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
1733 Just other_ghc_ex -> print other_ghc_ex
1734 Nothing -> putStrLn ("*** Exception: " ++ show se)
1736 -----------------------------------------------------------------------------
1737 -- recursive exception handlers
1739 -- Don't forget to unblock async exceptions in the handler, or if we're
1740 -- in an exception loop (eg. let a = error a in a) the ^C exception
1741 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1743 ghciHandle :: MonadException m => (SomeException -> m a) -> m a -> m a
1744 ghciHandle h m = Haskeline.catch m $ \e -> unblock (h e)
1746 ghciTry :: GHCi a -> GHCi (Either SomeException a)
1747 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
1749 -- ----------------------------------------------------------------------------
1752 -- TODO: won't work if home dir is encoded.
1753 -- (changeDirectory may not work either in that case.)
1754 expandPath :: MonadIO m => String -> InputT m String
1755 expandPath path = do
1756 exp_path <- liftIO $ expandPathIO path
1757 enc <- fmap BS.unpack $ Encoding.encode exp_path
1760 expandPathIO :: String -> IO String
1762 case dropWhile isSpace path of
1764 tilde <- getHomeDirectory -- will fail if HOME not defined
1765 return (tilde ++ '/':d)
1769 wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
1770 wantInterpretedModule str = do
1771 modl <- lookupModule str
1772 dflags <- getDynFlags
1773 when (GHC.modulePackageId modl /= thisPackage dflags) $
1774 ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
1775 is_interpreted <- GHC.moduleIsInterpreted modl
1776 when (not is_interpreted) $
1777 ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
1780 wantNameFromInterpretedModule :: GHC.GhcMonad m
1781 => (Name -> SDoc -> m ())
1785 wantNameFromInterpretedModule noCanDo str and_then =
1786 handleSourceError (GHC.printExceptionAndWarnings) $ do
1787 names <- GHC.parseName str
1791 let modl = ASSERT( isExternalName n ) GHC.nameModule n
1792 if not (GHC.isExternalName n)
1793 then noCanDo n $ ppr n <>
1794 text " is not defined in an interpreted module"
1796 is_interpreted <- GHC.moduleIsInterpreted modl
1797 if not is_interpreted
1798 then noCanDo n $ text "module " <> ppr modl <>
1799 text " is not interpreted"
1802 -- -----------------------------------------------------------------------------
1803 -- commands for debugger
1805 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1806 sprintCmd = pprintCommand False False
1807 printCmd = pprintCommand True False
1808 forceCmd = pprintCommand False True
1810 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1811 pprintCommand bind force str = do
1812 pprintClosureCommand bind force str
1814 stepCmd :: String -> GHCi ()
1815 stepCmd [] = doContinue (const True) GHC.SingleStep
1816 stepCmd expression = runStmt expression GHC.SingleStep >> return ()
1818 stepLocalCmd :: String -> GHCi ()
1819 stepLocalCmd [] = do
1820 mb_span <- getCurrentBreakSpan
1822 Nothing -> stepCmd []
1824 Just mod <- getCurrentBreakModule
1825 current_toplevel_decl <- enclosingTickSpan mod loc
1826 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1828 stepLocalCmd expression = stepCmd expression
1830 stepModuleCmd :: String -> GHCi ()
1831 stepModuleCmd [] = do
1832 mb_span <- getCurrentBreakSpan
1834 Nothing -> stepCmd []
1836 Just span <- getCurrentBreakSpan
1837 let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span
1838 doContinue f GHC.SingleStep
1840 stepModuleCmd expression = stepCmd expression
1842 -- | Returns the span of the largest tick containing the srcspan given
1843 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1844 enclosingTickSpan mod src = do
1845 ticks <- getTickArray mod
1846 let line = srcSpanStartLine src
1847 ASSERT (inRange (bounds ticks) line) do
1848 let enclosing_spans = [ span | (_,span) <- ticks ! line
1849 , srcSpanEnd span >= srcSpanEnd src]
1850 return . head . sortBy leftmost_largest $ enclosing_spans
1852 traceCmd :: String -> GHCi ()
1853 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1854 traceCmd expression = runStmt expression GHC.RunAndLogSteps >> return ()
1856 continueCmd :: String -> GHCi ()
1857 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1859 -- doContinue :: SingleStep -> GHCi ()
1860 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1861 doContinue pred step = do
1862 runResult <- resume pred step
1863 _ <- afterRunStmt pred runResult
1866 abandonCmd :: String -> GHCi ()
1867 abandonCmd = noArgs $ do
1868 b <- GHC.abandon -- the prompt will change to indicate the new context
1869 when (not b) $ io $ putStrLn "There is no computation running."
1872 deleteCmd :: String -> GHCi ()
1873 deleteCmd argLine = do
1874 deleteSwitch $ words argLine
1876 deleteSwitch :: [String] -> GHCi ()
1878 io $ putStrLn "The delete command requires at least one argument."
1879 -- delete all break points
1880 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1881 deleteSwitch idents = do
1882 mapM_ deleteOneBreak idents
1884 deleteOneBreak :: String -> GHCi ()
1886 | all isDigit str = deleteBreak (read str)
1887 | otherwise = return ()
1889 historyCmd :: String -> GHCi ()
1891 | null arg = history 20
1892 | all isDigit arg = history (read arg)
1893 | otherwise = io $ putStrLn "Syntax: :history [num]"
1896 resumes <- GHC.getResumeContext
1898 [] -> io $ putStrLn "Not stopped at a breakpoint"
1900 let hist = GHC.resumeHistory r
1901 (took,rest) = splitAt num hist
1903 [] -> io $ putStrLn $
1904 "Empty history. Perhaps you forgot to use :trace?"
1906 spans <- mapM GHC.getHistorySpan took
1907 let nums = map (printf "-%-3d:") [(1::Int)..]
1908 names = map GHC.historyEnclosingDecl took
1909 printForUser (vcat(zipWith3
1910 (\x y z -> x <+> y <+> z)
1912 (map (bold . ppr) names)
1913 (map (parens . ppr) spans)))
1914 io $ putStrLn $ if null rest then "<end of history>" else "..."
1916 bold :: SDoc -> SDoc
1917 bold c | do_bold = text start_bold <> c <> text end_bold
1920 backCmd :: String -> GHCi ()
1921 backCmd = noArgs $ do
1922 (names, _, span) <- GHC.back
1923 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span
1924 printTypeOfNames names
1925 -- run the command set with ":set stop <cmd>"
1927 enqueueCommands [stop st]
1929 forwardCmd :: String -> GHCi ()
1930 forwardCmd = noArgs $ do
1931 (names, ix, span) <- GHC.forward
1932 printForUser $ (if (ix == 0)
1933 then ptext (sLit "Stopped at")
1934 else ptext (sLit "Logged breakpoint at")) <+> ppr span
1935 printTypeOfNames names
1936 -- run the command set with ":set stop <cmd>"
1938 enqueueCommands [stop st]
1940 -- handle the "break" command
1941 breakCmd :: String -> GHCi ()
1942 breakCmd argLine = do
1943 breakSwitch $ words argLine
1945 breakSwitch :: [String] -> GHCi ()
1947 io $ putStrLn "The break command requires at least one argument."
1948 breakSwitch (arg1:rest)
1949 | looksLikeModuleName arg1 && not (null rest) = do
1950 mod <- wantInterpretedModule arg1
1951 breakByModule mod rest
1952 | all isDigit arg1 = do
1953 (toplevel, _) <- GHC.getContext
1955 (mod : _) -> breakByModuleLine mod (read arg1) rest
1957 io $ putStrLn "Cannot find default module for breakpoint."
1958 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1959 | otherwise = do -- try parsing it as an identifier
1960 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1961 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1962 if GHC.isGoodSrcLoc loc
1963 then ASSERT( isExternalName name )
1964 findBreakAndSet (GHC.nameModule name) $
1965 findBreakByCoord (Just (GHC.srcLocFile loc))
1966 (GHC.srcLocLine loc,
1968 else noCanDo name $ text "can't find its location: " <> ppr loc
1970 noCanDo n why = printForUser $
1971 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1973 breakByModule :: Module -> [String] -> GHCi ()
1974 breakByModule mod (arg1:rest)
1975 | all isDigit arg1 = do -- looks like a line number
1976 breakByModuleLine mod (read arg1) rest
1980 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1981 breakByModuleLine mod line args
1982 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1983 | [col] <- args, all isDigit col =
1984 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1985 | otherwise = breakSyntax
1988 breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1990 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1991 findBreakAndSet mod lookupTickTree = do
1992 tickArray <- getTickArray mod
1993 (breakArray, _) <- getModBreak mod
1994 case lookupTickTree tickArray of
1995 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1996 Just (tick, span) -> do
1997 success <- io $ setBreakFlag True breakArray tick
2001 recordBreak $ BreakLocation
2008 text "Breakpoint " <> ppr nm <>
2010 then text " was already set at " <> ppr span
2011 else text " activated at " <> ppr span
2013 printForUser $ text "Breakpoint could not be activated at"
2016 -- When a line number is specified, the current policy for choosing
2017 -- the best breakpoint is this:
2018 -- - the leftmost complete subexpression on the specified line, or
2019 -- - the leftmost subexpression starting on the specified line, or
2020 -- - the rightmost subexpression enclosing the specified line
2022 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2023 findBreakByLine line arr
2024 | not (inRange (bounds arr) line) = Nothing
2026 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
2027 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2028 listToMaybe (sortBy (rightmost `on` snd) ticks)
2032 starts_here = [ tick | tick@(_,span) <- ticks,
2033 GHC.srcSpanStartLine span == line ]
2035 (complete,incomplete) = partition ends_here starts_here
2036 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2038 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2039 -> Maybe (BreakIndex,SrcSpan)
2040 findBreakByCoord mb_file (line, col) arr
2041 | not (inRange (bounds arr) line) = Nothing
2043 listToMaybe (sortBy (rightmost `on` snd) contains ++
2044 sortBy (leftmost_smallest `on` snd) after_here)
2048 -- the ticks that span this coordinate
2049 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2050 is_correct_file span ]
2052 is_correct_file span
2053 | Just f <- mb_file = GHC.srcSpanFile span == f
2056 after_here = [ tick | tick@(_,span) <- ticks,
2057 GHC.srcSpanStartLine span == line,
2058 GHC.srcSpanStartCol span >= col ]
2060 -- For now, use ANSI bold on terminals that we know support it.
2061 -- Otherwise, we add a line of carets under the active expression instead.
2062 -- In particular, on Windows and when running the testsuite (which sets
2063 -- TERM to vt100 for other reasons) we get carets.
2064 -- We really ought to use a proper termcap/terminfo library.
2066 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2067 where mTerm = System.Environment.getEnv "TERM"
2068 `catchIO` \_ -> return "TERM not set"
2070 start_bold :: String
2071 start_bold = "\ESC[1m"
2073 end_bold = "\ESC[0m"
2075 listCmd :: String -> InputT GHCi ()
2077 mb_span <- lift getCurrentBreakSpan
2080 printForUser' $ text "Not stopped at a breakpoint; nothing to list"
2082 | GHC.isGoodSrcSpan span -> listAround span True
2084 do resumes <- GHC.getResumeContext
2086 [] -> panic "No resumes"
2088 do let traceIt = case GHC.resumeHistory r of
2089 [] -> text "rerunning with :trace,"
2091 doWhat = traceIt <+> text ":back then :list"
2092 printForUser' (text "Unable to list source for" <+>
2094 $$ text "Try" <+> doWhat)
2095 listCmd str = list2 (words str)
2097 list2 :: [String] -> InputT GHCi ()
2098 list2 [arg] | all isDigit arg = do
2099 (toplevel, _) <- GHC.getContext
2101 [] -> outputStrLn "No module to list"
2102 (mod : _) -> listModuleLine mod (read arg)
2103 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2104 mod <- wantInterpretedModule arg1
2105 listModuleLine mod (read arg2)
2107 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2108 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2109 if GHC.isGoodSrcLoc loc
2111 tickArray <- ASSERT( isExternalName name )
2112 lift $ getTickArray (GHC.nameModule name)
2113 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2114 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2117 Nothing -> listAround (GHC.srcLocSpan loc) False
2118 Just (_,span) -> listAround span False
2120 noCanDo name $ text "can't find its location: " <>
2123 noCanDo n why = printForUser' $
2124 text "cannot list source code for " <> ppr n <> text ": " <> why
2126 outputStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2128 listModuleLine :: Module -> Int -> InputT GHCi ()
2129 listModuleLine modl line = do
2130 graph <- GHC.getModuleGraph
2131 let this = filter ((== modl) . GHC.ms_mod) graph
2133 [] -> panic "listModuleLine"
2135 let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
2136 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2137 listAround (GHC.srcLocSpan loc) False
2139 -- | list a section of a source file around a particular SrcSpan.
2140 -- If the highlight flag is True, also highlight the span using
2141 -- start_bold\/end_bold.
2143 -- GHC files are UTF-8, so we can implement this by:
2144 -- 1) read the file in as a BS and syntax highlight it as before
2145 -- 2) convert the BS to String using utf-string, and write it out.
2146 -- It would be better if we could convert directly between UTF-8 and the
2147 -- console encoding, of course.
2148 listAround :: MonadIO m => SrcSpan -> Bool -> InputT m ()
2149 listAround span do_highlight = do
2150 contents <- liftIO $ BS.readFile (unpackFS file)
2152 lines = BS.split '\n' contents
2153 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2154 drop (line1 - 1 - pad_before) $ lines
2155 fst_line = max 1 (line1 - pad_before)
2156 line_nos = [ fst_line .. ]
2158 highlighted | do_highlight = zipWith highlight line_nos these_lines
2159 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2161 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2162 prefixed = zipWith ($) highlighted bs_line_nos
2164 let output = BS.intercalate (BS.pack "\n") prefixed
2165 utf8Decoded <- liftIO $ BS.useAsCStringLen output
2166 $ \(p,n) -> utf8DecodeString (castPtr p) n
2167 outputStrLn utf8Decoded
2169 file = GHC.srcSpanFile span
2170 line1 = GHC.srcSpanStartLine span
2171 col1 = GHC.srcSpanStartCol span
2172 line2 = GHC.srcSpanEndLine span
2173 col2 = GHC.srcSpanEndCol span
2175 pad_before | line1 == 1 = 0
2179 highlight | do_bold = highlight_bold
2180 | otherwise = highlight_carets
2182 highlight_bold no line prefix
2183 | no == line1 && no == line2
2184 = let (a,r) = BS.splitAt col1 line
2185 (b,c) = BS.splitAt (col2-col1) r
2187 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2189 = let (a,b) = BS.splitAt col1 line in
2190 BS.concat [prefix, a, BS.pack start_bold, b]
2192 = let (a,b) = BS.splitAt col2 line in
2193 BS.concat [prefix, a, BS.pack end_bold, b]
2194 | otherwise = BS.concat [prefix, line]
2196 highlight_carets no line prefix
2197 | no == line1 && no == line2
2198 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2199 BS.replicate (col2-col1) '^']
2201 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2204 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2206 | otherwise = BS.concat [prefix, line]
2208 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2209 nl = BS.singleton '\n'
2211 -- --------------------------------------------------------------------------
2214 getTickArray :: Module -> GHCi TickArray
2215 getTickArray modl = do
2217 let arrmap = tickarrays st
2218 case lookupModuleEnv arrmap modl of
2219 Just arr -> return arr
2221 (_breakArray, ticks) <- getModBreak modl
2222 let arr = mkTickArray (assocs ticks)
2223 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2226 discardTickArrays :: GHCi ()
2227 discardTickArrays = do
2229 setGHCiState st{tickarrays = emptyModuleEnv}
2231 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2233 = accumArray (flip (:)) [] (1, max_line)
2234 [ (line, (nm,span)) | (nm,span) <- ticks,
2235 line <- srcSpanLines span ]
2237 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2238 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2239 GHC.srcSpanEndLine span ]
2241 lookupModule :: GHC.GhcMonad m => String -> m Module
2242 lookupModule modName
2243 = GHC.lookupModule (GHC.mkModuleName modName) Nothing
2245 -- don't reset the counter back to zero?
2246 discardActiveBreakPoints :: GHCi ()
2247 discardActiveBreakPoints = do
2249 mapM_ (turnOffBreak.snd) (breaks st)
2250 setGHCiState $ st { breaks = [] }
2252 deleteBreak :: Int -> GHCi ()
2253 deleteBreak identity = do
2255 let oldLocations = breaks st
2256 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2258 then printForUser (text "Breakpoint" <+> ppr identity <+>
2259 text "does not exist")
2261 mapM_ (turnOffBreak.snd) this
2262 setGHCiState $ st { breaks = rest }
2264 turnOffBreak :: BreakLocation -> GHCi Bool
2265 turnOffBreak loc = do
2266 (arr, _) <- getModBreak (breakModule loc)
2267 io $ setBreakFlag False arr (breakTick loc)
2269 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2270 getModBreak mod = do
2271 Just mod_info <- GHC.getModuleInfo mod
2272 let modBreaks = GHC.modInfoModBreaks mod_info
2273 let array = GHC.modBreaks_flags modBreaks
2274 let ticks = GHC.modBreaks_locs modBreaks
2275 return (array, ticks)
2277 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2278 setBreakFlag toggle array index
2279 | toggle = GHC.setBreakOn array index
2280 | otherwise = GHC.setBreakOff array index