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
87 import Control.Monad as Monad
90 import GHC.Exts ( unsafeCoerce# )
92 import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
93 import GHC.IO.Handle ( hFlushAll )
97 import Data.IORef ( IORef, readIORef, writeIORef )
99 -----------------------------------------------------------------------------
101 ghciWelcomeMsg :: String
102 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
103 ": http://www.haskell.org/ghc/ :? for help"
105 cmdName :: Command -> String
108 GLOBAL_VAR(macros_ref, [], [Command])
110 builtin_commands :: [Command]
112 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
113 ("?", keepGoing help, noCompletion),
114 ("add", keepGoingPaths addModule, completeFilename),
115 ("abandon", keepGoing abandonCmd, noCompletion),
116 ("break", keepGoing breakCmd, completeIdentifier),
117 ("back", keepGoing backCmd, noCompletion),
118 ("browse", keepGoing' (browseCmd False), completeModule),
119 ("browse!", keepGoing' (browseCmd True), completeModule),
120 ("cd", keepGoing' changeDirectory, completeFilename),
121 ("check", keepGoing' checkModule, completeHomeModule),
122 ("continue", keepGoing continueCmd, noCompletion),
123 ("cmd", keepGoing cmdCmd, completeExpression),
124 ("ctags", keepGoing createCTagsWithLineNumbersCmd, completeFilename),
125 ("ctags!", keepGoing createCTagsWithRegExesCmd, completeFilename),
126 ("def", keepGoing (defineMacro False), completeExpression),
127 ("def!", keepGoing (defineMacro True), completeExpression),
128 ("delete", keepGoing deleteCmd, noCompletion),
129 ("edit", keepGoing editFile, completeFilename),
130 ("etags", keepGoing createETagsFileCmd, completeFilename),
131 ("force", keepGoing forceCmd, completeExpression),
132 ("forward", keepGoing forwardCmd, noCompletion),
133 ("help", keepGoing help, noCompletion),
134 ("history", keepGoing historyCmd, noCompletion),
135 ("info", keepGoing' info, completeIdentifier),
136 ("kind", keepGoing' kindOfType, completeIdentifier),
137 ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),
138 ("list", keepGoing' listCmd, noCompletion),
139 ("module", keepGoing setContext, completeSetModule),
140 ("main", keepGoing runMain, completeFilename),
141 ("print", keepGoing printCmd, completeExpression),
142 ("quit", quit, noCompletion),
143 ("reload", keepGoing' reloadModule, noCompletion),
144 ("run", keepGoing runRun, completeFilename),
145 ("set", keepGoing setCmd, completeSetOptions),
146 ("show", keepGoing showCmd, completeShowOptions),
147 ("sprint", keepGoing sprintCmd, completeExpression),
148 ("step", keepGoing stepCmd, completeIdentifier),
149 ("steplocal", keepGoing stepLocalCmd, completeIdentifier),
150 ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),
151 ("type", keepGoing' typeOfExpr, completeExpression),
152 ("trace", keepGoing traceCmd, completeExpression),
153 ("undef", keepGoing undefineMacro, completeMacro),
154 ("unset", keepGoing unsetOptions, completeSetOptions)
158 -- We initialize readline (in the interactiveUI function) to use
159 -- word_break_chars as the default set of completion word break characters.
160 -- This can be overridden for a particular command (for example, filename
161 -- expansion shouldn't consider '/' to be a word break) by setting the third
162 -- entry in the Command tuple above.
164 -- NOTE: in order for us to override the default correctly, any custom entry
165 -- must be a SUBSET of word_break_chars.
166 word_break_chars :: String
167 word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
168 specials = "(),;[]`{}"
170 in spaces ++ specials ++ symbols
172 flagWordBreakChars :: String
173 flagWordBreakChars = " \t\n"
176 keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)
177 keepGoing a str = keepGoing' (lift . a) str
179 keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool
180 keepGoing' a str = a str >> return False
182 keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
184 = do case toArgs str of
185 Left err -> Encoding.encode err >>= liftIO . BS.hPutStrLn stderr
189 shortHelpText :: String
190 shortHelpText = "use :? for help.\n"
194 " Commands available from the prompt:\n" ++
196 " <statement> evaluate/run <statement>\n" ++
197 " : repeat last command\n" ++
198 " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
199 " :add [*]<module> ... add module(s) to the current target set\n" ++
200 " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
201 " (!: more details; *: all top-level names)\n" ++
202 " :cd <dir> change directory to <dir>\n" ++
203 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
204 " :ctags[!] [<file>] create tags file for Vi (default: \"tags\")\n" ++
205 " (!: use regex instead of line number)\n" ++
206 " :def <cmd> <expr> define a command :<cmd>\n" ++
207 " :edit <file> edit file\n" ++
208 " :edit edit last module\n" ++
209 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
210 " :help, :? display this list of commands\n" ++
211 " :info [<name> ...] display information about the given names\n" ++
212 " :kind <type> show the kind of <type>\n" ++
213 " :load [*]<module> ... load module(s) and their dependents\n" ++
214 " :main [<arguments> ...] run the main function with the given arguments\n" ++
215 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
216 " :quit exit GHCi\n" ++
217 " :reload reload the current module set\n" ++
218 " :run function [<arguments> ...] run the function with the given arguments\n" ++
219 " :type <expr> show the type of <expr>\n" ++
220 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
221 " :!<command> run the shell command <command>\n" ++
223 " -- Commands for debugging:\n" ++
225 " :abandon at a breakpoint, abandon current computation\n" ++
226 " :back go back in the history (after :trace)\n" ++
227 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
228 " :break <name> set a breakpoint on the specified function\n" ++
229 " :continue resume after a breakpoint\n" ++
230 " :delete <number> delete the specified breakpoint\n" ++
231 " :delete * delete all breakpoints\n" ++
232 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
233 " :forward go forward in the history (after :back)\n" ++
234 " :history [<n>] after :trace, show the execution history\n" ++
235 " :list show the source code around current breakpoint\n" ++
236 " :list identifier show the source code for <identifier>\n" ++
237 " :list [<module>] <line> show the source code around line number <line>\n" ++
238 " :print [<name> ...] prints a value without forcing its computation\n" ++
239 " :sprint [<name> ...] simplifed version of :print\n" ++
240 " :step single-step after stopping at a breakpoint\n"++
241 " :step <expr> single-step into <expr>\n"++
242 " :steplocal single-step within the current top-level binding\n"++
243 " :stepmodule single-step restricted to the current module\n"++
244 " :trace trace after stopping at a breakpoint\n"++
245 " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++
248 " -- Commands for changing settings:\n" ++
250 " :set <option> ... set options\n" ++
251 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
252 " :set prog <progname> set the value returned by System.getProgName\n" ++
253 " :set prompt <prompt> set the prompt used in GHCi\n" ++
254 " :set editor <cmd> set the command used for :edit\n" ++
255 " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" ++
256 " :unset <option> ... unset options\n" ++
258 " Options for ':set' and ':unset':\n" ++
260 " +r revert top-level expressions after each evaluation\n" ++
261 " +s print timing/memory stats after each evaluation\n" ++
262 " +t print type after evaluation\n" ++
263 " -<flags> most GHC command line flags can also be set here\n" ++
264 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
265 " for GHCi-specific flags, see User's Guide,\n"++
266 " Flag reference, Interactive-mode options\n" ++
268 " -- Commands for displaying information:\n" ++
270 " :show bindings show the current bindings made at the prompt\n" ++
271 " :show breaks show the active breakpoints\n" ++
272 " :show context show the breakpoint context\n" ++
273 " :show modules show the currently loaded modules\n" ++
274 " :show packages show the currently active package flags\n" ++
275 " :show languages show the currently active language flags\n" ++
276 " :show <setting> show value of <setting>, which is one of\n" ++
277 " [args, prog, prompt, editor, stop]\n" ++
280 findEditor :: IO String
285 win <- System.Win32.getWindowsDirectory
286 return (win </> "notepad.exe")
291 foreign import ccall unsafe "rts_isProfiled" isProfiled :: IO CInt
293 default_progname, default_prompt, default_stop :: String
294 default_progname = "<interactive>"
295 default_prompt = "%s> "
298 default_args :: [String]
301 interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String]
303 interactiveUI srcs maybe_exprs = do
304 -- although GHCi compiles with -prof, it is not usable: the byte-code
305 -- compiler and interpreter don't work with profiling. So we check for
306 -- this up front and emit a helpful error message (#2197)
307 i <- liftIO $ isProfiled
309 ghcError (InstallationError "GHCi cannot be used when compiled with -prof")
311 -- HACK! If we happen to get into an infinite loop (eg the user
312 -- types 'let x=x in x' at the prompt), then the thread will block
313 -- on a blackhole, and become unreachable during GC. The GC will
314 -- detect that it is unreachable and send it the NonTermination
315 -- exception. However, since the thread is unreachable, everything
316 -- it refers to might be finalized, including the standard Handles.
317 -- This sounds like a bug, but we don't have a good solution right
319 _ <- liftIO $ newStablePtr stdin
320 _ <- liftIO $ newStablePtr stdout
321 _ <- liftIO $ newStablePtr stderr
323 -- Initialise buffering for the *interpreted* I/O system
326 liftIO $ when (isNothing maybe_exprs) $ do
327 -- Only for GHCi (not runghc and ghc -e):
329 -- Turn buffering off for the compiled program's stdout/stderr
331 -- Turn buffering off for GHCi's stdout
333 hSetBuffering stdout NoBuffering
334 -- We don't want the cmd line to buffer any input that might be
335 -- intended for the program, so unbuffer stdin.
336 hSetBuffering stdin NoBuffering
337 #if defined(mingw32_HOST_OS)
338 -- On Unix, stdin will use the locale encoding. The IO library
339 -- doesn't do this on Windows (yet), so for now we use UTF-8,
340 -- for consistency with GHC 6.10 and to make the tests work.
341 hSetEncoding stdin utf8
344 -- initial context is just the Prelude
345 prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing
346 GHC.setContext [] [(prel_mod, Nothing)]
348 default_editor <- liftIO $ findEditor
350 startGHCi (runGHCi srcs maybe_exprs)
351 GHCiState{ progname = default_progname,
353 prompt = default_prompt,
355 editor = default_editor,
356 -- session = session,
361 tickarrays = emptyModuleEnv,
362 last_command = Nothing,
365 ghc_e = isJust maybe_exprs
370 withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
371 withGhcAppData right left = do
372 either_dir <- tryIO (getAppUserDataDirectory "ghc")
375 do createDirectoryIfMissing False dir `catchIO` \_ -> return ()
379 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
380 runGHCi paths maybe_exprs = do
382 read_dot_files = not opt_IgnoreDotGhci
384 current_dir = return (Just ".ghci")
386 app_user_dir = liftIO $ withGhcAppData
387 (\dir -> return (Just (dir </> "ghci.conf")))
391 either_dir <- liftIO $ tryIO (getEnv "HOME")
393 Right home -> return (Just (home </> ".ghci"))
396 canonicalizePath' :: FilePath -> IO (Maybe FilePath)
397 canonicalizePath' fp = liftM Just (canonicalizePath fp)
398 `catchIO` \_ -> return Nothing
400 sourceConfigFile :: FilePath -> GHCi ()
401 sourceConfigFile file = do
402 exists <- liftIO $ doesFileExist file
404 dir_ok <- liftIO $ checkPerms (getDirectory file)
405 file_ok <- liftIO $ checkPerms file
406 when (dir_ok && file_ok) $ do
407 either_hdl <- liftIO $ tryIO (openFile file ReadMode)
410 -- NOTE: this assumes that runInputT won't affect the terminal;
411 -- can we assume this will always be the case?
412 -- This would be a good place for runFileInputT.
414 do runInputTWithPrefs defaultPrefs defaultSettings $
415 runCommands $ fileLoop hdl
416 liftIO (hClose hdl `catchIO` \_ -> return ())
418 getDirectory f = case takeDirectory f of "" -> "."; d -> d
420 when (read_dot_files) $ do
421 mcfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
422 mcfgs <- liftIO $ mapM canonicalizePath' (catMaybes mcfgs0)
423 mapM_ sourceConfigFile $ nub $ catMaybes mcfgs
424 -- nub, because we don't want to read .ghci twice if the
427 -- Perform a :load for files given on the GHCi command line
428 -- When in -e mode, if the load fails then we want to stop
429 -- immediately rather than going on to evaluate the expression.
430 when (not (null paths)) $ do
431 ok <- ghciHandle (\e -> do showException e; return Failed) $
432 -- TODO: this is a hack.
433 runInputTWithPrefs defaultPrefs defaultSettings $ do
434 let (filePaths, phases) = unzip paths
435 filePaths' <- mapM (Encoding.decode . BS.pack) filePaths
436 loadModule (zip filePaths' phases)
437 when (isJust maybe_exprs && failed ok) $
438 liftIO (exitWith (ExitFailure 1))
440 -- if verbosity is greater than 0, or we are connected to a
441 -- terminal, display the prompt in the interactive loop.
442 is_tty <- liftIO (hIsTerminalDevice stdin)
443 dflags <- getDynFlags
444 let show_prompt = verbosity dflags > 0 || is_tty
449 -- enter the interactive loop
450 runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
452 -- just evaluate the expression we were given
453 enqueueCommands exprs
454 let handle e = do st <- getGHCiState
455 -- flush the interpreter's stdout/stderr on exit (#3890)
457 -- Jump through some hoops to get the
458 -- current progname in the exception text:
459 -- <progname>: <exception>
460 liftIO $ withProgName (progname st)
461 -- this used to be topHandlerFastExit, see #2228
463 runInputTWithPrefs defaultPrefs defaultSettings $ do
464 runCommands' handle (return Nothing)
467 liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
469 runGHCiInput :: InputT GHCi a -> GHCi a
471 histFile <- liftIO $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
473 let settings = setComplete ghciCompleteWord
474 $ defaultSettings {historyFile = histFile}
477 nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
478 nextInputLine show_prompt is_tty
480 prompt <- if show_prompt then lift mkPrompt else return ""
483 when show_prompt $ lift mkPrompt >>= liftIO . putStr
486 -- NOTE: We only read .ghci files if they are owned by the current user,
487 -- and aren't world writable. Otherwise, we could be accidentally
488 -- running code planted by a malicious third party.
490 -- Furthermore, We only read ./.ghci if . is owned by the current user
491 -- and isn't writable by anyone else. I think this is sufficient: we
492 -- don't need to check .. and ../.. etc. because "." always refers to
493 -- the same directory while a process is running.
495 checkPerms :: String -> IO Bool
496 #ifdef mingw32_HOST_OS
501 handleIO (\_ -> return False) $ do
502 st <- getFileStatus name
504 if fileOwner st /= me then do
505 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
508 let mode = System.Posix.fileMode st
509 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
510 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
512 putStrLn $ "*** WARNING: " ++ name ++
513 " is writable by someone else, IGNORING!"
518 fileLoop :: MonadIO m => Handle -> InputT m (Maybe String)
520 l <- liftIO $ tryIO $ hGetLine hdl
522 Left e | isEOFError e -> return Nothing
523 | InvalidArgument <- etype -> return Nothing
524 | otherwise -> liftIO $ ioError e
525 where etype = ioeGetErrorType e
526 -- treat InvalidArgument in the same way as EOF:
527 -- this can happen if the user closed stdin, or
528 -- perhaps did getContents which closes stdin at
530 Right l -> return (Just l)
532 mkPrompt :: GHCi String
534 (toplevs,exports) <- GHC.getContext
535 resumes <- GHC.getResumeContext
536 -- st <- getGHCiState
542 let ix = GHC.resumeHistoryIx r
544 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
546 let hist = GHC.resumeHistory r !! (ix-1)
547 span <- GHC.getHistorySpan hist
548 return (brackets (ppr (negate ix) <> char ':'
549 <+> ppr span) <> space)
551 dots | _:rs <- resumes, not (null rs) = text "... "
556 -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
557 -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
558 -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
559 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
560 hsep (map (ppr . GHC.moduleName) (nub (map fst exports)))
562 deflt_prompt = dots <> context_bit <> modules_bit
564 f ('%':'s':xs) = deflt_prompt <> f xs
565 f ('%':'%':xs) = char '%' <> f xs
566 f (x:xs) = char x <> f xs
570 return (showSDoc (f (prompt st)))
573 queryQueue :: GHCi (Maybe String)
578 c:cs -> do setGHCiState st{ cmdqueue = cs }
581 runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
582 runCommands = runCommands' handler
584 runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
585 -> InputT GHCi (Maybe String) -> InputT GHCi ()
586 runCommands' eh getCmd = do
587 b <- ghandle (\e -> case fromException e of
588 Just UserInterrupt -> return False
589 _ -> case fromException e of
591 do liftIO (print (ghc_e :: GhcException))
594 liftIO (Exception.throwIO e))
595 (runOneCommand eh getCmd)
596 if b then return () else runCommands' eh getCmd
598 runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
600 runOneCommand eh getCmd = do
601 mb_cmd <- noSpace (lift queryQueue)
602 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
604 Nothing -> return True
605 Just c -> ghciHandle (lift . eh) $
606 handleSourceError printErrorAndKeepGoing
609 printErrorAndKeepGoing err = do
610 GHC.printException err
613 noSpace q = q >>= maybe (return Nothing)
614 (\c->case removeSpaces c of
616 ":{" -> multiLineCmd q
617 c -> return (Just c) )
619 st <- lift getGHCiState
621 lift $ setGHCiState st{ prompt = "%s| " }
622 mb_cmd <- collectCommand q ""
623 lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p }
625 -- we can't use removeSpaces for the sublines here, so
626 -- multiline commands are somewhat more brittle against
627 -- fileformat errors (such as \r in dos input on unix),
628 -- we get rid of any extra spaces for the ":}" test;
629 -- we also avoid silent failure if ":}" is not found;
630 -- and since there is no (?) valid occurrence of \r (as
631 -- opposed to its String representation, "\r") inside a
632 -- ghci command, we replace any such with ' ' (argh:-(
633 collectCommand q c = q >>=
634 maybe (liftIO (ioError collectError))
635 (\l->if removeSpaces l == ":}"
636 then return (Just $ removeSpaces c)
637 else collectCommand q (c ++ "\n" ++ map normSpace l))
638 where normSpace '\r' = ' '
640 -- QUESTION: is userError the one to use here?
641 collectError = userError "unterminated multiline command :{ .. :}"
642 doCommand (':' : cmd) = specialCommand cmd
643 doCommand stmt = do _ <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion
646 enqueueCommands :: [String] -> GHCi ()
647 enqueueCommands cmds = do
649 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
652 runStmt :: String -> SingleStep -> GHCi Bool
654 | null (filter (not.isSpace) stmt)
656 | "import " `isPrefixOf` stmt
657 = do newContextCmd (Import stmt); return False
659 = do -- In the new IO library, read handles buffer data even if the Handle
660 -- is set to NoBuffering. This causes problems for GHCi where there
661 -- are really two stdin Handles. So we flush any bufferred data in
662 -- GHCi's stdin Handle here (only relevant if stdin is attached to
663 -- a file, otherwise the read buffer can't be flushed).
664 _ <- liftIO $ tryIO $ hFlushAll stdin
665 result <- GhciMonad.runStmt stmt step
666 afterRunStmt (const True) result
668 --afterRunStmt :: GHC.RunResult -> GHCi Bool
669 -- False <=> the statement failed to compile
670 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
671 afterRunStmt _ (GHC.RunException e) = throw e
672 afterRunStmt step_here run_result = do
673 resumes <- GHC.getResumeContext
675 GHC.RunOk names -> do
676 show_types <- isOptionSet ShowType
677 when show_types $ printTypeOfNames names
678 GHC.RunBreak _ names mb_info
679 | isNothing mb_info ||
680 step_here (GHC.resumeSpan $ head resumes) -> do
681 mb_id_loc <- toBreakIdAndLocation mb_info
682 let breakCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
684 then printStoppedAtBreakInfo (head resumes) names
685 else enqueueCommands [breakCmd]
686 -- run the command set with ":set stop <cmd>"
688 enqueueCommands [stop st]
690 | otherwise -> resume step_here GHC.SingleStep >>=
691 afterRunStmt step_here >> return ()
695 liftIO installSignalHandlers
696 b <- isOptionSet RevertCAFs
699 return (case run_result of GHC.RunOk _ -> True; _ -> False)
701 toBreakIdAndLocation ::
702 Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
703 toBreakIdAndLocation Nothing = return Nothing
704 toBreakIdAndLocation (Just info) = do
705 let mod = GHC.breakInfo_module info
706 nm = GHC.breakInfo_number info
708 return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
709 breakModule loc == mod,
710 breakTick loc == nm ]
712 printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
713 printStoppedAtBreakInfo resume names = do
714 printForUser $ ptext (sLit "Stopped at") <+>
715 ppr (GHC.resumeSpan resume)
716 -- printTypeOfNames session names
717 let namesSorted = sortBy compareNames names
718 tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
719 docs <- pprTypeAndContents [id | AnId id <- tythings]
720 printForUserPartWay docs
722 printTypeOfNames :: [Name] -> GHCi ()
723 printTypeOfNames names
724 = mapM_ (printTypeOfName ) $ sortBy compareNames names
726 compareNames :: Name -> Name -> Ordering
727 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
728 where compareWith n = (getOccString n, getSrcSpan n)
730 printTypeOfName :: Name -> GHCi ()
732 = do maybe_tything <- GHC.lookupName n
733 case maybe_tything of
735 Just thing -> printTyThing thing
738 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
740 specialCommand :: String -> InputT GHCi Bool
741 specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
742 specialCommand str = do
743 let (cmd,rest) = break isSpace str
744 maybe_cmd <- lift $ lookupCommand cmd
746 GotCommand (_,f,_) -> f (dropWhile isSpace rest)
748 do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
752 do liftIO $ hPutStr stdout ("there is no last command to perform\n"
756 lookupCommand :: String -> GHCi (MaybeCommand)
757 lookupCommand "" = do
759 case last_command st of
760 Just c -> return $ GotCommand c
761 Nothing -> return NoLastCommand
762 lookupCommand str = do
763 mc <- liftIO $ lookupCommand' str
765 setGHCiState st{ last_command = mc }
767 Just c -> GotCommand c
768 Nothing -> BadCommand
770 lookupCommand' :: String -> IO (Maybe Command)
771 lookupCommand' ":" = return Nothing
772 lookupCommand' str' = do
773 macros <- readIORef macros_ref
774 let{ (str, cmds) = case str' of
775 ':' : rest -> (rest, builtin_commands)
776 _ -> (str', macros ++ builtin_commands) }
777 -- look for exact match first, then the first prefix match
778 return $ case [ c | c <- cmds, str == cmdName c ] of
780 [] -> case [ c | c@(s,_,_) <- cmds, str `isPrefixOf` s ] of
784 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
785 getCurrentBreakSpan = do
786 resumes <- GHC.getResumeContext
790 let ix = GHC.resumeHistoryIx r
792 then return (Just (GHC.resumeSpan r))
794 let hist = GHC.resumeHistory r !! (ix-1)
795 span <- GHC.getHistorySpan hist
798 getCurrentBreakModule :: GHCi (Maybe Module)
799 getCurrentBreakModule = do
800 resumes <- GHC.getResumeContext
804 let ix = GHC.resumeHistoryIx r
806 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
808 let hist = GHC.resumeHistory r !! (ix-1)
809 return $ Just $ GHC.getHistoryModule hist
811 -----------------------------------------------------------------------------
814 noArgs :: GHCi () -> String -> GHCi ()
816 noArgs _ _ = liftIO $ putStrLn "This command takes no arguments"
818 help :: String -> GHCi ()
819 help _ = liftIO (putStr helpText)
821 info :: String -> InputT GHCi ()
822 info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
823 info s = handleSourceError GHC.printException $
824 do { let names = words s
825 ; dflags <- getDynFlags
826 ; let pefas = dopt Opt_PrintExplicitForalls dflags
827 ; mapM_ (infoThing pefas) names }
829 infoThing pefas str = do
830 names <- GHC.parseName str
831 mb_stuffs <- mapM GHC.getInfo names
832 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
833 unqual <- GHC.getPrintUnqual
834 liftIO $ putStrLn $ showSDocForUser unqual $
835 vcat (intersperse (text "") $
836 map (pprInfo pefas) filtered)
838 -- Filter out names whose parent is also there Good
839 -- example is '[]', which is both a type and data
840 -- constructor in the same type
841 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
842 filterOutChildren get_thing xs
843 = filterOut has_parent xs
845 all_names = mkNameSet (map (getName . get_thing) xs)
846 has_parent x = case pprTyThingParent_maybe (get_thing x) of
847 Just p -> getName p `elemNameSet` all_names
850 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
851 pprInfo pefas (thing, fixity, insts)
852 = pprTyThingInContextLoc pefas thing
853 $$ show_fixity fixity
854 $$ vcat (map GHC.pprInstance insts)
857 | fix == GHC.defaultFixity = empty
858 | otherwise = ppr fix <+> ppr (GHC.getName thing)
860 runMain :: String -> GHCi ()
861 runMain s = case toArgs s of
862 Left err -> liftIO (hPutStrLn stderr err)
864 do dflags <- getDynFlags
865 case mainFunIs dflags of
866 Nothing -> doWithArgs args "main"
867 Just f -> doWithArgs args f
869 runRun :: String -> GHCi ()
870 runRun s = case toCmdArgs s of
871 Left err -> liftIO (hPutStrLn stderr err)
872 Right (cmd, args) -> doWithArgs args cmd
874 doWithArgs :: [String] -> String -> GHCi ()
875 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
876 show args ++ " (" ++ cmd ++ ")"]
878 addModule :: [FilePath] -> InputT GHCi ()
880 lift revertCAFs -- always revert CAFs on load/add.
881 files <- mapM expandPath files
882 targets <- mapM (\m -> GHC.guessTarget m Nothing) files
883 -- remove old targets with the same id; e.g. for :add *M
884 mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
885 mapM_ GHC.addTarget targets
886 prev_context <- GHC.getContext
887 ok <- trySuccess $ GHC.load LoadAllTargets
888 afterLoad ok False prev_context
890 changeDirectory :: String -> InputT GHCi ()
891 changeDirectory "" = do
892 -- :cd on its own changes to the user's home directory
893 either_dir <- liftIO $ tryIO getHomeDirectory
896 Right dir -> changeDirectory dir
897 changeDirectory dir = do
898 graph <- GHC.getModuleGraph
899 when (not (null graph)) $
900 liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."
901 prev_context <- GHC.getContext
903 _ <- GHC.load LoadAllTargets
904 lift $ setContextAfterLoad prev_context False []
905 GHC.workingDirectoryChanged
906 dir <- expandPath dir
907 liftIO $ setCurrentDirectory dir
909 trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
911 handleSourceError (\e -> do GHC.printException e
915 editFile :: String -> GHCi ()
917 do file <- if null str then chooseEditFile else return str
921 $ ghcError (CmdLineError "editor not set, use :set editor")
922 _ <- liftIO $ system (cmd ++ ' ':file)
925 -- The user didn't specify a file so we pick one for them.
926 -- Our strategy is to pick the first module that failed to load,
927 -- or otherwise the first target.
929 -- XXX: Can we figure out what happened if the depndecy analysis fails
930 -- (e.g., because the porgrammeer mistyped the name of a module)?
931 -- XXX: Can we figure out the location of an error to pass to the editor?
932 -- XXX: if we could figure out the list of errors that occured during the
933 -- last load/reaload, then we could start the editor focused on the first
935 chooseEditFile :: GHCi String
937 do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
939 graph <- GHC.getModuleGraph
940 failed_graph <- filterM hasFailed graph
941 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
943 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
946 case pick (order failed_graph) of
947 Just file -> return file
949 do targets <- GHC.getTargets
950 case msum (map fromTarget targets) of
951 Just file -> return file
952 Nothing -> ghcError (CmdLineError "No files to edit.")
954 where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
955 fromTarget _ = Nothing -- when would we get a module target?
957 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
958 defineMacro _ (':':_) =
959 liftIO $ putStrLn "macro name cannot start with a colon"
960 defineMacro overwrite s = do
961 let (macro_name, definition) = break isSpace s
962 macros <- liftIO (readIORef macros_ref)
963 let defined = map cmdName macros
966 then liftIO $ putStrLn "no macros defined"
967 else liftIO $ putStr ("the following macros are defined:\n" ++
970 if (not overwrite && macro_name `elem` defined)
971 then ghcError (CmdLineError
972 ("macro '" ++ macro_name ++ "' is already defined"))
975 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
977 -- give the expression a type signature, so we can be sure we're getting
978 -- something of the right type.
979 let new_expr = '(' : definition ++ ") :: String -> IO String"
981 -- compile the expression
982 handleSourceError (\e -> GHC.printException e) $
984 hv <- GHC.compileExpr new_expr
985 liftIO (writeIORef macros_ref --
986 (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)]))
988 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
990 str <- liftIO ((unsafeCoerce# fun :: String -> IO String) s)
991 -- make sure we force any exceptions in the result, while we are still
992 -- inside the exception handler for commands:
993 seqList str (return ())
994 enqueueCommands (lines str)
997 undefineMacro :: String -> GHCi ()
998 undefineMacro str = mapM_ undef (words str)
999 where undef macro_name = do
1000 cmds <- liftIO (readIORef macros_ref)
1001 if (macro_name `notElem` map cmdName cmds)
1002 then ghcError (CmdLineError
1003 ("macro '" ++ macro_name ++ "' is not defined"))
1005 liftIO (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
1007 cmdCmd :: String -> GHCi ()
1009 let expr = '(' : str ++ ") :: IO String"
1010 handleSourceError (\e -> GHC.printException e) $
1012 hv <- GHC.compileExpr expr
1013 cmds <- liftIO $ (unsafeCoerce# hv :: IO String)
1014 enqueueCommands (lines cmds)
1017 loadModuleName :: GHC.GhcMonad m => ImportDecl RdrName -> m Module
1018 loadModuleName = flip GHC.findModule Nothing . unLoc . ideclName
1020 loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
1021 loadModule fs = timeIt (loadModule' fs)
1023 loadModule_ :: [FilePath] -> InputT GHCi ()
1024 loadModule_ fs = loadModule (zip fs (repeat Nothing)) >> return ()
1026 loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
1027 loadModule' files = do
1028 prev_context <- GHC.getContext
1032 lift discardActiveBreakPoints
1034 _ <- GHC.load LoadAllTargets
1036 let (filenames, phases) = unzip files
1037 exp_filenames <- mapM expandPath filenames
1038 let files' = zip exp_filenames phases
1039 targets <- mapM (uncurry GHC.guessTarget) files'
1041 -- NOTE: we used to do the dependency anal first, so that if it
1042 -- fails we didn't throw away the current set of modules. This would
1043 -- require some re-working of the GHC interface, so we'll leave it
1044 -- as a ToDo for now.
1046 GHC.setTargets targets
1047 doLoad False prev_context LoadAllTargets
1049 checkModule :: String -> InputT GHCi ()
1051 let modl = GHC.mkModuleName m
1052 prev_context <- GHC.getContext
1053 ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do
1054 r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
1055 liftIO $ putStrLn $ showSDoc $
1056 case GHC.moduleInfo r of
1057 cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1059 (local,global) = ASSERT( all isExternalName scope )
1060 partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1062 (text "global names: " <+> ppr global) $$
1063 (text "local names: " <+> ppr local)
1066 afterLoad (successIf ok) False prev_context
1068 reloadModule :: String -> InputT GHCi ()
1070 prev_context <- GHC.getContext
1071 _ <- doLoad True prev_context $
1072 if null m then LoadAllTargets
1073 else LoadUpTo (GHC.mkModuleName m)
1076 doLoad :: Bool -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> LoadHowMuch -> InputT GHCi SuccessFlag
1077 doLoad retain_context prev_context howmuch = do
1078 -- turn off breakpoints before we load: we can't turn them off later, because
1079 -- the ModBreaks will have gone away.
1080 lift discardActiveBreakPoints
1081 ok <- trySuccess $ GHC.load howmuch
1082 afterLoad ok retain_context prev_context
1085 afterLoad :: SuccessFlag -> Bool -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> InputT GHCi ()
1086 afterLoad ok retain_context prev_context = do
1087 lift revertCAFs -- always revert CAFs on load.
1088 lift discardTickArrays
1089 loaded_mod_summaries <- getLoadedModules
1090 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1091 loaded_mod_names = map GHC.moduleName loaded_mods
1092 modulesLoadedMsg ok loaded_mod_names
1094 lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
1097 setContextAfterLoad :: ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> Bool -> [GHC.ModSummary] -> GHCi ()
1098 setContextAfterLoad prev keep_ctxt [] = do
1099 prel_mod <- getPrelude
1100 setContextKeepingPackageModules prev keep_ctxt ([], [(prel_mod, Nothing)])
1101 setContextAfterLoad prev keep_ctxt ms = do
1102 -- load a target if one is available, otherwise load the topmost module.
1103 targets <- GHC.getTargets
1104 case [ m | Just m <- map (findTarget ms) targets ] of
1106 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1107 load_this (last graph')
1112 = case filter (`matches` t) ms of
1116 summary `matches` Target (TargetModule m) _ _
1117 = GHC.ms_mod_name summary == m
1118 summary `matches` Target (TargetFile f _) _ _
1119 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1123 load_this summary | m <- GHC.ms_mod summary = do
1124 b <- GHC.moduleIsInterpreted m
1125 if b then setContextKeepingPackageModules prev keep_ctxt ([m], [])
1127 prel_mod <- getPrelude
1128 setContextKeepingPackageModules prev keep_ctxt ([],[(prel_mod,Nothing),(m,Nothing)])
1130 -- | Keep any package modules (except Prelude) when changing the context.
1131 setContextKeepingPackageModules
1132 :: ([Module],[(Module, Maybe (ImportDecl RdrName))]) -- previous context
1133 -> Bool -- re-execute :module commands
1134 -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -- new context
1136 setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do
1137 let (_,bs0) = prev_context
1138 prel_mod <- getPrelude
1139 -- filter everything, not just lefts
1140 let pkg_modules = filter ((\p -> not (isHomeModule p) && p /= prel_mod) . fst) bs0
1141 let bs1 = if null as then nubBy sameFst ((prel_mod,Nothing) : bs) else bs
1142 GHC.setContext as (nubBy sameFst (bs1 ++ pkg_modules))
1146 mapM_ (playCtxtCmd False) (remembered_ctx st)
1149 setGHCiState st{ remembered_ctx = [] }
1151 isHomeModule :: Module -> Bool
1152 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1154 sameFst :: (Module, Maybe (ImportDecl RdrName)) -> (Module, Maybe (ImportDecl RdrName)) -> Bool
1155 sameFst x y = fst x == fst y
1157 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi ()
1158 modulesLoadedMsg ok mods = do
1159 dflags <- getDynFlags
1160 when (verbosity dflags > 0) $ do
1162 | null mods = text "none."
1163 | otherwise = hsep (
1164 punctuate comma (map ppr mods)) <> text "."
1167 liftIO $ putStrLn $ showSDoc (text "Failed, modules loaded: " <> mod_commas)
1169 liftIO $ putStrLn $ showSDoc (text "Ok, modules loaded: " <> mod_commas)
1172 typeOfExpr :: String -> InputT GHCi ()
1174 = handleSourceError GHC.printException
1176 ty <- GHC.exprType str
1177 dflags <- getDynFlags
1178 let pefas = dopt Opt_PrintExplicitForalls dflags
1179 printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]
1181 kindOfType :: String -> InputT GHCi ()
1183 = handleSourceError GHC.printException
1185 ty <- GHC.typeKind str
1186 printForUser $ text str <+> dcolon <+> ppr ty
1188 quit :: String -> InputT GHCi Bool
1189 quit _ = return True
1191 shellEscape :: String -> GHCi Bool
1192 shellEscape str = liftIO (system str >> return False)
1194 -----------------------------------------------------------------------------
1195 -- Browsing a module's contents
1197 browseCmd :: Bool -> String -> InputT GHCi ()
1200 ['*':s] | looksLikeModuleName s -> do
1201 m <- lift $ wantInterpretedModule s
1202 browseModule bang m False
1203 [s] | looksLikeModuleName s -> do
1204 m <- lift $ lookupModule s
1205 browseModule bang m True
1207 (as,bs) <- GHC.getContext
1208 -- Guess which module the user wants to browse. Pick
1209 -- modules that are interpreted first. The most
1210 -- recently-added module occurs last, it seems.
1212 (as@(_:_), _) -> browseModule bang (last as) True
1213 ([], bs@(_:_)) -> browseModule bang (fst (last bs)) True
1214 ([], []) -> ghcError (CmdLineError ":browse: no current module")
1215 _ -> ghcError (CmdLineError "syntax: :browse <module>")
1217 -- without bang, show items in context of their parents and omit children
1218 -- with bang, show class methods and data constructors separately, and
1219 -- indicate import modules, to aid qualifying unqualified names
1220 -- with sorted, sort items alphabetically
1221 browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
1222 browseModule bang modl exports_only = do
1223 -- :browse! reports qualifiers wrt current context
1224 current_unqual <- GHC.getPrintUnqual
1225 -- Temporarily set the context to the module we're interested in,
1226 -- just so we can get an appropriate PrintUnqualified
1227 (as,bs) <- GHC.getContext
1228 prel_mod <- lift getPrelude
1229 if exports_only then GHC.setContext [] [(prel_mod,Nothing), (modl,Nothing)]
1230 else GHC.setContext [modl] []
1231 target_unqual <- GHC.getPrintUnqual
1232 GHC.setContext as bs
1234 let unqual = if bang then current_unqual else target_unqual
1236 mb_mod_info <- GHC.getModuleInfo modl
1238 Nothing -> ghcError (CmdLineError ("unknown module: " ++
1239 GHC.moduleNameString (GHC.moduleName modl)))
1241 dflags <- getDynFlags
1243 | exports_only = GHC.modInfoExports mod_info
1244 | otherwise = GHC.modInfoTopLevelScope mod_info
1247 -- sort alphabetically name, but putting
1248 -- locally-defined identifiers first.
1249 -- We would like to improve this; see #1799.
1250 sorted_names = loc_sort local ++ occ_sort external
1252 (local,external) = ASSERT( all isExternalName names )
1253 partition ((==modl) . nameModule) names
1254 occ_sort = sortBy (compare `on` nameOccName)
1255 -- try to sort by src location. If the first name in
1256 -- our list has a good source location, then they all should.
1258 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1259 = sortBy (compare `on` nameSrcSpan) names
1263 mb_things <- mapM GHC.lookupName sorted_names
1264 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1266 rdr_env <- GHC.getGRE
1268 let pefas = dopt Opt_PrintExplicitForalls dflags
1269 things | bang = catMaybes mb_things
1270 | otherwise = filtered_things
1271 pretty | bang = pprTyThing
1272 | otherwise = pprTyThingInContext
1274 labels [] = text "-- not currently imported"
1275 labels l = text $ intercalate "\n" $ map qualifier l
1276 qualifier = maybe "-- defined locally"
1277 (("-- imported via "++) . intercalate ", "
1278 . map GHC.moduleNameString)
1279 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1280 modNames = map (importInfo . GHC.getName) things
1282 -- annotate groups of imports with their import modules
1283 -- the default ordering is somewhat arbitrary, so we group
1284 -- by header and sort groups; the names themselves should
1285 -- really come in order of source appearance.. (trac #1799)
1286 annotate mts = concatMap (\(m,ts)->labels m:ts)
1287 $ sortBy cmpQualifiers $ group mts
1288 where cmpQualifiers =
1289 compare `on` (map (fmap (map moduleNameFS)) . fst)
1291 group mts@((m,_):_) = (m,map snd g) : group ng
1292 where (g,ng) = partition ((==m).fst) mts
1294 let prettyThings = map (pretty pefas) things
1295 prettyThings' | bang = annotate $ zip modNames prettyThings
1296 | otherwise = prettyThings
1297 liftIO $ putStrLn $ showSDocForUser unqual (vcat prettyThings')
1298 -- ToDo: modInfoInstances currently throws an exception for
1299 -- package modules. When it works, we can do this:
1300 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1302 -----------------------------------------------------------------------------
1303 -- Setting the module context
1305 newContextCmd :: CtxtCmd -> GHCi ()
1306 newContextCmd cmd = do
1307 playCtxtCmd True cmd
1309 let cmds = remembered_ctx st
1310 setGHCiState st{ remembered_ctx = cmds ++ [cmd] }
1312 setContext :: String -> GHCi ()
1314 | all sensible strs = newContextCmd cmd
1315 | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1319 '+':stuff -> rest AddModules stuff
1320 '-':stuff -> rest RemModules stuff
1321 stuff -> rest SetContext stuff
1323 rest cmd stuff = (cmd as bs, strs)
1324 where strs = words stuff
1325 (as,bs) = partitionWith starred strs
1327 sensible ('*':m) = looksLikeModuleName m
1328 sensible m = looksLikeModuleName m
1330 starred ('*':m) = Left m
1333 playCtxtCmd:: Bool -> CtxtCmd -> GHCi ()
1334 playCtxtCmd fail cmd = do
1335 (prev_as,prev_bs) <- GHC.getContext
1337 SetContext as bs -> do
1338 (as',bs') <- do_checks as bs
1339 prel_mod <- getPrelude
1340 let bs'' = if null as && prel_mod `notElem` (map fst bs')
1341 then (prel_mod,Nothing):bs'
1343 GHC.setContext as' bs''
1345 AddModules as bs -> do
1346 (as',bs') <- do_checks as bs
1347 -- it should replace the old stuff, not the other way around
1348 -- need deleteAllBy, not deleteFirstsBy for sameFst
1349 let remaining_as = prev_as \\ (as' ++ map fst bs')
1350 remaining_bs = deleteAllBy sameFst prev_bs (bs' ++ map contextualize as')
1351 GHC.setContext (remaining_as ++ as') (remaining_bs ++ bs')
1353 RemModules as bs -> do
1354 (as',bs') <- do_checks as bs
1355 let new_as = prev_as \\ (as' ++ map fst bs')
1356 new_bs = deleteAllBy sameFst prev_bs (map contextualize as' ++ bs')
1357 GHC.setContext new_as new_bs
1360 m_idecl <- maybe_fail $ GHC.parseImportDecl str
1362 Nothing -> return ()
1364 m_mdl <- maybe_fail $ loadModuleName idecl
1366 Nothing -> return ()
1367 Just m -> GHC.setContext prev_as (prev_bs ++ [(m, Just idecl)])
1370 maybe_fail | fail = liftM Just
1371 | otherwise = trymaybe
1373 do_checks as bs = do
1374 as' <- mapM (maybe_fail . wantInterpretedModule) as
1375 bs' <- mapM (maybe_fail . lookupModule) bs
1376 return (catMaybes as', map contextualize (catMaybes bs'))
1378 contextualize x = (x,Nothing)
1379 deleteAllBy f a b = filter (\x->(not (any (f x) b))) a
1381 trymaybe ::GHCi a -> GHCi (Maybe a)
1385 Left _ -> return Nothing
1386 Right a -> return (Just a)
1388 ----------------------------------------------------------------------------
1391 -- set options in the interpreter. Syntax is exactly the same as the
1392 -- ghc command line, except that certain options aren't available (-C,
1395 -- This is pretty fragile: most options won't work as expected. ToDo:
1396 -- figure out which ones & disallow them.
1398 setCmd :: String -> GHCi ()
1400 = do st <- getGHCiState
1401 let opts = options st
1402 liftIO $ putStrLn (showSDoc (
1403 text "options currently set: " <>
1406 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1408 dflags <- getDynFlags
1409 liftIO $ putStrLn (showSDoc (
1410 vcat (text "GHCi-specific dynamic flag settings:"
1411 :map (flagSetting dflags) ghciFlags)
1413 liftIO $ putStrLn (showSDoc (
1414 vcat (text "other dynamic, non-language, flag settings:"
1415 :map (flagSetting dflags) others)
1417 where flagSetting dflags (str, f, _)
1418 | dopt f dflags = text " " <> text "-f" <> text str
1419 | otherwise = text " " <> text "-fno-" <> text str
1420 (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags)
1422 flags = [Opt_PrintExplicitForalls
1423 ,Opt_PrintBindResult
1424 ,Opt_BreakOnException
1426 ,Opt_PrintEvldWithShow
1429 = case getCmd str of
1430 Right ("args", rest) ->
1432 Left err -> liftIO (hPutStrLn stderr err)
1433 Right args -> setArgs args
1434 Right ("prog", rest) ->
1436 Right [prog] -> setProg prog
1437 _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")
1438 Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1439 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1440 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1441 _ -> case toArgs str of
1442 Left err -> liftIO (hPutStrLn stderr err)
1443 Right wds -> setOptions wds
1445 setArgs, setOptions :: [String] -> GHCi ()
1446 setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
1450 setGHCiState st{ args = args }
1454 setGHCiState st{ progname = prog }
1458 setGHCiState st{ editor = cmd }
1460 setStop str@(c:_) | isDigit c
1461 = do let (nm_str,rest) = break (not.isDigit) str
1464 let old_breaks = breaks st
1465 if all ((/= nm) . fst) old_breaks
1466 then printForUser (text "Breakpoint" <+> ppr nm <+>
1467 text "does not exist")
1469 let new_breaks = map fn old_breaks
1470 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1471 | otherwise = (i,loc)
1472 setGHCiState st{ breaks = new_breaks }
1475 setGHCiState st{ stop = cmd }
1477 setPrompt value = do
1480 then liftIO $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1482 '\"' : _ -> case reads value of
1483 [(value', xs)] | all isSpace xs ->
1484 setGHCiState (st { prompt = value' })
1486 liftIO $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
1487 _ -> setGHCiState (st { prompt = value })
1490 do -- first, deal with the GHCi opts (+s, +t, etc.)
1491 let (plus_opts, minus_opts) = partitionWith isPlus wds
1492 mapM_ setOpt plus_opts
1493 -- then, dynamic flags
1494 newDynFlags minus_opts
1496 newDynFlags :: [String] -> GHCi ()
1497 newDynFlags minus_opts = do
1498 dflags <- getDynFlags
1499 let pkg_flags = packageFlags dflags
1500 (dflags', leftovers, warns) <- liftIO $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
1501 liftIO $ handleFlagWarnings dflags' warns
1503 if (not (null leftovers))
1504 then ghcError $ errorsToGhcException leftovers
1507 new_pkgs <- setDynFlags dflags'
1509 -- if the package flags changed, we should reset the context
1510 -- and link the new packages.
1511 dflags <- getDynFlags
1512 when (packageFlags dflags /= pkg_flags) $ do
1513 liftIO $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
1515 _ <- GHC.load LoadAllTargets
1516 liftIO (linkPackages dflags new_pkgs)
1517 -- package flags changed, we can't re-use any of the old context
1518 setContextAfterLoad ([],[]) False []
1522 unsetOptions :: String -> GHCi ()
1524 = -- first, deal with the GHCi opts (+s, +t, etc.)
1525 let opts = words str
1526 (minus_opts, rest1) = partition isMinus opts
1527 (plus_opts, rest2) = partitionWith isPlus rest1
1528 (other_opts, rest3) = partition (`elem` map fst defaulters) rest2
1531 [ ("args" , setArgs default_args)
1532 , ("prog" , setProg default_progname)
1533 , ("prompt", setPrompt default_prompt)
1534 , ("editor", liftIO findEditor >>= setEditor)
1535 , ("stop" , setStop default_stop)
1538 no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1539 no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
1541 in if (not (null rest3))
1542 then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))
1544 mapM_ (fromJust.flip lookup defaulters) other_opts
1546 mapM_ unsetOpt plus_opts
1548 no_flags <- mapM no_flag minus_opts
1549 newDynFlags no_flags
1551 isMinus :: String -> Bool
1552 isMinus ('-':_) = True
1555 isPlus :: String -> Either String String
1556 isPlus ('+':opt) = Left opt
1557 isPlus other = Right other
1559 setOpt, unsetOpt :: String -> GHCi ()
1562 = case strToGHCiOpt str of
1563 Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
1564 Just o -> setOption o
1567 = case strToGHCiOpt str of
1568 Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
1569 Just o -> unsetOption o
1571 strToGHCiOpt :: String -> (Maybe GHCiOption)
1572 strToGHCiOpt "s" = Just ShowTiming
1573 strToGHCiOpt "t" = Just ShowType
1574 strToGHCiOpt "r" = Just RevertCAFs
1575 strToGHCiOpt _ = Nothing
1577 optToStr :: GHCiOption -> String
1578 optToStr ShowTiming = "s"
1579 optToStr ShowType = "t"
1580 optToStr RevertCAFs = "r"
1582 -- ---------------------------------------------------------------------------
1585 showCmd :: String -> GHCi ()
1589 ["args"] -> liftIO $ putStrLn (show (args st))
1590 ["prog"] -> liftIO $ putStrLn (show (progname st))
1591 ["prompt"] -> liftIO $ putStrLn (show (prompt st))
1592 ["editor"] -> liftIO $ putStrLn (show (editor st))
1593 ["stop"] -> liftIO $ putStrLn (show (stop st))
1594 ["modules" ] -> showModules
1595 ["bindings"] -> showBindings
1596 ["linker"] -> liftIO showLinkerState
1597 ["breaks"] -> showBkptTable
1598 ["context"] -> showContext
1599 ["packages"] -> showPackages
1600 ["languages"] -> showLanguages
1601 _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
1602 " | breaks | context | packages | languages ]"))
1604 showModules :: GHCi ()
1606 loaded_mods <- getLoadedModules
1607 -- we want *loaded* modules only, see #1734
1608 let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)
1609 mapM_ show_one loaded_mods
1611 getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
1612 getLoadedModules = do
1613 graph <- GHC.getModuleGraph
1614 filterM (GHC.isLoaded . GHC.ms_mod_name) graph
1616 showBindings :: GHCi ()
1618 bindings <- GHC.getBindings
1619 docs <- pprTypeAndContents
1620 [ id | AnId id <- sortBy compareTyThings bindings]
1621 printForUserPartWay docs
1623 compareTyThings :: TyThing -> TyThing -> Ordering
1624 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1626 printTyThing :: TyThing -> GHCi ()
1627 printTyThing tyth = do dflags <- getDynFlags
1628 let pefas = dopt Opt_PrintExplicitForalls dflags
1629 printForUser (pprTyThing pefas tyth)
1631 showBkptTable :: GHCi ()
1634 printForUser $ prettyLocations (breaks st)
1636 showContext :: GHCi ()
1638 resumes <- GHC.getResumeContext
1639 printForUser $ vcat (map pp_resume (reverse resumes))
1642 ptext (sLit "--> ") <> text (GHC.resumeStmt resume)
1643 $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume))
1645 showPackages :: GHCi ()
1647 pkg_flags <- fmap packageFlags getDynFlags
1648 liftIO $ putStrLn $ showSDoc $ vcat $
1649 text ("active package flags:"++if null pkg_flags then " none" else "")
1650 : map showFlag pkg_flags
1651 where showFlag (ExposePackage p) = text $ " -package " ++ p
1652 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1653 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1654 showFlag (ExposePackageId p) = text $ " -package-id " ++ p
1656 showLanguages :: GHCi ()
1658 dflags <- getDynFlags
1659 liftIO $ putStrLn $ showSDoc $ vcat $
1660 text "active language flags:" :
1661 [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, xopt f dflags]
1663 -- -----------------------------------------------------------------------------
1666 completeCmd, completeMacro, completeIdentifier, completeModule,
1668 completeHomeModule, completeSetOptions, completeShowOptions,
1669 completeHomeModuleOrFile, completeExpression
1670 :: CompletionFunc GHCi
1672 ghciCompleteWord :: CompletionFunc GHCi
1673 ghciCompleteWord line@(left,_) = case firstWord of
1674 ':':cmd | null rest -> completeCmd line
1676 completion <- lookupCompletion cmd
1678 "import" -> completeModule line
1679 _ -> completeExpression line
1681 (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
1682 lookupCompletion ('!':_) = return completeFilename
1683 lookupCompletion c = do
1684 maybe_cmd <- liftIO $ lookupCommand' c
1686 Just (_,_,f) -> return f
1687 Nothing -> return completeFilename
1689 completeCmd = wrapCompleter " " $ \w -> do
1690 macros <- liftIO $ readIORef macros_ref
1691 let macro_names = map (':':) . map cmdName $ macros
1692 let command_names = map (':':) . map cmdName $ builtin_commands
1693 let{ candidates = case w of
1694 ':' : ':' : _ -> map (':':) command_names
1695 _ -> nub $ macro_names ++ command_names }
1696 return $ filter (w `isPrefixOf`) candidates
1698 completeMacro = wrapIdentCompleter $ \w -> do
1699 cmds <- liftIO $ readIORef macros_ref
1700 return (filter (w `isPrefixOf`) (map cmdName cmds))
1702 completeIdentifier = wrapIdentCompleter $ \w -> do
1703 rdrs <- GHC.getRdrNamesInScope
1704 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1706 completeModule = wrapIdentCompleter $ \w -> do
1707 dflags <- GHC.getSessionDynFlags
1708 let pkg_mods = allExposedModules dflags
1709 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
1710 return $ filter (w `isPrefixOf`)
1711 $ map (showSDoc.ppr) $ loaded_mods ++ pkg_mods
1713 completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
1714 modules <- case m of
1716 (toplevs, exports) <- GHC.getContext
1717 return $ map GHC.moduleName (nub (map fst exports) ++ toplevs)
1719 dflags <- GHC.getSessionDynFlags
1720 let pkg_mods = allExposedModules dflags
1721 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
1722 return $ loaded_mods ++ pkg_mods
1723 return $ filter (w `isPrefixOf`) $ map (showSDoc.ppr) modules
1725 completeHomeModule = wrapIdentCompleter listHomeModules
1727 listHomeModules :: String -> GHCi [String]
1728 listHomeModules w = do
1729 g <- GHC.getModuleGraph
1730 let home_mods = map GHC.ms_mod_name g
1731 return $ sort $ filter (w `isPrefixOf`)
1732 $ map (showSDoc.ppr) home_mods
1734 completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
1735 return (filter (w `isPrefixOf`) options)
1736 where options = "args":"prog":"prompt":"editor":"stop":flagList
1737 flagList = map head $ group $ sort allFlags
1739 completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
1740 return (filter (w `isPrefixOf`) options)
1741 where options = ["args", "prog", "prompt", "editor", "stop",
1742 "modules", "bindings", "linker", "breaks",
1743 "context", "packages", "languages"]
1745 completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
1746 $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
1749 unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
1750 unionComplete f1 f2 line = do
1755 wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
1756 wrapCompleter breakChars fun = completeWord Nothing breakChars
1757 $ fmap (map simpleCompletion) . fmap sort . fun
1759 wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
1760 wrapIdentCompleter = wrapCompleter word_break_chars
1762 wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi
1763 wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars
1764 $ \rest -> fmap (map simpleCompletion) . fmap sort . fun (getModifier rest)
1766 getModifier = find (`elem` modifChars)
1768 allExposedModules :: DynFlags -> [ModuleName]
1769 allExposedModules dflags
1770 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1772 pkg_db = pkgIdMap (pkgState dflags)
1774 completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
1777 -- ---------------------------------------------------------------------------
1778 -- User code exception handling
1780 -- This is the exception handler for exceptions generated by the
1781 -- user's code and exceptions coming from children sessions;
1782 -- it normally just prints out the exception. The
1783 -- handler must be recursive, in case showing the exception causes
1784 -- more exceptions to be raised.
1786 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1787 -- raising another exception. We therefore don't put the recursive
1788 -- handler arond the flushing operation, so if stderr is closed
1789 -- GHCi will just die gracefully rather than going into an infinite loop.
1790 handler :: SomeException -> GHCi Bool
1792 handler exception = do
1794 liftIO installSignalHandlers
1795 ghciHandle handler (showException exception >> return False)
1797 showException :: SomeException -> GHCi ()
1799 liftIO $ case fromException se of
1800 -- omit the location for CmdLineError:
1801 Just (CmdLineError s) -> putStrLn s
1803 Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
1804 Just other_ghc_ex -> print other_ghc_ex
1806 case fromException se of
1807 Just UserInterrupt -> putStrLn "Interrupted."
1808 _ -> putStrLn ("*** Exception: " ++ show se)
1810 -----------------------------------------------------------------------------
1811 -- recursive exception handlers
1813 -- Don't forget to unblock async exceptions in the handler, or if we're
1814 -- in an exception loop (eg. let a = error a in a) the ^C exception
1815 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1817 ghciHandle :: MonadException m => (SomeException -> m a) -> m a -> m a
1818 ghciHandle h m = Haskeline.catch m $ \e -> unblock (h e)
1820 ghciTry :: GHCi a -> GHCi (Either SomeException a)
1821 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
1823 -- ----------------------------------------------------------------------------
1826 -- TODO: won't work if home dir is encoded.
1827 -- (changeDirectory may not work either in that case.)
1828 expandPath :: MonadIO m => String -> InputT m String
1829 expandPath path = do
1830 exp_path <- liftIO $ expandPathIO path
1831 enc <- fmap BS.unpack $ Encoding.encode exp_path
1834 expandPathIO :: String -> IO String
1836 case dropWhile isSpace path of
1838 tilde <- getHomeDirectory -- will fail if HOME not defined
1839 return (tilde ++ '/':d)
1843 wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
1844 wantInterpretedModule str = do
1845 modl <- lookupModule str
1846 dflags <- getDynFlags
1847 when (GHC.modulePackageId modl /= thisPackage dflags) $
1848 ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
1849 is_interpreted <- GHC.moduleIsInterpreted modl
1850 when (not is_interpreted) $
1851 ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
1854 wantNameFromInterpretedModule :: GHC.GhcMonad m
1855 => (Name -> SDoc -> m ())
1859 wantNameFromInterpretedModule noCanDo str and_then =
1860 handleSourceError GHC.printException $ do
1861 names <- GHC.parseName str
1865 let modl = ASSERT( isExternalName n ) GHC.nameModule n
1866 if not (GHC.isExternalName n)
1867 then noCanDo n $ ppr n <>
1868 text " is not defined in an interpreted module"
1870 is_interpreted <- GHC.moduleIsInterpreted modl
1871 if not is_interpreted
1872 then noCanDo n $ text "module " <> ppr modl <>
1873 text " is not interpreted"
1876 -- -----------------------------------------------------------------------------
1877 -- commands for debugger
1879 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1880 sprintCmd = pprintCommand False False
1881 printCmd = pprintCommand True False
1882 forceCmd = pprintCommand False True
1884 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1885 pprintCommand bind force str = do
1886 pprintClosureCommand bind force str
1888 stepCmd :: String -> GHCi ()
1889 stepCmd [] = doContinue (const True) GHC.SingleStep
1890 stepCmd expression = runStmt expression GHC.SingleStep >> return ()
1892 stepLocalCmd :: String -> GHCi ()
1893 stepLocalCmd [] = do
1894 mb_span <- getCurrentBreakSpan
1896 Nothing -> stepCmd []
1898 Just mod <- getCurrentBreakModule
1899 current_toplevel_decl <- enclosingTickSpan mod loc
1900 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1902 stepLocalCmd expression = stepCmd expression
1904 stepModuleCmd :: String -> GHCi ()
1905 stepModuleCmd [] = do
1906 mb_span <- getCurrentBreakSpan
1908 Nothing -> stepCmd []
1910 Just span <- getCurrentBreakSpan
1911 let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span
1912 doContinue f GHC.SingleStep
1914 stepModuleCmd expression = stepCmd expression
1916 -- | Returns the span of the largest tick containing the srcspan given
1917 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1918 enclosingTickSpan mod src = do
1919 ticks <- getTickArray mod
1920 let line = srcSpanStartLine src
1921 ASSERT (inRange (bounds ticks) line) do
1922 let enclosing_spans = [ span | (_,span) <- ticks ! line
1923 , srcSpanEnd span >= srcSpanEnd src]
1924 return . head . sortBy leftmost_largest $ enclosing_spans
1926 traceCmd :: String -> GHCi ()
1927 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1928 traceCmd expression = runStmt expression GHC.RunAndLogSteps >> return ()
1930 continueCmd :: String -> GHCi ()
1931 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1933 -- doContinue :: SingleStep -> GHCi ()
1934 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1935 doContinue pred step = do
1936 runResult <- resume pred step
1937 _ <- afterRunStmt pred runResult
1940 abandonCmd :: String -> GHCi ()
1941 abandonCmd = noArgs $ do
1942 b <- GHC.abandon -- the prompt will change to indicate the new context
1943 when (not b) $ liftIO $ putStrLn "There is no computation running."
1945 deleteCmd :: String -> GHCi ()
1946 deleteCmd argLine = do
1947 deleteSwitch $ words argLine
1949 deleteSwitch :: [String] -> GHCi ()
1951 liftIO $ putStrLn "The delete command requires at least one argument."
1952 -- delete all break points
1953 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1954 deleteSwitch idents = do
1955 mapM_ deleteOneBreak idents
1957 deleteOneBreak :: String -> GHCi ()
1959 | all isDigit str = deleteBreak (read str)
1960 | otherwise = return ()
1962 historyCmd :: String -> GHCi ()
1964 | null arg = history 20
1965 | all isDigit arg = history (read arg)
1966 | otherwise = liftIO $ putStrLn "Syntax: :history [num]"
1969 resumes <- GHC.getResumeContext
1971 [] -> liftIO $ putStrLn "Not stopped at a breakpoint"
1973 let hist = GHC.resumeHistory r
1974 (took,rest) = splitAt num hist
1976 [] -> liftIO $ putStrLn $
1977 "Empty history. Perhaps you forgot to use :trace?"
1979 spans <- mapM GHC.getHistorySpan took
1980 let nums = map (printf "-%-3d:") [(1::Int)..]
1981 names = map GHC.historyEnclosingDecls took
1982 printForUser (vcat(zipWith3
1983 (\x y z -> x <+> y <+> z)
1985 (map (bold . hcat . punctuate colon . map text) names)
1986 (map (parens . ppr) spans)))
1987 liftIO $ putStrLn $ if null rest then "<end of history>" else "..."
1989 bold :: SDoc -> SDoc
1990 bold c | do_bold = text start_bold <> c <> text end_bold
1993 backCmd :: String -> GHCi ()
1994 backCmd = noArgs $ do
1995 (names, _, span) <- GHC.back
1996 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span
1997 printTypeOfNames names
1998 -- run the command set with ":set stop <cmd>"
2000 enqueueCommands [stop st]
2002 forwardCmd :: String -> GHCi ()
2003 forwardCmd = noArgs $ do
2004 (names, ix, span) <- GHC.forward
2005 printForUser $ (if (ix == 0)
2006 then ptext (sLit "Stopped at")
2007 else ptext (sLit "Logged breakpoint at")) <+> ppr span
2008 printTypeOfNames names
2009 -- run the command set with ":set stop <cmd>"
2011 enqueueCommands [stop st]
2013 -- handle the "break" command
2014 breakCmd :: String -> GHCi ()
2015 breakCmd argLine = do
2016 breakSwitch $ words argLine
2018 breakSwitch :: [String] -> GHCi ()
2020 liftIO $ putStrLn "The break command requires at least one argument."
2021 breakSwitch (arg1:rest)
2022 | looksLikeModuleName arg1 && not (null rest) = do
2023 mod <- wantInterpretedModule arg1
2024 breakByModule mod rest
2025 | all isDigit arg1 = do
2026 (toplevel, _) <- GHC.getContext
2028 (mod : _) -> breakByModuleLine mod (read arg1) rest
2030 liftIO $ putStrLn "Cannot find default module for breakpoint."
2031 liftIO $ putStrLn "Perhaps no modules are loaded for debugging?"
2032 | otherwise = do -- try parsing it as an identifier
2033 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
2034 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2035 if GHC.isGoodSrcLoc loc
2036 then ASSERT( isExternalName name )
2037 findBreakAndSet (GHC.nameModule name) $
2038 findBreakByCoord (Just (GHC.srcLocFile loc))
2039 (GHC.srcLocLine loc,
2041 else noCanDo name $ text "can't find its location: " <> ppr loc
2043 noCanDo n why = printForUser $
2044 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
2046 breakByModule :: Module -> [String] -> GHCi ()
2047 breakByModule mod (arg1:rest)
2048 | all isDigit arg1 = do -- looks like a line number
2049 breakByModuleLine mod (read arg1) rest
2053 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
2054 breakByModuleLine mod line args
2055 | [] <- args = findBreakAndSet mod $ findBreakByLine line
2056 | [col] <- args, all isDigit col =
2057 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
2058 | otherwise = breakSyntax
2061 breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
2063 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
2064 findBreakAndSet mod lookupTickTree = do
2065 tickArray <- getTickArray mod
2066 (breakArray, _) <- getModBreak mod
2067 case lookupTickTree tickArray of
2068 Nothing -> liftIO $ putStrLn $ "No breakpoints found at that location."
2069 Just (tick, span) -> do
2070 success <- liftIO $ setBreakFlag True breakArray tick
2074 recordBreak $ BreakLocation
2081 text "Breakpoint " <> ppr nm <>
2083 then text " was already set at " <> ppr span
2084 else text " activated at " <> ppr span
2086 printForUser $ text "Breakpoint could not be activated at"
2089 -- When a line number is specified, the current policy for choosing
2090 -- the best breakpoint is this:
2091 -- - the leftmost complete subexpression on the specified line, or
2092 -- - the leftmost subexpression starting on the specified line, or
2093 -- - the rightmost subexpression enclosing the specified line
2095 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2096 findBreakByLine line arr
2097 | not (inRange (bounds arr) line) = Nothing
2099 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
2100 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2101 listToMaybe (sortBy (rightmost `on` snd) ticks)
2105 starts_here = [ tick | tick@(_,span) <- ticks,
2106 GHC.srcSpanStartLine span == line ]
2108 (complete,incomplete) = partition ends_here starts_here
2109 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2111 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2112 -> Maybe (BreakIndex,SrcSpan)
2113 findBreakByCoord mb_file (line, col) arr
2114 | not (inRange (bounds arr) line) = Nothing
2116 listToMaybe (sortBy (rightmost `on` snd) contains ++
2117 sortBy (leftmost_smallest `on` snd) after_here)
2121 -- the ticks that span this coordinate
2122 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2123 is_correct_file span ]
2125 is_correct_file span
2126 | Just f <- mb_file = GHC.srcSpanFile span == f
2129 after_here = [ tick | tick@(_,span) <- ticks,
2130 GHC.srcSpanStartLine span == line,
2131 GHC.srcSpanStartCol span >= col ]
2133 -- For now, use ANSI bold on terminals that we know support it.
2134 -- Otherwise, we add a line of carets under the active expression instead.
2135 -- In particular, on Windows and when running the testsuite (which sets
2136 -- TERM to vt100 for other reasons) we get carets.
2137 -- We really ought to use a proper termcap/terminfo library.
2139 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2140 where mTerm = System.Environment.getEnv "TERM"
2141 `catchIO` \_ -> return "TERM not set"
2143 start_bold :: String
2144 start_bold = "\ESC[1m"
2146 end_bold = "\ESC[0m"
2148 listCmd :: String -> InputT GHCi ()
2149 listCmd c = listCmd' c
2151 listCmd' :: String -> InputT GHCi ()
2153 mb_span <- lift getCurrentBreakSpan
2156 printForUser $ text "Not stopped at a breakpoint; nothing to list"
2158 | GHC.isGoodSrcSpan span -> listAround span True
2160 do resumes <- GHC.getResumeContext
2162 [] -> panic "No resumes"
2164 do let traceIt = case GHC.resumeHistory r of
2165 [] -> text "rerunning with :trace,"
2167 doWhat = traceIt <+> text ":back then :list"
2168 printForUser (text "Unable to list source for" <+>
2170 $$ text "Try" <+> doWhat)
2171 listCmd' str = list2 (words str)
2173 list2 :: [String] -> InputT GHCi ()
2174 list2 [arg] | all isDigit arg = do
2175 (toplevel, _) <- GHC.getContext
2177 [] -> liftIO $ putStrLn "No module to list"
2178 (mod : _) -> listModuleLine mod (read arg)
2179 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2180 mod <- wantInterpretedModule arg1
2181 listModuleLine mod (read arg2)
2183 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2184 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2185 if GHC.isGoodSrcLoc loc
2187 tickArray <- ASSERT( isExternalName name )
2188 lift $ getTickArray (GHC.nameModule name)
2189 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2190 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2193 Nothing -> listAround (GHC.srcLocSpan loc) False
2194 Just (_,span) -> listAround span False
2196 noCanDo name $ text "can't find its location: " <>
2199 noCanDo n why = printForUser $
2200 text "cannot list source code for " <> ppr n <> text ": " <> why
2202 liftIO $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2204 listModuleLine :: Module -> Int -> InputT GHCi ()
2205 listModuleLine modl line = do
2206 graph <- GHC.getModuleGraph
2207 let this = filter ((== modl) . GHC.ms_mod) graph
2209 [] -> panic "listModuleLine"
2211 let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
2212 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2213 listAround (GHC.srcLocSpan loc) False
2215 -- | list a section of a source file around a particular SrcSpan.
2216 -- If the highlight flag is True, also highlight the span using
2217 -- start_bold\/end_bold.
2219 -- GHC files are UTF-8, so we can implement this by:
2220 -- 1) read the file in as a BS and syntax highlight it as before
2221 -- 2) convert the BS to String using utf-string, and write it out.
2222 -- It would be better if we could convert directly between UTF-8 and the
2223 -- console encoding, of course.
2224 listAround :: MonadIO m => SrcSpan -> Bool -> InputT m ()
2225 listAround span do_highlight = do
2226 contents <- liftIO $ BS.readFile (unpackFS file)
2228 lines = BS.split '\n' contents
2229 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2230 drop (line1 - 1 - pad_before) $ lines
2231 fst_line = max 1 (line1 - pad_before)
2232 line_nos = [ fst_line .. ]
2234 highlighted | do_highlight = zipWith highlight line_nos these_lines
2235 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2237 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2238 prefixed = zipWith ($) highlighted bs_line_nos
2240 let output = BS.intercalate (BS.pack "\n") prefixed
2241 utf8Decoded <- liftIO $ BS.useAsCStringLen output
2242 $ \(p,n) -> utf8DecodeString (castPtr p) n
2243 liftIO $ putStrLn utf8Decoded
2245 file = GHC.srcSpanFile span
2246 line1 = GHC.srcSpanStartLine span
2247 col1 = GHC.srcSpanStartCol span - 1
2248 line2 = GHC.srcSpanEndLine span
2249 col2 = GHC.srcSpanEndCol span - 1
2251 pad_before | line1 == 1 = 0
2255 highlight | do_bold = highlight_bold
2256 | otherwise = highlight_carets
2258 highlight_bold no line prefix
2259 | no == line1 && no == line2
2260 = let (a,r) = BS.splitAt col1 line
2261 (b,c) = BS.splitAt (col2-col1) r
2263 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2265 = let (a,b) = BS.splitAt col1 line in
2266 BS.concat [prefix, a, BS.pack start_bold, b]
2268 = let (a,b) = BS.splitAt col2 line in
2269 BS.concat [prefix, a, BS.pack end_bold, b]
2270 | otherwise = BS.concat [prefix, line]
2272 highlight_carets no line prefix
2273 | no == line1 && no == line2
2274 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2275 BS.replicate (col2-col1) '^']
2277 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2280 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2282 | otherwise = BS.concat [prefix, line]
2284 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2285 nl = BS.singleton '\n'
2287 -- --------------------------------------------------------------------------
2290 getTickArray :: Module -> GHCi TickArray
2291 getTickArray modl = do
2293 let arrmap = tickarrays st
2294 case lookupModuleEnv arrmap modl of
2295 Just arr -> return arr
2297 (_breakArray, ticks) <- getModBreak modl
2298 let arr = mkTickArray (assocs ticks)
2299 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2302 discardTickArrays :: GHCi ()
2303 discardTickArrays = do
2305 setGHCiState st{tickarrays = emptyModuleEnv}
2307 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2309 = accumArray (flip (:)) [] (1, max_line)
2310 [ (line, (nm,span)) | (nm,span) <- ticks,
2311 line <- srcSpanLines span ]
2313 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2314 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2315 GHC.srcSpanEndLine span ]
2317 lookupModule :: GHC.GhcMonad m => String -> m Module
2318 lookupModule modName
2319 = GHC.lookupModule (GHC.mkModuleName modName) Nothing
2321 -- don't reset the counter back to zero?
2322 discardActiveBreakPoints :: GHCi ()
2323 discardActiveBreakPoints = do
2325 mapM_ (turnOffBreak.snd) (breaks st)
2326 setGHCiState $ st { breaks = [] }
2328 deleteBreak :: Int -> GHCi ()
2329 deleteBreak identity = do
2331 let oldLocations = breaks st
2332 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2334 then printForUser (text "Breakpoint" <+> ppr identity <+>
2335 text "does not exist")
2337 mapM_ (turnOffBreak.snd) this
2338 setGHCiState $ st { breaks = rest }
2340 turnOffBreak :: BreakLocation -> GHCi Bool
2341 turnOffBreak loc = do
2342 (arr, _) <- getModBreak (breakModule loc)
2343 liftIO $ setBreakFlag False arr (breakTick loc)
2345 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2346 getModBreak mod = do
2347 Just mod_info <- GHC.getModuleInfo mod
2348 let modBreaks = GHC.modInfoModBreaks mod_info
2349 let array = GHC.modBreaks_flags modBreaks
2350 let ticks = GHC.modBreaks_locs modBreaks
2351 return (array, ticks)
2353 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2354 setBreakFlag toggle array index
2355 | toggle = GHC.setBreakOn array index
2356 | otherwise = GHC.setBreakOff array index