1 {-# OPTIONS -fno-cse #-}
2 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
4 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
5 -----------------------------------------------------------------------------
7 -- GHC Interactive User Interface
9 -- (c) The GHC Team 2005-2006
11 -----------------------------------------------------------------------------
13 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
15 #include "HsVersions.h"
17 import qualified GhciMonad
18 import GhciMonad hiding (runStmt)
23 import qualified GHC hiding (resume, runStmt)
24 import GHC ( LoadHowMuch(..), Target(..), TargetId(..),
26 BreakIndex, Resume, SingleStep,
27 Ghc, handleSourceError )
32 -- import PackageConfig
35 import HscTypes ( handleFlagWarnings )
37 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
38 import RdrName (RdrName)
39 import Outputable hiding (printForUser, printForUserPartWay)
40 import Module -- for ModuleEnv
44 -- Other random utilities
47 import BasicTypes hiding (isTopLevel)
48 import Panic hiding (showException)
54 import Maybes ( orElse, expectJust )
59 #ifndef mingw32_HOST_OS
60 import System.Posix hiding (getEnv)
62 import qualified System.Win32
65 import System.Console.Haskeline as Haskeline
66 import qualified System.Console.Haskeline.Encoding as Encoding
67 import Control.Monad.Trans
71 import Exception hiding (catch, block, unblock)
73 -- import Control.Concurrent
75 import System.FilePath
76 import qualified Data.ByteString.Char8 as BS
80 import System.Environment
81 import System.Exit ( exitWith, ExitCode(..) )
82 import System.Directory
84 import System.IO.Error as IO
87 import Control.Monad as Monad
90 import GHC.Exts ( unsafeCoerce# )
92 #if __GLASGOW_HASKELL__ >= 611
93 import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
94 import GHC.IO.Handle ( hFlushAll )
96 import GHC.IOBase ( IOErrorType(InvalidArgument) )
101 import Data.IORef ( IORef, readIORef, writeIORef )
103 -----------------------------------------------------------------------------
105 ghciWelcomeMsg :: String
106 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
107 ": http://www.haskell.org/ghc/ :? for help"
109 cmdName :: Command -> String
112 GLOBAL_VAR(macros_ref, [], [Command])
114 builtin_commands :: [Command]
116 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
117 ("?", keepGoing help, noCompletion),
118 ("add", keepGoingPaths addModule, completeFilename),
119 ("abandon", keepGoing abandonCmd, noCompletion),
120 ("break", keepGoing breakCmd, completeIdentifier),
121 ("back", keepGoing backCmd, noCompletion),
122 ("browse", keepGoing' (browseCmd False), completeModule),
123 ("browse!", keepGoing' (browseCmd True), completeModule),
124 ("cd", keepGoing' changeDirectory, completeFilename),
125 ("check", keepGoing' checkModule, completeHomeModule),
126 ("continue", keepGoing continueCmd, noCompletion),
127 ("cmd", keepGoing cmdCmd, completeExpression),
128 ("ctags", keepGoing createCTagsWithLineNumbersCmd, completeFilename),
129 ("ctags!", keepGoing createCTagsWithRegExesCmd, completeFilename),
130 ("def", keepGoing (defineMacro False), completeExpression),
131 ("def!", keepGoing (defineMacro True), completeExpression),
132 ("delete", keepGoing deleteCmd, noCompletion),
133 ("edit", keepGoing editFile, completeFilename),
134 ("etags", keepGoing createETagsFileCmd, completeFilename),
135 ("force", keepGoing forceCmd, completeExpression),
136 ("forward", keepGoing forwardCmd, noCompletion),
137 ("help", keepGoing help, noCompletion),
138 ("history", keepGoing historyCmd, noCompletion),
139 ("info", keepGoing' info, completeIdentifier),
140 ("kind", keepGoing' kindOfType, completeIdentifier),
141 ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),
142 ("list", keepGoing' listCmd, noCompletion),
143 ("module", keepGoing setContext, completeModule),
144 ("main", keepGoing runMain, completeFilename),
145 ("print", keepGoing printCmd, completeExpression),
146 ("quit", quit, noCompletion),
147 ("reload", keepGoing' reloadModule, noCompletion),
148 ("run", keepGoing runRun, completeFilename),
149 ("set", keepGoing setCmd, completeSetOptions),
150 ("show", keepGoing showCmd, completeShowOptions),
151 ("sprint", keepGoing sprintCmd, completeExpression),
152 ("step", keepGoing stepCmd, completeIdentifier),
153 ("steplocal", keepGoing stepLocalCmd, completeIdentifier),
154 ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),
155 ("type", keepGoing' typeOfExpr, completeExpression),
156 ("trace", keepGoing traceCmd, completeExpression),
157 ("undef", keepGoing undefineMacro, completeMacro),
158 ("unset", keepGoing unsetOptions, completeSetOptions)
162 -- We initialize readline (in the interactiveUI function) to use
163 -- word_break_chars as the default set of completion word break characters.
164 -- This can be overridden for a particular command (for example, filename
165 -- expansion shouldn't consider '/' to be a word break) by setting the third
166 -- entry in the Command tuple above.
168 -- NOTE: in order for us to override the default correctly, any custom entry
169 -- must be a SUBSET of word_break_chars.
170 word_break_chars :: String
171 word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
172 specials = "(),;[]`{}"
174 in spaces ++ specials ++ symbols
176 flagWordBreakChars :: String
177 flagWordBreakChars = " \t\n"
180 keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)
181 keepGoing a str = keepGoing' (lift . a) str
183 keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool
184 keepGoing' a str = a str >> return False
186 keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
188 = do case toArgs str of
189 Left err -> Encoding.encode err >>= liftIO . BS.hPutStrLn stderr
193 shortHelpText :: String
194 shortHelpText = "use :? for help.\n"
198 " Commands available from the prompt:\n" ++
200 " <statement> evaluate/run <statement>\n" ++
201 " : repeat last command\n" ++
202 " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
203 " :add [*]<module> ... add module(s) to the current target set\n" ++
204 " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
205 " (!: more details; *: all top-level names)\n" ++
206 " :cd <dir> change directory to <dir>\n" ++
207 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
208 " :ctags[!] [<file>] create tags file for Vi (default: \"tags\")\n" ++
209 " (!: use regex instead of line number)\n" ++
210 " :def <cmd> <expr> define a command :<cmd>\n" ++
211 " :edit <file> edit file\n" ++
212 " :edit edit last module\n" ++
213 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
214 " :help, :? display this list of commands\n" ++
215 " :info [<name> ...] display information about the given names\n" ++
216 " :kind <type> show the kind of <type>\n" ++
217 " :load [*]<module> ... load module(s) and their dependents\n" ++
218 " :main [<arguments> ...] run the main function with the given arguments\n" ++
219 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
220 " :quit exit GHCi\n" ++
221 " :reload reload the current module set\n" ++
222 " :run function [<arguments> ...] run the function with the given arguments\n" ++
223 " :type <expr> show the type of <expr>\n" ++
224 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
225 " :!<command> run the shell command <command>\n" ++
227 " -- Commands for debugging:\n" ++
229 " :abandon at a breakpoint, abandon current computation\n" ++
230 " :back go back in the history (after :trace)\n" ++
231 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
232 " :break <name> set a breakpoint on the specified function\n" ++
233 " :continue resume after a breakpoint\n" ++
234 " :delete <number> delete the specified breakpoint\n" ++
235 " :delete * delete all breakpoints\n" ++
236 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
237 " :forward go forward in the history (after :back)\n" ++
238 " :history [<n>] after :trace, show the execution history\n" ++
239 " :list show the source code around current breakpoint\n" ++
240 " :list identifier show the source code for <identifier>\n" ++
241 " :list [<module>] <line> show the source code around line number <line>\n" ++
242 " :print [<name> ...] prints a value without forcing its computation\n" ++
243 " :sprint [<name> ...] simplifed version of :print\n" ++
244 " :step single-step after stopping at a breakpoint\n"++
245 " :step <expr> single-step into <expr>\n"++
246 " :steplocal single-step within the current top-level binding\n"++
247 " :stepmodule single-step restricted to the current module\n"++
248 " :trace trace after stopping at a breakpoint\n"++
249 " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++
252 " -- Commands for changing settings:\n" ++
254 " :set <option> ... set options\n" ++
255 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
256 " :set prog <progname> set the value returned by System.getProgName\n" ++
257 " :set prompt <prompt> set the prompt used in GHCi\n" ++
258 " :set editor <cmd> set the command used for :edit\n" ++
259 " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" ++
260 " :unset <option> ... unset options\n" ++
262 " Options for ':set' and ':unset':\n" ++
264 " +r revert top-level expressions after each evaluation\n" ++
265 " +s print timing/memory stats after each evaluation\n" ++
266 " +t print type after evaluation\n" ++
267 " -<flags> most GHC command line flags can also be set here\n" ++
268 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
269 " for GHCi-specific flags, see User's Guide,\n"++
270 " Flag reference, Interactive-mode options\n" ++
272 " -- Commands for displaying information:\n" ++
274 " :show bindings show the current bindings made at the prompt\n" ++
275 " :show breaks show the active breakpoints\n" ++
276 " :show context show the breakpoint context\n" ++
277 " :show modules show the currently loaded modules\n" ++
278 " :show packages show the currently active package flags\n" ++
279 " :show languages show the currently active language flags\n" ++
280 " :show <setting> show value of <setting>, which is one of\n" ++
281 " [args, prog, prompt, editor, stop]\n" ++
284 findEditor :: IO String
289 win <- System.Win32.getWindowsDirectory
290 return (win </> "notepad.exe")
295 foreign import ccall unsafe "rts_isProfiled" isProfiled :: IO CInt
297 interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String]
299 interactiveUI srcs maybe_exprs = do
300 -- although GHCi compiles with -prof, it is not usable: the byte-code
301 -- compiler and interpreter don't work with profiling. So we check for
302 -- this up front and emit a helpful error message (#2197)
303 i <- liftIO $ isProfiled
305 ghcError (InstallationError "GHCi cannot be used when compiled with -prof")
307 -- HACK! If we happen to get into an infinite loop (eg the user
308 -- types 'let x=x in x' at the prompt), then the thread will block
309 -- on a blackhole, and become unreachable during GC. The GC will
310 -- detect that it is unreachable and send it the NonTermination
311 -- exception. However, since the thread is unreachable, everything
312 -- it refers to might be finalized, including the standard Handles.
313 -- This sounds like a bug, but we don't have a good solution right
315 _ <- liftIO $ newStablePtr stdin
316 _ <- liftIO $ newStablePtr stdout
317 _ <- liftIO $ newStablePtr stderr
319 -- Initialise buffering for the *interpreted* I/O system
322 liftIO $ when (isNothing maybe_exprs) $ do
323 -- Only for GHCi (not runghc and ghc -e):
325 -- Turn buffering off for the compiled program's stdout/stderr
327 -- Turn buffering off for GHCi's stdout
329 hSetBuffering stdout NoBuffering
330 -- We don't want the cmd line to buffer any input that might be
331 -- intended for the program, so unbuffer stdin.
332 hSetBuffering stdin NoBuffering
333 #if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611
334 -- On Unix, stdin will use the locale encoding. The IO library
335 -- doesn't do this on Windows (yet), so for now we use UTF-8,
336 -- for consistency with GHC 6.10 and to make the tests work.
337 hSetEncoding stdin utf8
340 -- initial context is just the Prelude
341 prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing
342 GHC.setContext [] [(prel_mod, Nothing)]
344 default_editor <- liftIO $ findEditor
346 startGHCi (runGHCi srcs maybe_exprs)
347 GHCiState{ progname = "<interactive>",
351 editor = default_editor,
352 -- session = session,
357 tickarrays = emptyModuleEnv,
358 last_command = Nothing,
361 ghc_e = isJust maybe_exprs
366 withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
367 withGhcAppData right left = do
368 either_dir <- IO.try (getAppUserDataDirectory "ghc")
370 Right dir -> right dir
373 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
374 runGHCi paths maybe_exprs = do
376 read_dot_files = not opt_IgnoreDotGhci
378 current_dir = return (Just ".ghci")
380 app_user_dir = io $ withGhcAppData
381 (\dir -> return (Just (dir </> "ghci.conf")))
385 either_dir <- io $ IO.try (getEnv "HOME")
387 Right home -> return (Just (home </> ".ghci"))
390 canonicalizePath' :: FilePath -> IO (Maybe FilePath)
391 canonicalizePath' fp = liftM Just (canonicalizePath fp)
392 `catchIO` \_ -> return Nothing
394 sourceConfigFile :: FilePath -> GHCi ()
395 sourceConfigFile file = do
396 exists <- io $ doesFileExist file
398 dir_ok <- io $ checkPerms (getDirectory file)
399 file_ok <- io $ checkPerms file
400 when (dir_ok && file_ok) $ do
401 either_hdl <- io $ IO.try (openFile file ReadMode)
404 -- NOTE: this assumes that runInputT won't affect the terminal;
405 -- can we assume this will always be the case?
406 -- This would be a good place for runFileInputT.
407 Right hdl -> runInputTWithPrefs defaultPrefs defaultSettings $ do
408 runCommands $ fileLoop hdl
410 getDirectory f = case takeDirectory f of "" -> "."; d -> d
412 when (read_dot_files) $ do
413 mcfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
414 mcfgs <- io $ mapM canonicalizePath' (catMaybes mcfgs0)
415 mapM_ sourceConfigFile $ nub $ catMaybes mcfgs
416 -- nub, because we don't want to read .ghci twice if the
419 -- Perform a :load for files given on the GHCi command line
420 -- When in -e mode, if the load fails then we want to stop
421 -- immediately rather than going on to evaluate the expression.
422 when (not (null paths)) $ do
423 ok <- ghciHandle (\e -> do showException e; return Failed) $
424 -- TODO: this is a hack.
425 runInputTWithPrefs defaultPrefs defaultSettings $ do
426 let (filePaths, phases) = unzip paths
427 filePaths' <- mapM (Encoding.decode . BS.pack) filePaths
428 loadModule (zip filePaths' phases)
429 when (isJust maybe_exprs && failed ok) $
430 io (exitWith (ExitFailure 1))
432 -- if verbosity is greater than 0, or we are connected to a
433 -- terminal, display the prompt in the interactive loop.
434 is_tty <- io (hIsTerminalDevice stdin)
435 dflags <- getDynFlags
436 let show_prompt = verbosity dflags > 0 || is_tty
441 -- enter the interactive loop
442 runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
444 -- just evaluate the expression we were given
445 enqueueCommands exprs
446 let handle e = do st <- getGHCiState
447 -- flush the interpreter's stdout/stderr on exit (#3890)
449 -- Jump through some hoops to get the
450 -- current progname in the exception text:
451 -- <progname>: <exception>
452 io $ withProgName (progname st)
453 -- this used to be topHandlerFastExit, see #2228
455 runInputTWithPrefs defaultPrefs defaultSettings $ do
456 runCommands' handle (return Nothing)
459 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
461 runGHCiInput :: InputT GHCi a -> GHCi a
463 histFile <- io $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
465 let settings = setComplete ghciCompleteWord
466 $ defaultSettings {historyFile = histFile}
469 nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
470 nextInputLine show_prompt is_tty
472 prompt <- if show_prompt then lift mkPrompt else return ""
475 when show_prompt $ lift mkPrompt >>= liftIO . putStr
478 -- NOTE: We only read .ghci files if they are owned by the current user,
479 -- and aren't world writable. Otherwise, we could be accidentally
480 -- running code planted by a malicious third party.
482 -- Furthermore, We only read ./.ghci if . is owned by the current user
483 -- and isn't writable by anyone else. I think this is sufficient: we
484 -- don't need to check .. and ../.. etc. because "." always refers to
485 -- the same directory while a process is running.
487 checkPerms :: String -> IO Bool
488 #ifdef mingw32_HOST_OS
493 handleIO (\_ -> return False) $ do
494 st <- getFileStatus name
496 if fileOwner st /= me then do
497 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
500 let mode = fileMode st
501 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
502 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
504 putStrLn $ "*** WARNING: " ++ name ++
505 " is writable by someone else, IGNORING!"
510 fileLoop :: MonadIO m => Handle -> InputT m (Maybe String)
512 l <- liftIO $ IO.try $ hGetLine hdl
514 Left e | isEOFError e -> return Nothing
515 | InvalidArgument <- etype -> return Nothing
516 | otherwise -> liftIO $ ioError e
517 where etype = ioeGetErrorType e
518 -- treat InvalidArgument in the same way as EOF:
519 -- this can happen if the user closed stdin, or
520 -- perhaps did getContents which closes stdin at
522 Right l -> return (Just l)
524 mkPrompt :: GHCi String
526 (toplevs,exports) <- GHC.getContext
527 resumes <- GHC.getResumeContext
528 -- st <- getGHCiState
534 let ix = GHC.resumeHistoryIx r
536 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
538 let hist = GHC.resumeHistory r !! (ix-1)
539 span <- GHC.getHistorySpan hist
540 return (brackets (ppr (negate ix) <> char ':'
541 <+> ppr span) <> space)
543 dots | _:rs <- resumes, not (null rs) = text "... "
548 -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
549 -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
550 -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
551 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
552 hsep (map (ppr . GHC.moduleName) (nub (map fst exports)))
554 deflt_prompt = dots <> context_bit <> modules_bit
556 f ('%':'s':xs) = deflt_prompt <> f xs
557 f ('%':'%':xs) = char '%' <> f xs
558 f (x:xs) = char x <> f xs
562 return (showSDoc (f (prompt st)))
565 queryQueue :: GHCi (Maybe String)
570 c:cs -> do setGHCiState st{ cmdqueue = cs }
573 runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
574 runCommands = runCommands' handler
576 runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
577 -> InputT GHCi (Maybe String) -> InputT GHCi ()
578 runCommands' eh getCmd = do
579 b <- ghandle (\e -> case fromException e of
580 Just UserInterrupt -> return False
581 _ -> case fromException e of
583 do liftIO (print (ghc_e :: GhcException))
586 liftIO (Exception.throwIO e))
587 (runOneCommand eh getCmd)
588 if b then return () else runCommands' eh getCmd
590 runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
592 runOneCommand eh getCmd = do
593 mb_cmd <- noSpace (lift queryQueue)
594 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
596 Nothing -> return True
597 Just c -> ghciHandle (lift . eh) $
598 handleSourceError printErrorAndKeepGoing
601 printErrorAndKeepGoing err = do
602 GHC.printExceptionAndWarnings err
605 noSpace q = q >>= maybe (return Nothing)
606 (\c->case removeSpaces c of
608 ":{" -> multiLineCmd q
609 c -> return (Just c) )
611 st <- lift getGHCiState
613 lift $ setGHCiState st{ prompt = "%s| " }
614 mb_cmd <- collectCommand q ""
615 lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p }
617 -- we can't use removeSpaces for the sublines here, so
618 -- multiline commands are somewhat more brittle against
619 -- fileformat errors (such as \r in dos input on unix),
620 -- we get rid of any extra spaces for the ":}" test;
621 -- we also avoid silent failure if ":}" is not found;
622 -- and since there is no (?) valid occurrence of \r (as
623 -- opposed to its String representation, "\r") inside a
624 -- ghci command, we replace any such with ' ' (argh:-(
625 collectCommand q c = q >>=
626 maybe (liftIO (ioError collectError))
627 (\l->if removeSpaces l == ":}"
628 then return (Just $ removeSpaces c)
629 else collectCommand q (c ++ "\n" ++ map normSpace l))
630 where normSpace '\r' = ' '
632 -- QUESTION: is userError the one to use here?
633 collectError = userError "unterminated multiline command :{ .. :}"
634 doCommand (':' : cmd) = specialCommand cmd
635 doCommand stmt = do _ <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion
638 enqueueCommands :: [String] -> GHCi ()
639 enqueueCommands cmds = do
641 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
644 runStmt :: String -> SingleStep -> GHCi Bool
646 | null (filter (not.isSpace) stmt) = return False
647 | x@('i':'m':'p':'o':'r':'t':' ':_) <- stmt = keepGoing' (importContext True) x
650 #if __GLASGOW_HASKELL__ >= 611
651 -- In the new IO library, read handles buffer data even if the Handle
652 -- is set to NoBuffering. This causes problems for GHCi where there
653 -- are really two stdin Handles. So we flush any bufferred data in
654 -- GHCi's stdin Handle here (only relevant if stdin is attached to
655 -- a file, otherwise the read buffer can't be flushed).
656 _ <- liftIO $ IO.try $ hFlushAll stdin
658 result <- GhciMonad.runStmt stmt step
659 afterRunStmt (const True) result
661 --afterRunStmt :: GHC.RunResult -> GHCi Bool
662 -- False <=> the statement failed to compile
663 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
664 afterRunStmt _ (GHC.RunException e) = throw e
665 afterRunStmt step_here run_result = do
666 resumes <- GHC.getResumeContext
668 GHC.RunOk names -> do
669 show_types <- isOptionSet ShowType
670 when show_types $ printTypeOfNames names
671 GHC.RunBreak _ names mb_info
672 | isNothing mb_info ||
673 step_here (GHC.resumeSpan $ head resumes) -> do
674 mb_id_loc <- toBreakIdAndLocation mb_info
675 let breakCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
677 then printStoppedAtBreakInfo (head resumes) names
678 else enqueueCommands [breakCmd]
679 -- run the command set with ":set stop <cmd>"
681 enqueueCommands [stop st]
683 | otherwise -> resume step_here GHC.SingleStep >>=
684 afterRunStmt step_here >> return ()
688 io installSignalHandlers
689 b <- isOptionSet RevertCAFs
692 return (case run_result of GHC.RunOk _ -> True; _ -> False)
694 toBreakIdAndLocation ::
695 Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
696 toBreakIdAndLocation Nothing = return Nothing
697 toBreakIdAndLocation (Just info) = do
698 let mod = GHC.breakInfo_module info
699 nm = GHC.breakInfo_number info
701 return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
702 breakModule loc == mod,
703 breakTick loc == nm ]
705 printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
706 printStoppedAtBreakInfo resume names = do
707 printForUser $ ptext (sLit "Stopped at") <+>
708 ppr (GHC.resumeSpan resume)
709 -- printTypeOfNames session names
710 let namesSorted = sortBy compareNames names
711 tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
712 docs <- pprTypeAndContents [id | AnId id <- tythings]
713 printForUserPartWay docs
715 printTypeOfNames :: [Name] -> GHCi ()
716 printTypeOfNames names
717 = mapM_ (printTypeOfName ) $ sortBy compareNames names
719 compareNames :: Name -> Name -> Ordering
720 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
721 where compareWith n = (getOccString n, getSrcSpan n)
723 printTypeOfName :: Name -> GHCi ()
725 = do maybe_tything <- GHC.lookupName n
726 case maybe_tything of
728 Just thing -> printTyThing thing
731 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
733 specialCommand :: String -> InputT GHCi Bool
734 specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
735 specialCommand str = do
736 let (cmd,rest) = break isSpace str
737 maybe_cmd <- lift $ lookupCommand cmd
739 GotCommand (_,f,_) -> f (dropWhile isSpace rest)
741 do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
745 do liftIO $ hPutStr stdout ("there is no last command to perform\n"
749 lookupCommand :: String -> GHCi (MaybeCommand)
750 lookupCommand "" = do
752 case last_command st of
753 Just c -> return $ GotCommand c
754 Nothing -> return NoLastCommand
755 lookupCommand str = do
756 mc <- io $ lookupCommand' str
758 setGHCiState st{ last_command = mc }
760 Just c -> GotCommand c
761 Nothing -> BadCommand
763 lookupCommand' :: String -> IO (Maybe Command)
764 lookupCommand' ":" = return Nothing
765 lookupCommand' str' = do
766 macros <- readIORef macros_ref
767 let{ (str, cmds) = case str' of
768 ':' : rest -> (rest, builtin_commands)
769 _ -> (str', macros ++ builtin_commands) }
770 -- look for exact match first, then the first prefix match
771 return $ case [ c | c <- cmds, str == cmdName c ] of
773 [] -> case [ c | c@(s,_,_) <- cmds, str `isPrefixOf` s ] of
777 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
778 getCurrentBreakSpan = do
779 resumes <- GHC.getResumeContext
783 let ix = GHC.resumeHistoryIx r
785 then return (Just (GHC.resumeSpan r))
787 let hist = GHC.resumeHistory r !! (ix-1)
788 span <- GHC.getHistorySpan hist
791 getCurrentBreakModule :: GHCi (Maybe Module)
792 getCurrentBreakModule = do
793 resumes <- GHC.getResumeContext
797 let ix = GHC.resumeHistoryIx r
799 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
801 let hist = GHC.resumeHistory r !! (ix-1)
802 return $ Just $ GHC.getHistoryModule hist
804 -----------------------------------------------------------------------------
807 noArgs :: GHCi () -> String -> GHCi ()
809 noArgs _ _ = io $ putStrLn "This command takes no arguments"
811 help :: String -> GHCi ()
812 help _ = io (putStr helpText)
814 info :: String -> InputT GHCi ()
815 info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
816 info s = handleSourceError GHC.printExceptionAndWarnings $ do
817 { let names = words s
818 ; dflags <- getDynFlags
819 ; let pefas = dopt Opt_PrintExplicitForalls dflags
820 ; mapM_ (infoThing pefas) names }
822 infoThing pefas str = do
823 names <- GHC.parseName str
824 mb_stuffs <- mapM GHC.getInfo names
825 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
826 unqual <- GHC.getPrintUnqual
827 outputStrLn $ showSDocForUser unqual $
828 vcat (intersperse (text "") $
829 map (pprInfo pefas) filtered)
831 -- Filter out names whose parent is also there Good
832 -- example is '[]', which is both a type and data
833 -- constructor in the same type
834 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
835 filterOutChildren get_thing xs
836 = filterOut has_parent xs
838 all_names = mkNameSet (map (getName . get_thing) xs)
839 has_parent x = case pprTyThingParent_maybe (get_thing x) of
840 Just p -> getName p `elemNameSet` all_names
843 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
844 pprInfo pefas (thing, fixity, insts)
845 = pprTyThingInContextLoc pefas thing
846 $$ show_fixity fixity
847 $$ vcat (map GHC.pprInstance insts)
850 | fix == GHC.defaultFixity = empty
851 | otherwise = ppr fix <+> ppr (GHC.getName thing)
853 runMain :: String -> GHCi ()
854 runMain s = case toArgs s of
855 Left err -> io (hPutStrLn stderr err)
857 do dflags <- getDynFlags
858 case mainFunIs dflags of
859 Nothing -> doWithArgs args "main"
860 Just f -> doWithArgs args f
862 runRun :: String -> GHCi ()
863 runRun s = case toCmdArgs s of
864 Left err -> io (hPutStrLn stderr err)
865 Right (cmd, args) -> doWithArgs args cmd
867 doWithArgs :: [String] -> String -> GHCi ()
868 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
869 show args ++ " (" ++ cmd ++ ")"]
871 addModule :: [FilePath] -> InputT GHCi ()
873 lift revertCAFs -- always revert CAFs on load/add.
874 files <- mapM expandPath files
875 targets <- mapM (\m -> GHC.guessTarget m Nothing) files
876 -- remove old targets with the same id; e.g. for :add *M
877 mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
878 mapM_ GHC.addTarget targets
879 prev_context <- GHC.getContext
880 ok <- trySuccess $ GHC.load LoadAllTargets
881 afterLoad ok False prev_context
883 changeDirectory :: String -> InputT GHCi ()
884 changeDirectory "" = do
885 -- :cd on its own changes to the user's home directory
886 either_dir <- liftIO $ IO.try getHomeDirectory
889 Right dir -> changeDirectory dir
890 changeDirectory dir = do
891 graph <- GHC.getModuleGraph
892 when (not (null graph)) $
893 outputStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
894 prev_context <- GHC.getContext
896 _ <- GHC.load LoadAllTargets
897 lift $ setContextAfterLoad prev_context False []
898 GHC.workingDirectoryChanged
899 dir <- expandPath dir
900 liftIO $ setCurrentDirectory dir
902 trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
904 handleSourceError (\e -> do GHC.printExceptionAndWarnings e
908 editFile :: String -> GHCi ()
910 do file <- if null str then chooseEditFile else return str
914 $ ghcError (CmdLineError "editor not set, use :set editor")
915 _ <- io $ system (cmd ++ ' ':file)
918 -- The user didn't specify a file so we pick one for them.
919 -- Our strategy is to pick the first module that failed to load,
920 -- or otherwise the first target.
922 -- XXX: Can we figure out what happened if the depndecy analysis fails
923 -- (e.g., because the porgrammeer mistyped the name of a module)?
924 -- XXX: Can we figure out the location of an error to pass to the editor?
925 -- XXX: if we could figure out the list of errors that occured during the
926 -- last load/reaload, then we could start the editor focused on the first
928 chooseEditFile :: GHCi String
930 do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
932 graph <- GHC.getModuleGraph
933 failed_graph <- filterM hasFailed graph
934 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
936 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
939 case pick (order failed_graph) of
940 Just file -> return file
942 do targets <- GHC.getTargets
943 case msum (map fromTarget targets) of
944 Just file -> return file
945 Nothing -> ghcError (CmdLineError "No files to edit.")
947 where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
948 fromTarget _ = Nothing -- when would we get a module target?
950 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
951 defineMacro _ (':':_) =
952 io $ putStrLn "macro name cannot start with a colon"
953 defineMacro overwrite s = do
954 let (macro_name, definition) = break isSpace s
955 macros <- io (readIORef macros_ref)
956 let defined = map cmdName macros
959 then io $ putStrLn "no macros defined"
960 else io $ putStr ("the following macros are defined:\n" ++
963 if (not overwrite && macro_name `elem` defined)
964 then ghcError (CmdLineError
965 ("macro '" ++ macro_name ++ "' is already defined"))
968 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
970 -- give the expression a type signature, so we can be sure we're getting
971 -- something of the right type.
972 let new_expr = '(' : definition ++ ") :: String -> IO String"
974 -- compile the expression
975 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
976 hv <- GHC.compileExpr new_expr
977 io (writeIORef macros_ref --
978 (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)]))
980 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
982 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
983 -- make sure we force any exceptions in the result, while we are still
984 -- inside the exception handler for commands:
985 seqList str (return ())
986 enqueueCommands (lines str)
989 undefineMacro :: String -> GHCi ()
990 undefineMacro str = mapM_ undef (words str)
991 where undef macro_name = do
992 cmds <- io (readIORef macros_ref)
993 if (macro_name `notElem` map cmdName cmds)
994 then ghcError (CmdLineError
995 ("macro '" ++ macro_name ++ "' is not defined"))
997 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
999 cmdCmd :: String -> GHCi ()
1001 let expr = '(' : str ++ ") :: IO String"
1002 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1003 hv <- GHC.compileExpr expr
1004 cmds <- io $ (unsafeCoerce# hv :: IO String)
1005 enqueueCommands (lines cmds)
1008 loadModuleName :: GHC.GhcMonad m => ImportDecl RdrName -> m Module
1009 loadModuleName = flip GHC.findModule Nothing . unLoc . ideclName
1011 loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
1012 loadModule fs = timeIt (loadModule' fs)
1014 loadModule_ :: [FilePath] -> InputT GHCi ()
1015 loadModule_ fs = loadModule (zip fs (repeat Nothing)) >> return ()
1017 loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
1018 loadModule' files = do
1019 prev_context <- GHC.getContext
1023 lift discardActiveBreakPoints
1025 _ <- GHC.load LoadAllTargets
1027 let (filenames, phases) = unzip files
1028 exp_filenames <- mapM expandPath filenames
1029 let files' = zip exp_filenames phases
1030 targets <- mapM (uncurry GHC.guessTarget) files'
1032 -- NOTE: we used to do the dependency anal first, so that if it
1033 -- fails we didn't throw away the current set of modules. This would
1034 -- require some re-working of the GHC interface, so we'll leave it
1035 -- as a ToDo for now.
1037 GHC.setTargets targets
1038 doLoad False prev_context LoadAllTargets
1040 checkModule :: String -> InputT GHCi ()
1042 let modl = GHC.mkModuleName m
1043 prev_context <- GHC.getContext
1044 ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do
1045 r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
1046 outputStrLn (showSDoc (
1047 case GHC.moduleInfo r of
1048 cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1050 (local,global) = ASSERT( all isExternalName scope )
1051 partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1053 (text "global names: " <+> ppr global) $$
1054 (text "local names: " <+> ppr local)
1057 afterLoad (successIf ok) False prev_context
1059 reloadModule :: String -> InputT GHCi ()
1061 prev_context <- GHC.getContext
1062 _ <- doLoad True prev_context $
1063 if null m then LoadAllTargets
1064 else LoadUpTo (GHC.mkModuleName m)
1067 doLoad :: Bool -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> LoadHowMuch -> InputT GHCi SuccessFlag
1068 doLoad retain_context prev_context howmuch = do
1069 -- turn off breakpoints before we load: we can't turn them off later, because
1070 -- the ModBreaks will have gone away.
1071 lift discardActiveBreakPoints
1072 ok <- trySuccess $ GHC.load howmuch
1073 afterLoad ok retain_context prev_context
1076 afterLoad :: SuccessFlag -> Bool -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> InputT GHCi ()
1077 afterLoad ok retain_context prev_context = do
1078 lift revertCAFs -- always revert CAFs on load.
1079 lift discardTickArrays
1080 loaded_mod_summaries <- getLoadedModules
1081 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1082 loaded_mod_names = map GHC.moduleName loaded_mods
1083 modulesLoadedMsg ok loaded_mod_names
1085 lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
1088 setContextAfterLoad :: ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> Bool -> [GHC.ModSummary] -> GHCi ()
1089 setContextAfterLoad prev keep_ctxt [] = do
1090 prel_mod <- getPrelude
1091 setContextKeepingPackageModules prev keep_ctxt ([], [(prel_mod, Nothing)])
1092 setContextAfterLoad prev keep_ctxt ms = do
1093 -- load a target if one is available, otherwise load the topmost module.
1094 targets <- GHC.getTargets
1095 case [ m | Just m <- map (findTarget ms) targets ] of
1097 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1098 load_this (last graph')
1103 = case filter (`matches` t) ms of
1107 summary `matches` Target (TargetModule m) _ _
1108 = GHC.ms_mod_name summary == m
1109 summary `matches` Target (TargetFile f _) _ _
1110 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1114 load_this summary | m <- GHC.ms_mod summary = do
1115 b <- GHC.moduleIsInterpreted m
1116 if b then setContextKeepingPackageModules prev keep_ctxt ([m], [])
1118 prel_mod <- getPrelude
1119 setContextKeepingPackageModules prev keep_ctxt ([],[(prel_mod,Nothing),(m,Nothing)])
1121 -- | Keep any package modules (except Prelude) when changing the context.
1122 setContextKeepingPackageModules
1123 :: ([Module],[(Module, Maybe (ImportDecl RdrName))]) -- previous context
1124 -> Bool -- re-execute :module commands
1125 -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -- new context
1127 setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do
1128 let (_,bs0) = prev_context
1129 prel_mod <- getPrelude
1130 -- filter everything, not just lefts
1131 let pkg_modules = filter ((\p -> not (isHomeModule p) && p /= prel_mod) . fst) bs0
1132 let bs1 = if null as then nubBy sameFst ((prel_mod,Nothing) : bs) else bs
1133 GHC.setContext as (nubBy sameFst (bs1 ++ pkg_modules))
1137 let mem = remembered_ctx st
1138 playCmd (Left x) = playCtxtCmd False x
1139 playCmd (Right x) = importContext False x
1143 setGHCiState st{ remembered_ctx = [] }
1145 isHomeModule :: Module -> Bool
1146 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1148 sameFst :: (Module, Maybe (ImportDecl RdrName)) -> (Module, Maybe (ImportDecl RdrName)) -> Bool
1149 sameFst x y = fst x == fst y
1151 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi ()
1152 modulesLoadedMsg ok mods = do
1153 dflags <- getDynFlags
1154 when (verbosity dflags > 0) $ do
1156 | null mods = text "none."
1157 | otherwise = hsep (
1158 punctuate comma (map ppr mods)) <> text "."
1161 outputStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))
1163 outputStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas))
1166 typeOfExpr :: String -> InputT GHCi ()
1168 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1169 ty <- GHC.exprType str
1170 dflags <- getDynFlags
1171 let pefas = dopt Opt_PrintExplicitForalls dflags
1172 printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]
1174 kindOfType :: String -> InputT GHCi ()
1176 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1177 ty <- GHC.typeKind str
1178 printForUser $ text str <+> dcolon <+> ppr ty
1180 quit :: String -> InputT GHCi Bool
1181 quit _ = return True
1183 shellEscape :: String -> GHCi Bool
1184 shellEscape str = io (system str >> return False)
1186 -----------------------------------------------------------------------------
1187 -- Browsing a module's contents
1189 browseCmd :: Bool -> String -> InputT GHCi ()
1192 ['*':s] | looksLikeModuleName s -> do
1193 m <- lift $ wantInterpretedModule s
1194 browseModule bang m False
1195 [s] | looksLikeModuleName s -> do
1196 m <- lift $ lookupModule s
1197 browseModule bang m True
1199 (as,bs) <- GHC.getContext
1200 -- Guess which module the user wants to browse. Pick
1201 -- modules that are interpreted first. The most
1202 -- recently-added module occurs last, it seems.
1204 (as@(_:_), _) -> browseModule bang (last as) True
1205 ([], bs@(_:_)) -> browseModule bang (fst (last bs)) True
1206 ([], []) -> ghcError (CmdLineError ":browse: no current module")
1207 _ -> ghcError (CmdLineError "syntax: :browse <module>")
1209 -- without bang, show items in context of their parents and omit children
1210 -- with bang, show class methods and data constructors separately, and
1211 -- indicate import modules, to aid qualifying unqualified names
1212 -- with sorted, sort items alphabetically
1213 browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
1214 browseModule bang modl exports_only = do
1215 -- :browse! reports qualifiers wrt current context
1216 current_unqual <- GHC.getPrintUnqual
1217 -- Temporarily set the context to the module we're interested in,
1218 -- just so we can get an appropriate PrintUnqualified
1219 (as,bs) <- GHC.getContext
1220 prel_mod <- lift getPrelude
1221 if exports_only then GHC.setContext [] [(prel_mod,Nothing), (modl,Nothing)]
1222 else GHC.setContext [modl] []
1223 target_unqual <- GHC.getPrintUnqual
1224 GHC.setContext as bs
1226 let unqual = if bang then current_unqual else target_unqual
1228 mb_mod_info <- GHC.getModuleInfo modl
1230 Nothing -> ghcError (CmdLineError ("unknown module: " ++
1231 GHC.moduleNameString (GHC.moduleName modl)))
1233 dflags <- getDynFlags
1235 | exports_only = GHC.modInfoExports mod_info
1236 | otherwise = GHC.modInfoTopLevelScope mod_info
1239 -- sort alphabetically name, but putting
1240 -- locally-defined identifiers first.
1241 -- We would like to improve this; see #1799.
1242 sorted_names = loc_sort local ++ occ_sort external
1244 (local,external) = ASSERT( all isExternalName names )
1245 partition ((==modl) . nameModule) names
1246 occ_sort = sortBy (compare `on` nameOccName)
1247 -- try to sort by src location. If the first name in
1248 -- our list has a good source location, then they all should.
1250 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1251 = sortBy (compare `on` nameSrcSpan) names
1255 mb_things <- mapM GHC.lookupName sorted_names
1256 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1258 rdr_env <- GHC.getGRE
1260 let pefas = dopt Opt_PrintExplicitForalls dflags
1261 things | bang = catMaybes mb_things
1262 | otherwise = filtered_things
1263 pretty | bang = pprTyThing
1264 | otherwise = pprTyThingInContext
1266 labels [] = text "-- not currently imported"
1267 labels l = text $ intercalate "\n" $ map qualifier l
1268 qualifier = maybe "-- defined locally"
1269 (("-- imported via "++) . intercalate ", "
1270 . map GHC.moduleNameString)
1271 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1272 modNames = map (importInfo . GHC.getName) things
1274 -- annotate groups of imports with their import modules
1275 -- the default ordering is somewhat arbitrary, so we group
1276 -- by header and sort groups; the names themselves should
1277 -- really come in order of source appearance.. (trac #1799)
1278 annotate mts = concatMap (\(m,ts)->labels m:ts)
1279 $ sortBy cmpQualifiers $ group mts
1280 where cmpQualifiers =
1281 compare `on` (map (fmap (map moduleNameFS)) . fst)
1283 group mts@((m,_):_) = (m,map snd g) : group ng
1284 where (g,ng) = partition ((==m).fst) mts
1286 let prettyThings = map (pretty pefas) things
1287 prettyThings' | bang = annotate $ zip modNames prettyThings
1288 | otherwise = prettyThings
1289 outputStrLn $ showSDocForUser unqual (vcat prettyThings')
1290 -- ToDo: modInfoInstances currently throws an exception for
1291 -- package modules. When it works, we can do this:
1292 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1294 -----------------------------------------------------------------------------
1295 -- Setting the module context
1297 importContext :: Bool -> String -> GHCi ()
1298 importContext fail str
1300 (as,bs) <- GHC.getContext
1302 case Monad.join x of
1303 Nothing -> return ()
1305 m <- loadModuleName a
1306 GHC.setContext as (bs++[(m,Just a)])
1308 let cmds = remembered_ctx st
1309 setGHCiState st{ remembered_ctx = cmds++[Right str] }
1311 do_checks True = liftM Just (GhciMonad.parseImportDecl str)
1312 do_checks False = trymaybe (GhciMonad.parseImportDecl str)
1314 setContext :: String -> GHCi ()
1316 | all sensible strs = do
1317 playCtxtCmd True (cmd, as, bs)
1319 let cmds = remembered_ctx st
1320 setGHCiState st{ remembered_ctx = cmds ++ [Left (cmd,as,bs)] }
1321 | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1323 (cmd, strs, as, bs) =
1325 '+':stuff -> rest AddModules stuff
1326 '-':stuff -> rest RemModules stuff
1327 stuff -> rest SetContext stuff
1329 rest cmd stuff = (cmd, strs, as, bs)
1330 where strs = words stuff
1331 (as,bs) = partitionWith starred strs
1333 sensible ('*':m) = looksLikeModuleName m
1334 sensible m = looksLikeModuleName m
1336 starred ('*':m) = Left m
1339 playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi ()
1340 playCtxtCmd fail (cmd, as, bs)
1342 (as',bs') <- do_checks fail
1343 (prev_as,prev_bs) <- GHC.getContext
1347 prel_mod <- getPrelude
1348 let bs'' = if null as && prel_mod `notElem` (map fst bs') then (prel_mod,Nothing):bs'
1352 -- it should replace the old stuff, not the other way around
1353 -- need deleteAllBy, not deleteFirstsBy for sameFst
1354 let remaining_as = prev_as \\ (as' ++ map fst bs')
1355 remaining_bs = deleteAllBy sameFst prev_bs (bs' ++ map contextualize as')
1356 return (remaining_as ++ as', remaining_bs ++ bs')
1358 let new_as = prev_as \\ (as' ++ map fst bs')
1359 new_bs = deleteAllBy sameFst prev_bs (map contextualize as' ++ bs')
1360 return (new_as, new_bs)
1361 GHC.setContext new_as new_bs
1364 as' <- mapM wantInterpretedModule as
1365 bs' <- mapM lookupModule bs
1366 return (as', map contextualize bs')
1367 do_checks False = do
1368 as' <- mapM (trymaybe . wantInterpretedModule) as
1369 bs' <- mapM (trymaybe . lookupModule) bs
1370 return (catMaybes as', map contextualize (catMaybes bs'))
1371 contextualize x = (x,Nothing)
1372 deleteAllBy f a b = filter (\x->(not (any (f x) b))) a
1374 trymaybe ::GHCi a -> GHCi (Maybe a)
1378 Left _ -> return Nothing
1379 Right a -> return (Just a)
1381 ----------------------------------------------------------------------------
1384 -- set options in the interpreter. Syntax is exactly the same as the
1385 -- ghc command line, except that certain options aren't available (-C,
1388 -- This is pretty fragile: most options won't work as expected. ToDo:
1389 -- figure out which ones & disallow them.
1391 setCmd :: String -> GHCi ()
1393 = do st <- getGHCiState
1394 let opts = options st
1395 io $ putStrLn (showSDoc (
1396 text "options currently set: " <>
1399 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1401 dflags <- getDynFlags
1402 io $ putStrLn (showSDoc (
1403 vcat (text "GHCi-specific dynamic flag settings:"
1404 :map (flagSetting dflags) ghciFlags)
1406 io $ putStrLn (showSDoc (
1407 vcat (text "other dynamic, non-language, flag settings:"
1408 :map (flagSetting dflags) nonLanguageDynFlags)
1410 where flagSetting dflags (str, f, _)
1411 | dopt f dflags = text " " <> text "-f" <> text str
1412 | otherwise = text " " <> text "-fno-" <> text str
1413 (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags)
1415 nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions)
1417 flags = [Opt_PrintExplicitForalls
1418 ,Opt_PrintBindResult
1419 ,Opt_BreakOnException
1421 ,Opt_PrintEvldWithShow
1424 = case getCmd str of
1425 Right ("args", rest) ->
1427 Left err -> io (hPutStrLn stderr err)
1428 Right args -> setArgs args
1429 Right ("prog", rest) ->
1431 Right [prog] -> setProg prog
1432 _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")
1433 Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1434 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1435 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1436 _ -> case toArgs str of
1437 Left err -> io (hPutStrLn stderr err)
1438 Right wds -> setOptions wds
1440 setArgs, setOptions :: [String] -> GHCi ()
1441 setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
1445 setGHCiState st{ args = args }
1449 setGHCiState st{ progname = prog }
1453 setGHCiState st{ editor = cmd }
1455 setStop str@(c:_) | isDigit c
1456 = do let (nm_str,rest) = break (not.isDigit) str
1459 let old_breaks = breaks st
1460 if all ((/= nm) . fst) old_breaks
1461 then printForUser (text "Breakpoint" <+> ppr nm <+>
1462 text "does not exist")
1464 let new_breaks = map fn old_breaks
1465 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1466 | otherwise = (i,loc)
1467 setGHCiState st{ breaks = new_breaks }
1470 setGHCiState st{ stop = cmd }
1472 setPrompt value = do
1475 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1477 '\"' : _ -> case reads value of
1478 [(value', xs)] | all isSpace xs ->
1479 setGHCiState (st { prompt = value' })
1481 io $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
1482 _ -> setGHCiState (st { prompt = value })
1485 do -- first, deal with the GHCi opts (+s, +t, etc.)
1486 let (plus_opts, minus_opts) = partitionWith isPlus wds
1487 mapM_ setOpt plus_opts
1488 -- then, dynamic flags
1489 newDynFlags minus_opts
1491 newDynFlags :: [String] -> GHCi ()
1492 newDynFlags minus_opts = do
1493 dflags <- getDynFlags
1494 let pkg_flags = packageFlags dflags
1495 (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
1496 handleFlagWarnings dflags' warns
1498 if (not (null leftovers))
1499 then ghcError $ errorsToGhcException leftovers
1502 new_pkgs <- setDynFlags dflags'
1504 -- if the package flags changed, we should reset the context
1505 -- and link the new packages.
1506 dflags <- getDynFlags
1507 when (packageFlags dflags /= pkg_flags) $ do
1508 io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
1510 _ <- GHC.load LoadAllTargets
1511 io (linkPackages dflags new_pkgs)
1512 -- package flags changed, we can't re-use any of the old context
1513 setContextAfterLoad ([],[]) False []
1517 unsetOptions :: String -> GHCi ()
1519 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1520 let opts = words str
1521 (minus_opts, rest1) = partition isMinus opts
1522 (plus_opts, rest2) = partitionWith isPlus rest1
1524 if (not (null rest2))
1525 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1528 mapM_ unsetOpt plus_opts
1530 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1531 no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
1533 no_flags <- mapM no_flag minus_opts
1534 newDynFlags no_flags
1536 isMinus :: String -> Bool
1537 isMinus ('-':_) = True
1540 isPlus :: String -> Either String String
1541 isPlus ('+':opt) = Left opt
1542 isPlus other = Right other
1544 setOpt, unsetOpt :: String -> GHCi ()
1547 = case strToGHCiOpt str of
1548 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1549 Just o -> setOption o
1552 = case strToGHCiOpt str of
1553 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1554 Just o -> unsetOption o
1556 strToGHCiOpt :: String -> (Maybe GHCiOption)
1557 strToGHCiOpt "s" = Just ShowTiming
1558 strToGHCiOpt "t" = Just ShowType
1559 strToGHCiOpt "r" = Just RevertCAFs
1560 strToGHCiOpt _ = Nothing
1562 optToStr :: GHCiOption -> String
1563 optToStr ShowTiming = "s"
1564 optToStr ShowType = "t"
1565 optToStr RevertCAFs = "r"
1567 -- ---------------------------------------------------------------------------
1570 showCmd :: String -> GHCi ()
1574 ["args"] -> io $ putStrLn (show (args st))
1575 ["prog"] -> io $ putStrLn (show (progname st))
1576 ["prompt"] -> io $ putStrLn (show (prompt st))
1577 ["editor"] -> io $ putStrLn (show (editor st))
1578 ["stop"] -> io $ putStrLn (show (stop st))
1579 ["modules" ] -> showModules
1580 ["bindings"] -> showBindings
1581 ["linker"] -> io showLinkerState
1582 ["breaks"] -> showBkptTable
1583 ["context"] -> showContext
1584 ["packages"] -> showPackages
1585 ["languages"] -> showLanguages
1586 _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
1587 " | breaks | context | packages | languages ]"))
1589 showModules :: GHCi ()
1591 loaded_mods <- getLoadedModules
1592 -- we want *loaded* modules only, see #1734
1593 let show_one ms = do m <- GHC.showModule ms; io (putStrLn m)
1594 mapM_ show_one loaded_mods
1596 getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
1597 getLoadedModules = do
1598 graph <- GHC.getModuleGraph
1599 filterM (GHC.isLoaded . GHC.ms_mod_name) graph
1601 showBindings :: GHCi ()
1603 bindings <- GHC.getBindings
1604 docs <- pprTypeAndContents
1605 [ id | AnId id <- sortBy compareTyThings bindings]
1606 printForUserPartWay docs
1608 compareTyThings :: TyThing -> TyThing -> Ordering
1609 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1611 printTyThing :: TyThing -> GHCi ()
1612 printTyThing tyth = do dflags <- getDynFlags
1613 let pefas = dopt Opt_PrintExplicitForalls dflags
1614 printForUser (pprTyThing pefas tyth)
1616 showBkptTable :: GHCi ()
1619 printForUser $ prettyLocations (breaks st)
1621 showContext :: GHCi ()
1623 resumes <- GHC.getResumeContext
1624 printForUser $ vcat (map pp_resume (reverse resumes))
1627 ptext (sLit "--> ") <> text (GHC.resumeStmt resume)
1628 $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume))
1630 showPackages :: GHCi ()
1632 pkg_flags <- fmap packageFlags getDynFlags
1633 io $ putStrLn $ showSDoc $ vcat $
1634 text ("active package flags:"++if null pkg_flags then " none" else "")
1635 : map showFlag pkg_flags
1636 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1637 io $ putStrLn $ showSDoc $ vcat $
1638 text "packages currently loaded:"
1639 : map (nest 2 . text . packageIdString)
1640 (sortBy (compare `on` packageIdFS) pkg_ids)
1641 where showFlag (ExposePackage p) = text $ " -package " ++ p
1642 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1643 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1644 showFlag (ExposePackageId p) = text $ " -package-id " ++ p
1646 showLanguages :: GHCi ()
1648 dflags <- getDynFlags
1649 io $ putStrLn $ showSDoc $ vcat $
1650 text "active language flags:" :
1651 [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags]
1653 -- -----------------------------------------------------------------------------
1656 completeCmd, completeMacro, completeIdentifier, completeModule,
1657 completeHomeModule, completeSetOptions, completeShowOptions,
1658 completeHomeModuleOrFile, completeExpression
1659 :: CompletionFunc GHCi
1661 ghciCompleteWord :: CompletionFunc GHCi
1662 ghciCompleteWord line@(left,_) = case firstWord of
1663 ':':cmd | null rest -> completeCmd line
1665 completion <- lookupCompletion cmd
1667 "import" -> completeModule line
1668 _ -> completeExpression line
1670 (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
1671 lookupCompletion ('!':_) = return completeFilename
1672 lookupCompletion c = do
1673 maybe_cmd <- liftIO $ lookupCommand' c
1675 Just (_,_,f) -> return f
1676 Nothing -> return completeFilename
1678 completeCmd = wrapCompleter " " $ \w -> do
1679 macros <- liftIO $ readIORef macros_ref
1680 let macro_names = map (':':) . map cmdName $ macros
1681 let command_names = map (':':) . map cmdName $ builtin_commands
1682 let{ candidates = case w of
1683 ':' : ':' : _ -> map (':':) command_names
1684 _ -> nub $ macro_names ++ command_names }
1685 return $ filter (w `isPrefixOf`) candidates
1687 completeMacro = wrapIdentCompleter $ \w -> do
1688 cmds <- liftIO $ readIORef macros_ref
1689 return (filter (w `isPrefixOf`) (map cmdName cmds))
1691 completeIdentifier = wrapIdentCompleter $ \w -> do
1692 rdrs <- GHC.getRdrNamesInScope
1693 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1695 completeModule = wrapIdentCompleter $ \w -> do
1696 dflags <- GHC.getSessionDynFlags
1697 let pkg_mods = allExposedModules dflags
1698 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
1699 return $ filter (w `isPrefixOf`)
1700 $ map (showSDoc.ppr) $ loaded_mods ++ pkg_mods
1702 completeHomeModule = wrapIdentCompleter listHomeModules
1704 listHomeModules :: String -> GHCi [String]
1705 listHomeModules w = do
1706 g <- GHC.getModuleGraph
1707 let home_mods = map GHC.ms_mod_name g
1708 return $ sort $ filter (w `isPrefixOf`)
1709 $ map (showSDoc.ppr) home_mods
1711 completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
1712 return (filter (w `isPrefixOf`) options)
1713 where options = "args":"prog":"prompt":"editor":"stop":flagList
1714 flagList = map head $ group $ sort allFlags
1716 completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
1717 return (filter (w `isPrefixOf`) options)
1718 where options = ["args", "prog", "prompt", "editor", "stop",
1719 "modules", "bindings", "linker", "breaks",
1720 "context", "packages", "languages"]
1722 completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
1723 $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
1726 unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
1727 unionComplete f1 f2 line = do
1732 wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
1733 wrapCompleter breakChars fun = completeWord Nothing breakChars
1734 $ fmap (map simpleCompletion) . fmap sort . fun
1736 wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
1737 wrapIdentCompleter = wrapCompleter word_break_chars
1739 allExposedModules :: DynFlags -> [ModuleName]
1740 allExposedModules dflags
1741 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1743 pkg_db = pkgIdMap (pkgState dflags)
1745 completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
1748 -- ---------------------------------------------------------------------------
1749 -- User code exception handling
1751 -- This is the exception handler for exceptions generated by the
1752 -- user's code and exceptions coming from children sessions;
1753 -- it normally just prints out the exception. The
1754 -- handler must be recursive, in case showing the exception causes
1755 -- more exceptions to be raised.
1757 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1758 -- raising another exception. We therefore don't put the recursive
1759 -- handler arond the flushing operation, so if stderr is closed
1760 -- GHCi will just die gracefully rather than going into an infinite loop.
1761 handler :: SomeException -> GHCi Bool
1763 handler exception = do
1765 io installSignalHandlers
1766 ghciHandle handler (showException exception >> return False)
1768 showException :: SomeException -> GHCi ()
1770 io $ case fromException se of
1771 -- omit the location for CmdLineError:
1772 Just (CmdLineError s) -> putStrLn s
1774 Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
1775 Just other_ghc_ex -> print other_ghc_ex
1777 case fromException se of
1778 Just UserInterrupt -> putStrLn "Interrupted."
1779 _other -> putStrLn ("*** Exception: " ++ show se)
1781 -----------------------------------------------------------------------------
1782 -- recursive exception handlers
1784 -- Don't forget to unblock async exceptions in the handler, or if we're
1785 -- in an exception loop (eg. let a = error a in a) the ^C exception
1786 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1788 ghciHandle :: MonadException m => (SomeException -> m a) -> m a -> m a
1789 ghciHandle h m = Haskeline.catch m $ \e -> unblock (h e)
1791 ghciTry :: GHCi a -> GHCi (Either SomeException a)
1792 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
1794 -- ----------------------------------------------------------------------------
1797 -- TODO: won't work if home dir is encoded.
1798 -- (changeDirectory may not work either in that case.)
1799 expandPath :: MonadIO m => String -> InputT m String
1800 expandPath path = do
1801 exp_path <- liftIO $ expandPathIO path
1802 enc <- fmap BS.unpack $ Encoding.encode exp_path
1805 expandPathIO :: String -> IO String
1807 case dropWhile isSpace path of
1809 tilde <- getHomeDirectory -- will fail if HOME not defined
1810 return (tilde ++ '/':d)
1814 wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
1815 wantInterpretedModule str = do
1816 modl <- lookupModule str
1817 dflags <- getDynFlags
1818 when (GHC.modulePackageId modl /= thisPackage dflags) $
1819 ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
1820 is_interpreted <- GHC.moduleIsInterpreted modl
1821 when (not is_interpreted) $
1822 ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
1825 wantNameFromInterpretedModule :: GHC.GhcMonad m
1826 => (Name -> SDoc -> m ())
1830 wantNameFromInterpretedModule noCanDo str and_then =
1831 handleSourceError (GHC.printExceptionAndWarnings) $ do
1832 names <- GHC.parseName str
1836 let modl = ASSERT( isExternalName n ) GHC.nameModule n
1837 if not (GHC.isExternalName n)
1838 then noCanDo n $ ppr n <>
1839 text " is not defined in an interpreted module"
1841 is_interpreted <- GHC.moduleIsInterpreted modl
1842 if not is_interpreted
1843 then noCanDo n $ text "module " <> ppr modl <>
1844 text " is not interpreted"
1847 -- -----------------------------------------------------------------------------
1848 -- commands for debugger
1850 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1851 sprintCmd = pprintCommand False False
1852 printCmd = pprintCommand True False
1853 forceCmd = pprintCommand False True
1855 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1856 pprintCommand bind force str = do
1857 pprintClosureCommand bind force str
1859 stepCmd :: String -> GHCi ()
1860 stepCmd [] = doContinue (const True) GHC.SingleStep
1861 stepCmd expression = runStmt expression GHC.SingleStep >> return ()
1863 stepLocalCmd :: String -> GHCi ()
1864 stepLocalCmd [] = do
1865 mb_span <- getCurrentBreakSpan
1867 Nothing -> stepCmd []
1869 Just mod <- getCurrentBreakModule
1870 current_toplevel_decl <- enclosingTickSpan mod loc
1871 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1873 stepLocalCmd expression = stepCmd expression
1875 stepModuleCmd :: String -> GHCi ()
1876 stepModuleCmd [] = do
1877 mb_span <- getCurrentBreakSpan
1879 Nothing -> stepCmd []
1881 Just span <- getCurrentBreakSpan
1882 let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span
1883 doContinue f GHC.SingleStep
1885 stepModuleCmd expression = stepCmd expression
1887 -- | Returns the span of the largest tick containing the srcspan given
1888 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1889 enclosingTickSpan mod src = do
1890 ticks <- getTickArray mod
1891 let line = srcSpanStartLine src
1892 ASSERT (inRange (bounds ticks) line) do
1893 let enclosing_spans = [ span | (_,span) <- ticks ! line
1894 , srcSpanEnd span >= srcSpanEnd src]
1895 return . head . sortBy leftmost_largest $ enclosing_spans
1897 traceCmd :: String -> GHCi ()
1898 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1899 traceCmd expression = runStmt expression GHC.RunAndLogSteps >> return ()
1901 continueCmd :: String -> GHCi ()
1902 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1904 -- doContinue :: SingleStep -> GHCi ()
1905 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1906 doContinue pred step = do
1907 runResult <- resume pred step
1908 _ <- afterRunStmt pred runResult
1911 abandonCmd :: String -> GHCi ()
1912 abandonCmd = noArgs $ do
1913 b <- GHC.abandon -- the prompt will change to indicate the new context
1914 when (not b) $ io $ putStrLn "There is no computation running."
1917 deleteCmd :: String -> GHCi ()
1918 deleteCmd argLine = do
1919 deleteSwitch $ words argLine
1921 deleteSwitch :: [String] -> GHCi ()
1923 io $ putStrLn "The delete command requires at least one argument."
1924 -- delete all break points
1925 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1926 deleteSwitch idents = do
1927 mapM_ deleteOneBreak idents
1929 deleteOneBreak :: String -> GHCi ()
1931 | all isDigit str = deleteBreak (read str)
1932 | otherwise = return ()
1934 historyCmd :: String -> GHCi ()
1936 | null arg = history 20
1937 | all isDigit arg = history (read arg)
1938 | otherwise = io $ putStrLn "Syntax: :history [num]"
1941 resumes <- GHC.getResumeContext
1943 [] -> io $ putStrLn "Not stopped at a breakpoint"
1945 let hist = GHC.resumeHistory r
1946 (took,rest) = splitAt num hist
1948 [] -> io $ putStrLn $
1949 "Empty history. Perhaps you forgot to use :trace?"
1951 spans <- mapM GHC.getHistorySpan took
1952 let nums = map (printf "-%-3d:") [(1::Int)..]
1953 names = map GHC.historyEnclosingDecl took
1954 printForUser (vcat(zipWith3
1955 (\x y z -> x <+> y <+> z)
1957 (map (bold . ppr) names)
1958 (map (parens . ppr) spans)))
1959 io $ putStrLn $ if null rest then "<end of history>" else "..."
1961 bold :: SDoc -> SDoc
1962 bold c | do_bold = text start_bold <> c <> text end_bold
1965 backCmd :: String -> GHCi ()
1966 backCmd = noArgs $ do
1967 (names, _, span) <- GHC.back
1968 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span
1969 printTypeOfNames names
1970 -- run the command set with ":set stop <cmd>"
1972 enqueueCommands [stop st]
1974 forwardCmd :: String -> GHCi ()
1975 forwardCmd = noArgs $ do
1976 (names, ix, span) <- GHC.forward
1977 printForUser $ (if (ix == 0)
1978 then ptext (sLit "Stopped at")
1979 else ptext (sLit "Logged breakpoint at")) <+> ppr span
1980 printTypeOfNames names
1981 -- run the command set with ":set stop <cmd>"
1983 enqueueCommands [stop st]
1985 -- handle the "break" command
1986 breakCmd :: String -> GHCi ()
1987 breakCmd argLine = do
1988 breakSwitch $ words argLine
1990 breakSwitch :: [String] -> GHCi ()
1992 io $ putStrLn "The break command requires at least one argument."
1993 breakSwitch (arg1:rest)
1994 | looksLikeModuleName arg1 && not (null rest) = do
1995 mod <- wantInterpretedModule arg1
1996 breakByModule mod rest
1997 | all isDigit arg1 = do
1998 (toplevel, _) <- GHC.getContext
2000 (mod : _) -> breakByModuleLine mod (read arg1) rest
2002 io $ putStrLn "Cannot find default module for breakpoint."
2003 io $ putStrLn "Perhaps no modules are loaded for debugging?"
2004 | otherwise = do -- try parsing it as an identifier
2005 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
2006 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2007 if GHC.isGoodSrcLoc loc
2008 then ASSERT( isExternalName name )
2009 findBreakAndSet (GHC.nameModule name) $
2010 findBreakByCoord (Just (GHC.srcLocFile loc))
2011 (GHC.srcLocLine loc,
2013 else noCanDo name $ text "can't find its location: " <> ppr loc
2015 noCanDo n why = printForUser $
2016 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
2018 breakByModule :: Module -> [String] -> GHCi ()
2019 breakByModule mod (arg1:rest)
2020 | all isDigit arg1 = do -- looks like a line number
2021 breakByModuleLine mod (read arg1) rest
2025 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
2026 breakByModuleLine mod line args
2027 | [] <- args = findBreakAndSet mod $ findBreakByLine line
2028 | [col] <- args, all isDigit col =
2029 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
2030 | otherwise = breakSyntax
2033 breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
2035 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
2036 findBreakAndSet mod lookupTickTree = do
2037 tickArray <- getTickArray mod
2038 (breakArray, _) <- getModBreak mod
2039 case lookupTickTree tickArray of
2040 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
2041 Just (tick, span) -> do
2042 success <- io $ setBreakFlag True breakArray tick
2046 recordBreak $ BreakLocation
2053 text "Breakpoint " <> ppr nm <>
2055 then text " was already set at " <> ppr span
2056 else text " activated at " <> ppr span
2058 printForUser $ text "Breakpoint could not be activated at"
2061 -- When a line number is specified, the current policy for choosing
2062 -- the best breakpoint is this:
2063 -- - the leftmost complete subexpression on the specified line, or
2064 -- - the leftmost subexpression starting on the specified line, or
2065 -- - the rightmost subexpression enclosing the specified line
2067 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2068 findBreakByLine line arr
2069 | not (inRange (bounds arr) line) = Nothing
2071 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
2072 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2073 listToMaybe (sortBy (rightmost `on` snd) ticks)
2077 starts_here = [ tick | tick@(_,span) <- ticks,
2078 GHC.srcSpanStartLine span == line ]
2080 (complete,incomplete) = partition ends_here starts_here
2081 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2083 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2084 -> Maybe (BreakIndex,SrcSpan)
2085 findBreakByCoord mb_file (line, col) arr
2086 | not (inRange (bounds arr) line) = Nothing
2088 listToMaybe (sortBy (rightmost `on` snd) contains ++
2089 sortBy (leftmost_smallest `on` snd) after_here)
2093 -- the ticks that span this coordinate
2094 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2095 is_correct_file span ]
2097 is_correct_file span
2098 | Just f <- mb_file = GHC.srcSpanFile span == f
2101 after_here = [ tick | tick@(_,span) <- ticks,
2102 GHC.srcSpanStartLine span == line,
2103 GHC.srcSpanStartCol span >= col ]
2105 -- For now, use ANSI bold on terminals that we know support it.
2106 -- Otherwise, we add a line of carets under the active expression instead.
2107 -- In particular, on Windows and when running the testsuite (which sets
2108 -- TERM to vt100 for other reasons) we get carets.
2109 -- We really ought to use a proper termcap/terminfo library.
2111 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2112 where mTerm = System.Environment.getEnv "TERM"
2113 `catchIO` \_ -> return "TERM not set"
2115 start_bold :: String
2116 start_bold = "\ESC[1m"
2118 end_bold = "\ESC[0m"
2120 listCmd :: String -> InputT GHCi ()
2122 mb_span <- lift getCurrentBreakSpan
2125 printForUser $ text "Not stopped at a breakpoint; nothing to list"
2127 | GHC.isGoodSrcSpan span -> listAround span True
2129 do resumes <- GHC.getResumeContext
2131 [] -> panic "No resumes"
2133 do let traceIt = case GHC.resumeHistory r of
2134 [] -> text "rerunning with :trace,"
2136 doWhat = traceIt <+> text ":back then :list"
2137 printForUser (text "Unable to list source for" <+>
2139 $$ text "Try" <+> doWhat)
2140 listCmd str = list2 (words str)
2142 list2 :: [String] -> InputT GHCi ()
2143 list2 [arg] | all isDigit arg = do
2144 (toplevel, _) <- GHC.getContext
2146 [] -> outputStrLn "No module to list"
2147 (mod : _) -> listModuleLine mod (read arg)
2148 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2149 mod <- wantInterpretedModule arg1
2150 listModuleLine mod (read arg2)
2152 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2153 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2154 if GHC.isGoodSrcLoc loc
2156 tickArray <- ASSERT( isExternalName name )
2157 lift $ getTickArray (GHC.nameModule name)
2158 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2159 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2162 Nothing -> listAround (GHC.srcLocSpan loc) False
2163 Just (_,span) -> listAround span False
2165 noCanDo name $ text "can't find its location: " <>
2168 noCanDo n why = printForUser $
2169 text "cannot list source code for " <> ppr n <> text ": " <> why
2171 outputStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2173 listModuleLine :: Module -> Int -> InputT GHCi ()
2174 listModuleLine modl line = do
2175 graph <- GHC.getModuleGraph
2176 let this = filter ((== modl) . GHC.ms_mod) graph
2178 [] -> panic "listModuleLine"
2180 let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
2181 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2182 listAround (GHC.srcLocSpan loc) False
2184 -- | list a section of a source file around a particular SrcSpan.
2185 -- If the highlight flag is True, also highlight the span using
2186 -- start_bold\/end_bold.
2188 -- GHC files are UTF-8, so we can implement this by:
2189 -- 1) read the file in as a BS and syntax highlight it as before
2190 -- 2) convert the BS to String using utf-string, and write it out.
2191 -- It would be better if we could convert directly between UTF-8 and the
2192 -- console encoding, of course.
2193 listAround :: MonadIO m => SrcSpan -> Bool -> InputT m ()
2194 listAround span do_highlight = do
2195 contents <- liftIO $ BS.readFile (unpackFS file)
2197 lines = BS.split '\n' contents
2198 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2199 drop (line1 - 1 - pad_before) $ lines
2200 fst_line = max 1 (line1 - pad_before)
2201 line_nos = [ fst_line .. ]
2203 highlighted | do_highlight = zipWith highlight line_nos these_lines
2204 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2206 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2207 prefixed = zipWith ($) highlighted bs_line_nos
2209 let output = BS.intercalate (BS.pack "\n") prefixed
2210 utf8Decoded <- liftIO $ BS.useAsCStringLen output
2211 $ \(p,n) -> utf8DecodeString (castPtr p) n
2212 outputStrLn utf8Decoded
2214 file = GHC.srcSpanFile span
2215 line1 = GHC.srcSpanStartLine span
2216 col1 = GHC.srcSpanStartCol span - 1
2217 line2 = GHC.srcSpanEndLine span
2218 col2 = GHC.srcSpanEndCol span - 1
2220 pad_before | line1 == 1 = 0
2224 highlight | do_bold = highlight_bold
2225 | otherwise = highlight_carets
2227 highlight_bold no line prefix
2228 | no == line1 && no == line2
2229 = let (a,r) = BS.splitAt col1 line
2230 (b,c) = BS.splitAt (col2-col1) r
2232 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2234 = let (a,b) = BS.splitAt col1 line in
2235 BS.concat [prefix, a, BS.pack start_bold, b]
2237 = let (a,b) = BS.splitAt col2 line in
2238 BS.concat [prefix, a, BS.pack end_bold, b]
2239 | otherwise = BS.concat [prefix, line]
2241 highlight_carets no line prefix
2242 | no == line1 && no == line2
2243 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2244 BS.replicate (col2-col1) '^']
2246 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2249 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2251 | otherwise = BS.concat [prefix, line]
2253 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2254 nl = BS.singleton '\n'
2256 -- --------------------------------------------------------------------------
2259 getTickArray :: Module -> GHCi TickArray
2260 getTickArray modl = do
2262 let arrmap = tickarrays st
2263 case lookupModuleEnv arrmap modl of
2264 Just arr -> return arr
2266 (_breakArray, ticks) <- getModBreak modl
2267 let arr = mkTickArray (assocs ticks)
2268 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2271 discardTickArrays :: GHCi ()
2272 discardTickArrays = do
2274 setGHCiState st{tickarrays = emptyModuleEnv}
2276 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2278 = accumArray (flip (:)) [] (1, max_line)
2279 [ (line, (nm,span)) | (nm,span) <- ticks,
2280 line <- srcSpanLines span ]
2282 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2283 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2284 GHC.srcSpanEndLine span ]
2286 lookupModule :: GHC.GhcMonad m => String -> m Module
2287 lookupModule modName
2288 = GHC.lookupModule (GHC.mkModuleName modName) Nothing
2290 -- don't reset the counter back to zero?
2291 discardActiveBreakPoints :: GHCi ()
2292 discardActiveBreakPoints = do
2294 mapM_ (turnOffBreak.snd) (breaks st)
2295 setGHCiState $ st { breaks = [] }
2297 deleteBreak :: Int -> GHCi ()
2298 deleteBreak identity = do
2300 let oldLocations = breaks st
2301 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2303 then printForUser (text "Breakpoint" <+> ppr identity <+>
2304 text "does not exist")
2306 mapM_ (turnOffBreak.snd) this
2307 setGHCiState $ st { breaks = rest }
2309 turnOffBreak :: BreakLocation -> GHCi Bool
2310 turnOffBreak loc = do
2311 (arr, _) <- getModBreak (breakModule loc)
2312 io $ setBreakFlag False arr (breakTick loc)
2314 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2315 getModBreak mod = do
2316 Just mod_info <- GHC.getModuleInfo mod
2317 let modBreaks = GHC.modInfoModBreaks mod_info
2318 let array = GHC.modBreaks_flags modBreaks
2319 let ticks = GHC.modBreaks_locs modBreaks
2320 return (array, ticks)
2322 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2323 setBreakFlag toggle array index
2324 | toggle = GHC.setBreakOn array index
2325 | otherwise = GHC.setBreakOff array index