1 {-# OPTIONS -fno-cse #-}
2 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
4 {-# OPTIONS -#include "Linker.h" #-}
5 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
6 -----------------------------------------------------------------------------
8 -- GHC Interactive User Interface
10 -- (c) The GHC Team 2005-2006
12 -----------------------------------------------------------------------------
14 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
16 #include "HsVersions.h"
18 import qualified GhciMonad
19 import GhciMonad hiding (runStmt)
24 import qualified GHC hiding (resume, runStmt)
25 import GHC ( LoadHowMuch(..), Target(..), TargetId(..),
26 Module, ModuleName, TyThing(..), Phase,
27 BreakIndex, SrcSpan, Resume, SingleStep,
28 Ghc, handleSourceError )
36 import HscTypes ( implicitTyThings, handleFlagWarnings )
37 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
38 import Outputable hiding (printForUser, printForUserPartWay)
39 import Module -- for ModuleEnv
44 -- Other random utilities
47 import BasicTypes hiding (isTopLevel)
48 import Panic hiding (showException)
54 import Maybes ( orElse, expectJust )
58 #if __GLASGOW_HASKELL__ < 611
63 #ifndef mingw32_HOST_OS
64 import System.Posix hiding (getEnv)
66 import qualified System.Win32
69 import System.Console.Haskeline as Haskeline
70 import qualified System.Console.Haskeline.Encoding as Encoding
71 import Control.Monad.Trans
75 import Exception hiding (catch, block, unblock)
76 import qualified Exception
78 -- import Control.Concurrent
80 import System.FilePath
81 import qualified Data.ByteString.Char8 as BS
85 import System.Environment
86 import System.Exit ( exitWith, ExitCode(..) )
87 import System.Directory
89 import System.IO.Error as IO
92 import Control.Monad as Monad
95 import GHC.Exts ( unsafeCoerce# )
97 #if __GLASGOW_HASKELL__ >= 611
98 import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
100 import GHC.IOBase ( IOErrorType(InvalidArgument) )
103 import GHC.TopHandler
105 import Data.IORef ( IORef, readIORef, writeIORef )
107 -----------------------------------------------------------------------------
109 ghciWelcomeMsg :: String
110 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
111 ": http://www.haskell.org/ghc/ :? for help"
113 cmdName :: Command -> String
116 GLOBAL_VAR(macros_ref, [], [Command])
118 builtin_commands :: [Command]
120 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
121 ("?", keepGoing help, noCompletion),
122 ("add", keepGoingPaths addModule, completeFilename),
123 ("abandon", keepGoing abandonCmd, noCompletion),
124 ("break", keepGoing breakCmd, completeIdentifier),
125 ("back", keepGoing backCmd, noCompletion),
126 ("browse", keepGoing' (browseCmd False), completeModule),
127 ("browse!", keepGoing' (browseCmd True), completeModule),
128 ("cd", keepGoing' changeDirectory, completeFilename),
129 ("check", keepGoing' checkModule, completeHomeModule),
130 ("continue", keepGoing continueCmd, noCompletion),
131 ("cmd", keepGoing cmdCmd, completeExpression),
132 ("ctags", keepGoing createCTagsFileCmd, completeFilename),
133 ("def", keepGoing (defineMacro False), completeExpression),
134 ("def!", keepGoing (defineMacro True), completeExpression),
135 ("delete", keepGoing deleteCmd, noCompletion),
136 ("e", keepGoing editFile, completeFilename),
137 ("edit", keepGoing editFile, completeFilename),
138 ("etags", keepGoing createETagsFileCmd, completeFilename),
139 ("force", keepGoing forceCmd, completeExpression),
140 ("forward", keepGoing forwardCmd, noCompletion),
141 ("help", keepGoing help, noCompletion),
142 ("history", keepGoing historyCmd, noCompletion),
143 ("info", keepGoing' info, completeIdentifier),
144 ("kind", keepGoing' kindOfType, completeIdentifier),
145 ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),
146 ("list", keepGoing' listCmd, noCompletion),
147 ("module", keepGoing setContext, completeModule),
148 ("main", keepGoing runMain, completeFilename),
149 ("print", keepGoing printCmd, completeExpression),
150 ("quit", quit, noCompletion),
151 ("reload", keepGoing' reloadModule, noCompletion),
152 ("run", keepGoing runRun, completeFilename),
153 ("set", keepGoing setCmd, completeSetOptions),
154 ("show", keepGoing showCmd, completeShowOptions),
155 ("sprint", keepGoing sprintCmd, completeExpression),
156 ("step", keepGoing stepCmd, completeIdentifier),
157 ("steplocal", keepGoing stepLocalCmd, completeIdentifier),
158 ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),
159 ("type", keepGoing' typeOfExpr, completeExpression),
160 ("trace", keepGoing traceCmd, completeExpression),
161 ("undef", keepGoing undefineMacro, completeMacro),
162 ("unset", keepGoing unsetOptions, completeSetOptions)
166 -- We initialize readline (in the interactiveUI function) to use
167 -- word_break_chars as the default set of completion word break characters.
168 -- This can be overridden for a particular command (for example, filename
169 -- expansion shouldn't consider '/' to be a word break) by setting the third
170 -- entry in the Command tuple above.
172 -- NOTE: in order for us to override the default correctly, any custom entry
173 -- must be a SUBSET of word_break_chars.
174 word_break_chars :: String
175 word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
176 specials = "(),;[]`{}"
178 in spaces ++ specials ++ symbols
180 flagWordBreakChars :: String
181 flagWordBreakChars = " \t\n"
184 keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)
185 keepGoing a str = keepGoing' (lift . a) str
187 keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool
188 keepGoing' a str = a str >> return False
190 keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
192 = do case toArgs str of
193 Left err -> Encoding.encode err >>= liftIO . BS.hPutStrLn stderr
197 shortHelpText :: String
198 shortHelpText = "use :? for help.\n"
202 " Commands available from the prompt:\n" ++
204 " <statement> evaluate/run <statement>\n" ++
205 " : repeat last command\n" ++
206 " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
207 " :add [*]<module> ... add module(s) to the current target set\n" ++
208 " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
209 " (!: more details; *: all top-level names)\n" ++
210 " :cd <dir> change directory to <dir>\n" ++
211 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
212 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
213 " :def <cmd> <expr> define a command :<cmd>\n" ++
214 " :edit <file> edit file\n" ++
215 " :edit edit last module\n" ++
216 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
217 " :help, :? display this list of commands\n" ++
218 " :info [<name> ...] display information about the given names\n" ++
219 " :kind <type> show the kind of <type>\n" ++
220 " :load [*]<module> ... load module(s) and their dependents\n" ++
221 " :main [<arguments> ...] run the main function with the given arguments\n" ++
222 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
223 " :quit exit GHCi\n" ++
224 " :reload reload the current module set\n" ++
225 " :run function [<arguments> ...] run the function with the given arguments\n" ++
226 " :type <expr> show the type of <expr>\n" ++
227 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
228 " :!<command> run the shell command <command>\n" ++
230 " -- Commands for debugging:\n" ++
232 " :abandon at a breakpoint, abandon current computation\n" ++
233 " :back go back in the history (after :trace)\n" ++
234 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
235 " :break <name> set a breakpoint on the specified function\n" ++
236 " :continue resume after a breakpoint\n" ++
237 " :delete <number> delete the specified breakpoint\n" ++
238 " :delete * delete all breakpoints\n" ++
239 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
240 " :forward go forward in the history (after :back)\n" ++
241 " :history [<n>] after :trace, show the execution history\n" ++
242 " :list show the source code around current breakpoint\n" ++
243 " :list identifier show the source code for <identifier>\n" ++
244 " :list [<module>] <line> show the source code around line number <line>\n" ++
245 " :print [<name> ...] prints a value without forcing its computation\n" ++
246 " :sprint [<name> ...] simplifed version of :print\n" ++
247 " :step single-step after stopping at a breakpoint\n"++
248 " :step <expr> single-step into <expr>\n"++
249 " :steplocal single-step within the current top-level binding\n"++
250 " :stepmodule single-step restricted to the current module\n"++
251 " :trace trace after stopping at a breakpoint\n"++
252 " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++
255 " -- Commands for changing settings:\n" ++
257 " :set <option> ... set options\n" ++
258 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
259 " :set prog <progname> set the value returned by System.getProgName\n" ++
260 " :set prompt <prompt> set the prompt used in GHCi\n" ++
261 " :set editor <cmd> set the command used for :edit\n" ++
262 " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" ++
263 " :unset <option> ... unset options\n" ++
265 " Options for ':set' and ':unset':\n" ++
267 " +r revert top-level expressions after each evaluation\n" ++
268 " +s print timing/memory stats after each evaluation\n" ++
269 " +t print type after evaluation\n" ++
270 " -<flags> most GHC command line flags can also be set here\n" ++
271 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
272 " for GHCi-specific flags, see User's Guide,\n"++
273 " Flag reference, Interactive-mode options\n" ++
275 " -- Commands for displaying information:\n" ++
277 " :show bindings show the current bindings made at the prompt\n" ++
278 " :show breaks show the active breakpoints\n" ++
279 " :show context show the breakpoint context\n" ++
280 " :show modules show the currently loaded modules\n" ++
281 " :show packages show the currently active package flags\n" ++
282 " :show languages show the currently active language flags\n" ++
283 " :show <setting> show value of <setting>, which is one of\n" ++
284 " [args, prog, prompt, editor, stop]\n" ++
287 findEditor :: IO String
292 win <- System.Win32.getWindowsDirectory
293 return (win </> "notepad.exe")
298 interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String]
300 interactiveUI srcs maybe_exprs = do
301 -- although GHCi compiles with -prof, it is not usable: the byte-code
302 -- compiler and interpreter don't work with profiling. So we check for
303 -- this up front and emit a helpful error message (#2197)
304 m <- liftIO $ lookupSymbol "PushCostCentre"
306 ghcError (InstallationError "GHCi cannot be used when compiled with -prof")
308 -- HACK! If we happen to get into an infinite loop (eg the user
309 -- types 'let x=x in x' at the prompt), then the thread will block
310 -- on a blackhole, and become unreachable during GC. The GC will
311 -- detect that it is unreachable and send it the NonTermination
312 -- exception. However, since the thread is unreachable, everything
313 -- it refers to might be finalized, including the standard Handles.
314 -- This sounds like a bug, but we don't have a good solution right
316 liftIO $ newStablePtr stdin
317 liftIO $ newStablePtr stdout
318 liftIO $ newStablePtr stderr
320 -- Initialise buffering for the *interpreted* I/O system
323 liftIO $ when (isNothing maybe_exprs) $ do
324 -- Only for GHCi (not runghc and ghc -e):
326 -- Turn buffering off for the compiled program's stdout/stderr
328 -- Turn buffering off for GHCi's stdout
330 hSetBuffering stdout NoBuffering
331 -- We don't want the cmd line to buffer any input that might be
332 -- intended for the program, so unbuffer stdin.
333 hSetBuffering stdin NoBuffering
335 -- initial context is just the Prelude
336 prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing
337 GHC.setContext [] [prel_mod]
339 default_editor <- liftIO $ findEditor
341 startGHCi (runGHCi srcs maybe_exprs)
342 GHCiState{ progname = "<interactive>",
346 editor = default_editor,
347 -- session = session,
352 tickarrays = emptyModuleEnv,
353 last_command = Nothing,
356 ghc_e = isJust maybe_exprs
361 withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
362 withGhcAppData right left = do
363 either_dir <- IO.try (getAppUserDataDirectory "ghc")
365 Right dir -> right dir
368 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
369 runGHCi paths maybe_exprs = do
371 read_dot_files = not opt_IgnoreDotGhci
373 current_dir = return (Just ".ghci")
375 app_user_dir = io $ withGhcAppData
376 (\dir -> return (Just (dir </> "ghci.conf")))
380 either_dir <- io $ IO.try (getEnv "HOME")
382 Right home -> return (Just (home </> ".ghci"))
385 sourceConfigFile :: FilePath -> GHCi ()
386 sourceConfigFile file = do
387 exists <- io $ doesFileExist file
389 dir_ok <- io $ checkPerms (getDirectory file)
390 file_ok <- io $ checkPerms file
391 when (dir_ok && file_ok) $ do
392 either_hdl <- io $ IO.try (openFile file ReadMode)
395 -- NOTE: this assumes that runInputT won't affect the terminal;
396 -- can we assume this will always be the case?
397 -- This would be a good place for runFileInputT.
398 Right hdl -> runInputTWithPrefs defaultPrefs defaultSettings $ do
400 runCommands $ fileLoop hdl
402 getDirectory f = case takeDirectory f of "" -> "."; d -> d
404 when (read_dot_files) $ do
405 cfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
406 cfgs <- io $ mapM canonicalizePath (catMaybes cfgs0)
407 mapM_ sourceConfigFile (nub cfgs)
408 -- nub, because we don't want to read .ghci twice if the
411 -- Perform a :load for files given on the GHCi command line
412 -- When in -e mode, if the load fails then we want to stop
413 -- immediately rather than going on to evaluate the expression.
414 when (not (null paths)) $ do
415 ok <- ghciHandle (\e -> do showException e; return Failed) $
416 -- TODO: this is a hack.
417 runInputTWithPrefs defaultPrefs defaultSettings $ do
418 let (filePaths, phases) = unzip paths
419 filePaths' <- mapM (Encoding.decode . BS.pack) filePaths
420 loadModule (zip filePaths' phases)
421 when (isJust maybe_exprs && failed ok) $
422 io (exitWith (ExitFailure 1))
424 -- if verbosity is greater than 0, or we are connected to a
425 -- terminal, display the prompt in the interactive loop.
426 is_tty <- io (hIsTerminalDevice stdin)
427 dflags <- getDynFlags
428 let show_prompt = verbosity dflags > 0 || is_tty
433 -- enter the interactive loop
434 runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
436 -- just evaluate the expression we were given
437 enqueueCommands exprs
438 let handle e = do st <- getGHCiState
439 -- Jump through some hoops to get the
440 -- current progname in the exception text:
441 -- <progname>: <exception>
442 io $ withProgName (progname st)
443 -- this used to be topHandlerFastExit, see #2228
445 runInputTWithPrefs defaultPrefs defaultSettings $ do
447 runCommands' handle (return Nothing)
450 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
452 runGHCiInput :: InputT GHCi a -> GHCi a
454 histFile <- io $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
456 let settings = setComplete ghciCompleteWord
457 $ defaultSettings {historyFile = histFile}
458 runInputT settings $ do
462 nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
463 nextInputLine show_prompt is_tty
465 prompt <- if show_prompt then lift mkPrompt else return ""
468 when show_prompt $ lift mkPrompt >>= liftIO . putStr
471 -- NOTE: We only read .ghci files if they are owned by the current user,
472 -- and aren't world writable. Otherwise, we could be accidentally
473 -- running code planted by a malicious third party.
475 -- Furthermore, We only read ./.ghci if . is owned by the current user
476 -- and isn't writable by anyone else. I think this is sufficient: we
477 -- don't need to check .. and ../.. etc. because "." always refers to
478 -- the same directory while a process is running.
480 checkPerms :: String -> IO Bool
481 #ifdef mingw32_HOST_OS
486 handleIO (\_ -> return False) $ do
487 st <- getFileStatus name
489 if fileOwner st /= me then do
490 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
493 let mode = fileMode st
494 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
495 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
497 putStrLn $ "*** WARNING: " ++ name ++
498 " is writable by someone else, IGNORING!"
503 fileLoop :: MonadIO m => Handle -> InputT m (Maybe String)
505 l <- liftIO $ IO.try $ hGetLine hdl
507 Left e | isEOFError e -> return Nothing
508 | InvalidArgument <- etype -> return Nothing
509 | otherwise -> liftIO $ ioError e
510 where etype = ioeGetErrorType e
511 -- treat InvalidArgument in the same way as EOF:
512 -- this can happen if the user closed stdin, or
513 -- perhaps did getContents which closes stdin at
515 Right l -> return (Just l)
517 mkPrompt :: GHCi String
519 (toplevs,exports) <- GHC.getContext
520 resumes <- GHC.getResumeContext
521 -- st <- getGHCiState
527 let ix = GHC.resumeHistoryIx r
529 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
531 let hist = GHC.resumeHistory r !! (ix-1)
532 span <- GHC.getHistorySpan hist
533 return (brackets (ppr (negate ix) <> char ':'
534 <+> ppr span) <> space)
536 dots | _:rs <- resumes, not (null rs) = text "... "
543 -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
544 -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
545 -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
546 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
547 hsep (map (ppr . GHC.moduleName) exports)
549 deflt_prompt = dots <> context_bit <> modules_bit
551 f ('%':'s':xs) = deflt_prompt <> f xs
552 f ('%':'%':xs) = char '%' <> f xs
553 f (x:xs) = char x <> f xs
557 return (showSDoc (f (prompt st)))
560 queryQueue :: GHCi (Maybe String)
565 c:cs -> do setGHCiState st{ cmdqueue = cs }
568 runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
569 runCommands = runCommands' handler
571 runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
572 -> InputT GHCi (Maybe String) -> InputT GHCi ()
573 runCommands' eh getCmd = do
574 b <- handleGhcException (\e -> case e of
575 Interrupted -> return False
576 _other -> liftIO (print e) >> return True)
577 (runOneCommand eh getCmd)
578 if b then return () else runCommands' eh getCmd
580 runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
582 runOneCommand eh getCmd = do
583 mb_cmd <- noSpace (lift queryQueue)
584 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
586 Nothing -> return True
587 Just c -> ghciHandle (lift . eh) $
588 handleSourceError printErrorAndKeepGoing
591 printErrorAndKeepGoing err = do
592 GHC.printExceptionAndWarnings err
595 noSpace q = q >>= maybe (return Nothing)
596 (\c->case removeSpaces c of
598 ":{" -> multiLineCmd q
599 c -> return (Just c) )
601 st <- lift getGHCiState
603 lift $ setGHCiState st{ prompt = "%s| " }
604 mb_cmd <- collectCommand q ""
605 lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p }
607 -- we can't use removeSpaces for the sublines here, so
608 -- multiline commands are somewhat more brittle against
609 -- fileformat errors (such as \r in dos input on unix),
610 -- we get rid of any extra spaces for the ":}" test;
611 -- we also avoid silent failure if ":}" is not found;
612 -- and since there is no (?) valid occurrence of \r (as
613 -- opposed to its String representation, "\r") inside a
614 -- ghci command, we replace any such with ' ' (argh:-(
615 collectCommand q c = q >>=
616 maybe (liftIO (ioError collectError))
617 (\l->if removeSpaces l == ":}"
618 then return (Just $ removeSpaces c)
619 else collectCommand q (c++map normSpace l))
620 where normSpace '\r' = ' '
622 -- QUESTION: is userError the one to use here?
623 collectError = userError "unterminated multiline command :{ .. :}"
624 doCommand (':' : cmd) = specialCommand cmd
625 doCommand stmt = do timeIt $ lift $ runStmt stmt GHC.RunToCompletion
628 enqueueCommands :: [String] -> GHCi ()
629 enqueueCommands cmds = do
631 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
634 runStmt :: String -> SingleStep -> GHCi Bool
636 | null (filter (not.isSpace) stmt) = return False
637 | ["import", mod] <- words stmt = keepGoing' setContext ('+':mod)
639 = do result <- GhciMonad.runStmt stmt step
640 afterRunStmt (const True) result
642 --afterRunStmt :: GHC.RunResult -> GHCi Bool
643 -- False <=> the statement failed to compile
644 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
645 afterRunStmt _ (GHC.RunException e) = throw e
646 afterRunStmt step_here run_result = do
647 resumes <- GHC.getResumeContext
649 GHC.RunOk names -> do
650 show_types <- isOptionSet ShowType
651 when show_types $ printTypeOfNames names
652 GHC.RunBreak _ names mb_info
653 | isNothing mb_info ||
654 step_here (GHC.resumeSpan $ head resumes) -> do
655 mb_id_loc <- toBreakIdAndLocation mb_info
656 let breakCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
658 then printStoppedAtBreakInfo (head resumes) names
659 else enqueueCommands [breakCmd]
660 -- run the command set with ":set stop <cmd>"
662 enqueueCommands [stop st]
664 | otherwise -> resume step_here GHC.SingleStep >>=
665 afterRunStmt step_here >> return ()
669 io installSignalHandlers
670 b <- isOptionSet RevertCAFs
673 return (case run_result of GHC.RunOk _ -> True; _ -> False)
675 toBreakIdAndLocation ::
676 Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
677 toBreakIdAndLocation Nothing = return Nothing
678 toBreakIdAndLocation (Just info) = do
679 let mod = GHC.breakInfo_module info
680 nm = GHC.breakInfo_number info
682 return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
683 breakModule loc == mod,
684 breakTick loc == nm ]
686 printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
687 printStoppedAtBreakInfo resume names = do
688 printForUser $ ptext (sLit "Stopped at") <+>
689 ppr (GHC.resumeSpan resume)
690 -- printTypeOfNames session names
691 let namesSorted = sortBy compareNames names
692 tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
693 docs <- pprTypeAndContents [id | AnId id <- tythings]
694 printForUserPartWay docs
696 printTypeOfNames :: [Name] -> GHCi ()
697 printTypeOfNames names
698 = mapM_ (printTypeOfName ) $ sortBy compareNames names
700 compareNames :: Name -> Name -> Ordering
701 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
702 where compareWith n = (getOccString n, getSrcSpan n)
704 printTypeOfName :: Name -> GHCi ()
706 = do maybe_tything <- GHC.lookupName n
707 case maybe_tything of
709 Just thing -> printTyThing thing
712 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
714 specialCommand :: String -> InputT GHCi Bool
715 specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
716 specialCommand str = do
717 let (cmd,rest) = break isSpace str
718 maybe_cmd <- lift $ lookupCommand cmd
720 GotCommand (_,f,_) -> f (dropWhile isSpace rest)
722 do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
726 do liftIO $ hPutStr stdout ("there is no last command to perform\n"
730 lookupCommand :: String -> GHCi (MaybeCommand)
731 lookupCommand "" = do
733 case last_command st of
734 Just c -> return $ GotCommand c
735 Nothing -> return NoLastCommand
736 lookupCommand str = do
737 mc <- io $ lookupCommand' str
739 setGHCiState st{ last_command = mc }
741 Just c -> GotCommand c
742 Nothing -> BadCommand
744 lookupCommand' :: String -> IO (Maybe Command)
745 lookupCommand' str = do
746 macros <- readIORef macros_ref
747 let cmds = builtin_commands ++ macros
748 -- look for exact match first, then the first prefix match
749 return $ case [ c | c <- cmds, str == cmdName c ] of
751 [] -> case [ c | c@(s,_,_) <- cmds, str `isPrefixOf` s ] of
755 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
756 getCurrentBreakSpan = do
757 resumes <- GHC.getResumeContext
761 let ix = GHC.resumeHistoryIx r
763 then return (Just (GHC.resumeSpan r))
765 let hist = GHC.resumeHistory r !! (ix-1)
766 span <- GHC.getHistorySpan hist
769 getCurrentBreakModule :: GHCi (Maybe Module)
770 getCurrentBreakModule = do
771 resumes <- GHC.getResumeContext
775 let ix = GHC.resumeHistoryIx r
777 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
779 let hist = GHC.resumeHistory r !! (ix-1)
780 return $ Just $ GHC.getHistoryModule hist
782 -----------------------------------------------------------------------------
785 noArgs :: GHCi () -> String -> GHCi ()
787 noArgs _ _ = io $ putStrLn "This command takes no arguments"
789 help :: String -> GHCi ()
790 help _ = io (putStr helpText)
792 info :: String -> InputT GHCi ()
793 info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
794 info s = handleSourceError GHC.printExceptionAndWarnings $ do
795 { let names = words s
796 ; dflags <- getDynFlags
797 ; let pefas = dopt Opt_PrintExplicitForalls dflags
798 ; mapM_ (infoThing pefas) names }
800 infoThing pefas str = do
801 names <- GHC.parseName str
802 mb_stuffs <- mapM GHC.getInfo names
803 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
804 unqual <- GHC.getPrintUnqual
805 outputStrLn $ showSDocForUser unqual $
806 vcat (intersperse (text "") $
807 map (pprInfo pefas) filtered)
809 -- Filter out names whose parent is also there Good
810 -- example is '[]', which is both a type and data
811 -- constructor in the same type
812 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
813 filterOutChildren get_thing xs
814 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
816 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
818 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
819 pprInfo pefas (thing, fixity, insts)
820 = pprTyThingInContextLoc pefas thing
821 $$ show_fixity fixity
822 $$ vcat (map GHC.pprInstance insts)
825 | fix == GHC.defaultFixity = empty
826 | otherwise = ppr fix <+> ppr (GHC.getName thing)
828 runMain :: String -> GHCi ()
829 runMain s = case toArgs s of
830 Left err -> io (hPutStrLn stderr err)
832 do dflags <- getDynFlags
833 case mainFunIs dflags of
834 Nothing -> doWithArgs args "main"
835 Just f -> doWithArgs args f
837 runRun :: String -> GHCi ()
838 runRun s = case toCmdArgs s of
839 Left err -> io (hPutStrLn stderr err)
840 Right (cmd, args) -> doWithArgs args cmd
842 doWithArgs :: [String] -> String -> GHCi ()
843 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
844 show args ++ " (" ++ cmd ++ ")"]
846 addModule :: [FilePath] -> InputT GHCi ()
848 lift revertCAFs -- always revert CAFs on load/add.
849 files <- mapM expandPath files
850 targets <- mapM (\m -> GHC.guessTarget m Nothing) files
851 -- remove old targets with the same id; e.g. for :add *M
852 mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
853 mapM_ GHC.addTarget targets
854 prev_context <- GHC.getContext
855 ok <- trySuccess $ GHC.load LoadAllTargets
856 afterLoad ok False prev_context
858 changeDirectory :: String -> InputT GHCi ()
859 changeDirectory "" = do
860 -- :cd on its own changes to the user's home directory
861 either_dir <- liftIO $ IO.try getHomeDirectory
864 Right dir -> changeDirectory dir
865 changeDirectory dir = do
866 graph <- GHC.getModuleGraph
867 when (not (null graph)) $
868 outputStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
869 prev_context <- GHC.getContext
871 GHC.load LoadAllTargets
872 lift $ setContextAfterLoad prev_context False []
873 GHC.workingDirectoryChanged
874 dir <- expandPath dir
875 liftIO $ setCurrentDirectory dir
877 trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
879 handleSourceError (\e -> do GHC.printExceptionAndWarnings e
883 editFile :: String -> GHCi ()
885 do file <- if null str then chooseEditFile else return str
889 $ ghcError (CmdLineError "editor not set, use :set editor")
890 io $ system (cmd ++ ' ':file)
893 -- The user didn't specify a file so we pick one for them.
894 -- Our strategy is to pick the first module that failed to load,
895 -- or otherwise the first target.
897 -- XXX: Can we figure out what happened if the depndecy analysis fails
898 -- (e.g., because the porgrammeer mistyped the name of a module)?
899 -- XXX: Can we figure out the location of an error to pass to the editor?
900 -- XXX: if we could figure out the list of errors that occured during the
901 -- last load/reaload, then we could start the editor focused on the first
903 chooseEditFile :: GHCi String
905 do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
907 graph <- GHC.getModuleGraph
908 failed_graph <- filterM hasFailed graph
909 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
911 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
914 case pick (order failed_graph) of
915 Just file -> return file
917 do targets <- GHC.getTargets
918 case msum (map fromTarget targets) of
919 Just file -> return file
920 Nothing -> ghcError (CmdLineError "No files to edit.")
922 where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
923 fromTarget _ = Nothing -- when would we get a module target?
925 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
926 defineMacro overwrite s = do
927 let (macro_name, definition) = break isSpace s
928 macros <- io (readIORef macros_ref)
929 let defined = map cmdName macros
932 then io $ putStrLn "no macros defined"
933 else io $ putStr ("the following macros are defined:\n" ++
936 if (not overwrite && macro_name `elem` defined)
937 then ghcError (CmdLineError
938 ("macro '" ++ macro_name ++ "' is already defined"))
941 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
943 -- give the expression a type signature, so we can be sure we're getting
944 -- something of the right type.
945 let new_expr = '(' : definition ++ ") :: String -> IO String"
947 -- compile the expression
948 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
949 hv <- GHC.compileExpr new_expr
950 io (writeIORef macros_ref --
951 (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)]))
953 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
955 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
956 -- make sure we force any exceptions in the result, while we are still
957 -- inside the exception handler for commands:
958 seqList str (return ())
959 enqueueCommands (lines str)
962 undefineMacro :: String -> GHCi ()
963 undefineMacro str = mapM_ undef (words str)
964 where undef macro_name = do
965 cmds <- io (readIORef macros_ref)
966 if (macro_name `notElem` map cmdName cmds)
967 then ghcError (CmdLineError
968 ("macro '" ++ macro_name ++ "' is not defined"))
970 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
972 cmdCmd :: String -> GHCi ()
974 let expr = '(' : str ++ ") :: IO String"
975 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
976 hv <- GHC.compileExpr expr
977 cmds <- io $ (unsafeCoerce# hv :: IO String)
978 enqueueCommands (lines cmds)
981 loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
982 loadModule fs = timeIt (loadModule' fs)
984 loadModule_ :: [FilePath] -> InputT GHCi ()
985 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
987 loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
988 loadModule' files = do
989 prev_context <- GHC.getContext
993 lift discardActiveBreakPoints
995 GHC.load LoadAllTargets
997 let (filenames, phases) = unzip files
998 exp_filenames <- mapM expandPath filenames
999 let files' = zip exp_filenames phases
1000 targets <- mapM (uncurry GHC.guessTarget) files'
1002 -- NOTE: we used to do the dependency anal first, so that if it
1003 -- fails we didn't throw away the current set of modules. This would
1004 -- require some re-working of the GHC interface, so we'll leave it
1005 -- as a ToDo for now.
1007 GHC.setTargets targets
1008 doLoad False prev_context LoadAllTargets
1010 checkModule :: String -> InputT GHCi ()
1012 let modl = GHC.mkModuleName m
1013 prev_context <- GHC.getContext
1014 ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do
1015 r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
1016 outputStrLn (showSDoc (
1017 case GHC.moduleInfo r of
1018 cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1020 (local,global) = ASSERT( all isExternalName scope )
1021 partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1023 (text "global names: " <+> ppr global) $$
1024 (text "local names: " <+> ppr local)
1027 afterLoad (successIf ok) False prev_context
1029 reloadModule :: String -> InputT GHCi ()
1031 prev_context <- GHC.getContext
1032 doLoad True prev_context $
1033 if null m then LoadAllTargets
1034 else LoadUpTo (GHC.mkModuleName m)
1037 doLoad :: Bool -> ([Module],[Module]) -> LoadHowMuch -> InputT GHCi SuccessFlag
1038 doLoad retain_context prev_context howmuch = do
1039 -- turn off breakpoints before we load: we can't turn them off later, because
1040 -- the ModBreaks will have gone away.
1041 lift discardActiveBreakPoints
1042 ok <- trySuccess $ GHC.load howmuch
1043 afterLoad ok retain_context prev_context
1046 afterLoad :: SuccessFlag -> Bool -> ([Module],[Module]) -> InputT GHCi ()
1047 afterLoad ok retain_context prev_context = do
1048 lift revertCAFs -- always revert CAFs on load.
1049 lift discardTickArrays
1050 loaded_mod_summaries <- getLoadedModules
1051 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1052 loaded_mod_names = map GHC.moduleName loaded_mods
1053 modulesLoadedMsg ok loaded_mod_names
1055 lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
1058 setContextAfterLoad :: ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi ()
1059 setContextAfterLoad prev keep_ctxt [] = do
1060 prel_mod <- getPrelude
1061 setContextKeepingPackageModules prev keep_ctxt ([], [prel_mod])
1062 setContextAfterLoad prev keep_ctxt ms = do
1063 -- load a target if one is available, otherwise load the topmost module.
1064 targets <- GHC.getTargets
1065 case [ m | Just m <- map (findTarget ms) targets ] of
1067 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1068 load_this (last graph')
1073 = case filter (`matches` t) ms of
1077 summary `matches` Target (TargetModule m) _ _
1078 = GHC.ms_mod_name summary == m
1079 summary `matches` Target (TargetFile f _) _ _
1080 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1084 load_this summary | m <- GHC.ms_mod summary = do
1085 b <- GHC.moduleIsInterpreted m
1086 if b then setContextKeepingPackageModules prev keep_ctxt ([m], [])
1088 prel_mod <- getPrelude
1089 setContextKeepingPackageModules prev keep_ctxt ([],[prel_mod,m])
1091 -- | Keep any package modules (except Prelude) when changing the context.
1092 setContextKeepingPackageModules
1093 :: ([Module],[Module]) -- previous context
1094 -> Bool -- re-execute :module commands
1095 -> ([Module],[Module]) -- new context
1097 setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do
1098 let (_,bs0) = prev_context
1099 prel_mod <- getPrelude
1100 let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1101 let bs1 = if null as then nub (prel_mod : bs) else bs
1102 GHC.setContext as (nub (bs1 ++ pkg_modules))
1106 mapM_ (playCtxtCmd False) (remembered_ctx st)
1109 setGHCiState st{ remembered_ctx = [] }
1111 isHomeModule :: Module -> Bool
1112 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1114 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi ()
1115 modulesLoadedMsg ok mods = do
1116 dflags <- getDynFlags
1117 when (verbosity dflags > 0) $ do
1119 | null mods = text "none."
1120 | otherwise = hsep (
1121 punctuate comma (map ppr mods)) <> text "."
1124 outputStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))
1126 outputStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas))
1129 typeOfExpr :: String -> InputT GHCi ()
1131 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1132 ty <- GHC.exprType str
1133 dflags <- getDynFlags
1134 let pefas = dopt Opt_PrintExplicitForalls dflags
1135 printForUser' $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]
1137 kindOfType :: String -> InputT GHCi ()
1139 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1140 ty <- GHC.typeKind str
1141 printForUser' $ text str <+> dcolon <+> ppr ty
1143 quit :: String -> InputT GHCi Bool
1144 quit _ = return True
1146 shellEscape :: String -> GHCi Bool
1147 shellEscape str = io (system str >> return False)
1149 -----------------------------------------------------------------------------
1150 -- Browsing a module's contents
1152 browseCmd :: Bool -> String -> InputT GHCi ()
1155 ['*':s] | looksLikeModuleName s -> do
1156 m <- lift $ wantInterpretedModule s
1157 browseModule bang m False
1158 [s] | looksLikeModuleName s -> do
1159 m <- lift $ lookupModule s
1160 browseModule bang m True
1162 (as,bs) <- GHC.getContext
1163 -- Guess which module the user wants to browse. Pick
1164 -- modules that are interpreted first. The most
1165 -- recently-added module occurs last, it seems.
1167 (as@(_:_), _) -> browseModule bang (last as) True
1168 ([], bs@(_:_)) -> browseModule bang (last bs) True
1169 ([], []) -> ghcError (CmdLineError ":browse: no current module")
1170 _ -> ghcError (CmdLineError "syntax: :browse <module>")
1172 -- without bang, show items in context of their parents and omit children
1173 -- with bang, show class methods and data constructors separately, and
1174 -- indicate import modules, to aid qualifying unqualified names
1175 -- with sorted, sort items alphabetically
1176 browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
1177 browseModule bang modl exports_only = do
1178 -- :browse! reports qualifiers wrt current context
1179 current_unqual <- GHC.getPrintUnqual
1180 -- Temporarily set the context to the module we're interested in,
1181 -- just so we can get an appropriate PrintUnqualified
1182 (as,bs) <- GHC.getContext
1183 prel_mod <- lift getPrelude
1184 if exports_only then GHC.setContext [] [prel_mod,modl]
1185 else GHC.setContext [modl] []
1186 target_unqual <- GHC.getPrintUnqual
1187 GHC.setContext as bs
1189 let unqual = if bang then current_unqual else target_unqual
1191 mb_mod_info <- GHC.getModuleInfo modl
1193 Nothing -> ghcError (CmdLineError ("unknown module: " ++
1194 GHC.moduleNameString (GHC.moduleName modl)))
1196 dflags <- getDynFlags
1198 | exports_only = GHC.modInfoExports mod_info
1199 | otherwise = GHC.modInfoTopLevelScope mod_info
1202 -- sort alphabetically name, but putting
1203 -- locally-defined identifiers first.
1204 -- We would like to improve this; see #1799.
1205 sorted_names = loc_sort local ++ occ_sort external
1207 (local,external) = ASSERT( all isExternalName names )
1208 partition ((==modl) . nameModule) names
1209 occ_sort = sortBy (compare `on` nameOccName)
1210 -- try to sort by src location. If the first name in
1211 -- our list has a good source location, then they all should.
1213 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1214 = sortBy (compare `on` nameSrcSpan) names
1218 mb_things <- mapM GHC.lookupName sorted_names
1219 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1221 rdr_env <- GHC.getGRE
1223 let pefas = dopt Opt_PrintExplicitForalls dflags
1224 things | bang = catMaybes mb_things
1225 | otherwise = filtered_things
1226 pretty | bang = pprTyThing
1227 | otherwise = pprTyThingInContext
1229 labels [] = text "-- not currently imported"
1230 labels l = text $ intercalate "\n" $ map qualifier l
1231 qualifier = maybe "-- defined locally"
1232 (("-- imported via "++) . intercalate ", "
1233 . map GHC.moduleNameString)
1234 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1235 modNames = map (importInfo . GHC.getName) things
1237 -- annotate groups of imports with their import modules
1238 -- the default ordering is somewhat arbitrary, so we group
1239 -- by header and sort groups; the names themselves should
1240 -- really come in order of source appearance.. (trac #1799)
1241 annotate mts = concatMap (\(m,ts)->labels m:ts)
1242 $ sortBy cmpQualifiers $ group mts
1243 where cmpQualifiers =
1244 compare `on` (map (fmap (map moduleNameFS)) . fst)
1246 group mts@((m,_):_) = (m,map snd g) : group ng
1247 where (g,ng) = partition ((==m).fst) mts
1249 let prettyThings = map (pretty pefas) things
1250 prettyThings' | bang = annotate $ zip modNames prettyThings
1251 | otherwise = prettyThings
1252 outputStrLn $ showSDocForUser unqual (vcat prettyThings')
1253 -- ToDo: modInfoInstances currently throws an exception for
1254 -- package modules. When it works, we can do this:
1255 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1257 -----------------------------------------------------------------------------
1258 -- Setting the module context
1260 setContext :: String -> GHCi ()
1262 | all sensible strs = do
1263 playCtxtCmd True (cmd, as, bs)
1265 setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] }
1266 | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1268 (cmd, strs, as, bs) =
1270 '+':stuff -> rest AddModules stuff
1271 '-':stuff -> rest RemModules stuff
1272 stuff -> rest SetContext stuff
1274 rest cmd stuff = (cmd, strs, as, bs)
1275 where strs = words stuff
1276 (as,bs) = partitionWith starred strs
1278 sensible ('*':m) = looksLikeModuleName m
1279 sensible m = looksLikeModuleName m
1281 starred ('*':m) = Left m
1284 playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi ()
1285 playCtxtCmd fail (cmd, as, bs)
1287 (as',bs') <- do_checks fail
1288 (prev_as,prev_bs) <- GHC.getContext
1292 prel_mod <- getPrelude
1293 let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs'
1297 let as_to_add = as' \\ (prev_as ++ prev_bs)
1298 bs_to_add = bs' \\ (prev_as ++ prev_bs)
1299 return (prev_as ++ as_to_add, prev_bs ++ bs_to_add)
1301 let new_as = prev_as \\ (as' ++ bs')
1302 new_bs = prev_bs \\ (as' ++ bs')
1303 return (new_as, new_bs)
1304 GHC.setContext new_as new_bs
1307 as' <- mapM wantInterpretedModule as
1308 bs' <- mapM lookupModule bs
1310 do_checks False = do
1311 as' <- mapM (trymaybe . wantInterpretedModule) as
1312 bs' <- mapM (trymaybe . lookupModule) bs
1313 return (catMaybes as', catMaybes bs')
1318 Left _ -> return Nothing
1319 Right a -> return (Just a)
1321 ----------------------------------------------------------------------------
1324 -- set options in the interpreter. Syntax is exactly the same as the
1325 -- ghc command line, except that certain options aren't available (-C,
1328 -- This is pretty fragile: most options won't work as expected. ToDo:
1329 -- figure out which ones & disallow them.
1331 setCmd :: String -> GHCi ()
1333 = do st <- getGHCiState
1334 let opts = options st
1335 io $ putStrLn (showSDoc (
1336 text "options currently set: " <>
1339 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1341 dflags <- getDynFlags
1342 io $ putStrLn (showSDoc (
1343 vcat (text "GHCi-specific dynamic flag settings:"
1344 :map (flagSetting dflags) ghciFlags)
1346 io $ putStrLn (showSDoc (
1347 vcat (text "other dynamic, non-language, flag settings:"
1348 :map (flagSetting dflags) nonLanguageDynFlags)
1350 where flagSetting dflags (str, f, _)
1351 | dopt f dflags = text " " <> text "-f" <> text str
1352 | otherwise = text " " <> text "-fno-" <> text str
1353 (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags)
1355 nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions)
1357 flags = [Opt_PrintExplicitForalls
1358 ,Opt_PrintBindResult
1359 ,Opt_BreakOnException
1361 ,Opt_PrintEvldWithShow
1364 = case getCmd str of
1365 Right ("args", rest) ->
1367 Left err -> io (hPutStrLn stderr err)
1368 Right args -> setArgs args
1369 Right ("prog", rest) ->
1371 Right [prog] -> setProg prog
1372 _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")
1373 Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1374 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1375 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1376 _ -> case toArgs str of
1377 Left err -> io (hPutStrLn stderr err)
1378 Right wds -> setOptions wds
1380 setArgs, setOptions :: [String] -> GHCi ()
1381 setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
1385 setGHCiState st{ args = args }
1389 setGHCiState st{ progname = prog }
1393 setGHCiState st{ editor = cmd }
1395 setStop str@(c:_) | isDigit c
1396 = do let (nm_str,rest) = break (not.isDigit) str
1399 let old_breaks = breaks st
1400 if all ((/= nm) . fst) old_breaks
1401 then printForUser (text "Breakpoint" <+> ppr nm <+>
1402 text "does not exist")
1404 let new_breaks = map fn old_breaks
1405 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1406 | otherwise = (i,loc)
1407 setGHCiState st{ breaks = new_breaks }
1410 setGHCiState st{ stop = cmd }
1412 setPrompt value = do
1415 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1417 '\"' : _ -> case reads value of
1418 [(value', xs)] | all isSpace xs ->
1419 setGHCiState (st { prompt = value' })
1421 io $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
1422 _ -> setGHCiState (st { prompt = value })
1425 do -- first, deal with the GHCi opts (+s, +t, etc.)
1426 let (plus_opts, minus_opts) = partitionWith isPlus wds
1427 mapM_ setOpt plus_opts
1428 -- then, dynamic flags
1429 newDynFlags minus_opts
1431 newDynFlags :: [String] -> GHCi ()
1432 newDynFlags minus_opts = do
1433 dflags <- getDynFlags
1434 let pkg_flags = packageFlags dflags
1435 (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
1436 handleFlagWarnings dflags' warns
1438 if (not (null leftovers))
1439 then ghcError $ errorsToGhcException leftovers
1442 new_pkgs <- setDynFlags dflags'
1444 -- if the package flags changed, we should reset the context
1445 -- and link the new packages.
1446 dflags <- getDynFlags
1447 when (packageFlags dflags /= pkg_flags) $ do
1448 io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
1450 GHC.load LoadAllTargets
1451 io (linkPackages dflags new_pkgs)
1452 -- package flags changed, we can't re-use any of the old context
1453 setContextAfterLoad ([],[]) False []
1457 unsetOptions :: String -> GHCi ()
1459 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1460 let opts = words str
1461 (minus_opts, rest1) = partition isMinus opts
1462 (plus_opts, rest2) = partitionWith isPlus rest1
1464 if (not (null rest2))
1465 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1468 mapM_ unsetOpt plus_opts
1470 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1471 no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
1473 no_flags <- mapM no_flag minus_opts
1474 newDynFlags no_flags
1476 isMinus :: String -> Bool
1477 isMinus ('-':_) = True
1480 isPlus :: String -> Either String String
1481 isPlus ('+':opt) = Left opt
1482 isPlus other = Right other
1484 setOpt, unsetOpt :: String -> GHCi ()
1487 = case strToGHCiOpt str of
1488 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1489 Just o -> setOption o
1492 = case strToGHCiOpt str of
1493 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1494 Just o -> unsetOption o
1496 strToGHCiOpt :: String -> (Maybe GHCiOption)
1497 strToGHCiOpt "s" = Just ShowTiming
1498 strToGHCiOpt "t" = Just ShowType
1499 strToGHCiOpt "r" = Just RevertCAFs
1500 strToGHCiOpt _ = Nothing
1502 optToStr :: GHCiOption -> String
1503 optToStr ShowTiming = "s"
1504 optToStr ShowType = "t"
1505 optToStr RevertCAFs = "r"
1507 -- ---------------------------------------------------------------------------
1510 showCmd :: String -> GHCi ()
1514 ["args"] -> io $ putStrLn (show (args st))
1515 ["prog"] -> io $ putStrLn (show (progname st))
1516 ["prompt"] -> io $ putStrLn (show (prompt st))
1517 ["editor"] -> io $ putStrLn (show (editor st))
1518 ["stop"] -> io $ putStrLn (show (stop st))
1519 ["modules" ] -> showModules
1520 ["bindings"] -> showBindings
1521 ["linker"] -> io showLinkerState
1522 ["breaks"] -> showBkptTable
1523 ["context"] -> showContext
1524 ["packages"] -> showPackages
1525 ["languages"] -> showLanguages
1526 _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
1527 " | breaks | context | packages | languages ]"))
1529 showModules :: GHCi ()
1531 loaded_mods <- getLoadedModules
1532 -- we want *loaded* modules only, see #1734
1533 let show_one ms = do m <- GHC.showModule ms; io (putStrLn m)
1534 mapM_ show_one loaded_mods
1536 getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
1537 getLoadedModules = do
1538 graph <- GHC.getModuleGraph
1539 filterM (GHC.isLoaded . GHC.ms_mod_name) graph
1541 showBindings :: GHCi ()
1543 bindings <- GHC.getBindings
1544 docs <- pprTypeAndContents
1545 [ id | AnId id <- sortBy compareTyThings bindings]
1546 printForUserPartWay docs
1548 compareTyThings :: TyThing -> TyThing -> Ordering
1549 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1551 printTyThing :: TyThing -> GHCi ()
1552 printTyThing tyth = do dflags <- getDynFlags
1553 let pefas = dopt Opt_PrintExplicitForalls dflags
1554 printForUser (pprTyThing pefas tyth)
1556 showBkptTable :: GHCi ()
1559 printForUser $ prettyLocations (breaks st)
1561 showContext :: GHCi ()
1563 resumes <- GHC.getResumeContext
1564 printForUser $ vcat (map pp_resume (reverse resumes))
1567 ptext (sLit "--> ") <> text (GHC.resumeStmt resume)
1568 $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume))
1570 showPackages :: GHCi ()
1572 pkg_flags <- fmap packageFlags getDynFlags
1573 io $ putStrLn $ showSDoc $ vcat $
1574 text ("active package flags:"++if null pkg_flags then " none" else "")
1575 : map showFlag pkg_flags
1576 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1577 io $ putStrLn $ showSDoc $ vcat $
1578 text "packages currently loaded:"
1579 : map (nest 2 . text . packageIdString)
1580 (sortBy (compare `on` packageIdFS) pkg_ids)
1581 where showFlag (ExposePackage p) = text $ " -package " ++ p
1582 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1583 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1585 showLanguages :: GHCi ()
1587 dflags <- getDynFlags
1588 io $ putStrLn $ showSDoc $ vcat $
1589 text "active language flags:" :
1590 [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags]
1592 -- -----------------------------------------------------------------------------
1595 completeCmd, completeMacro, completeIdentifier, completeModule,
1596 completeHomeModule, completeSetOptions, completeShowOptions,
1597 completeHomeModuleOrFile, completeExpression
1598 :: CompletionFunc GHCi
1600 ghciCompleteWord :: CompletionFunc GHCi
1601 ghciCompleteWord line@(left,_) = case firstWord of
1602 ':':cmd | null rest -> completeCmd line
1604 completion <- lookupCompletion cmd
1606 "import" -> completeModule line
1607 _ -> completeExpression line
1609 (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
1610 lookupCompletion ('!':_) = return completeFilename
1611 lookupCompletion c = do
1612 maybe_cmd <- liftIO $ lookupCommand' c
1614 Just (_,_,f) -> return f
1615 Nothing -> return completeFilename
1617 completeCmd = wrapCompleter " " $ \w -> do
1618 cmds <- liftIO $ readIORef macros_ref
1619 return (filter (w `isPrefixOf`) (map (':':)
1620 (map cmdName (builtin_commands ++ cmds))))
1622 completeMacro = wrapIdentCompleter $ \w -> do
1623 cmds <- liftIO $ readIORef macros_ref
1624 return (filter (w `isPrefixOf`) (map cmdName cmds))
1626 completeIdentifier = wrapIdentCompleter $ \w -> do
1627 rdrs <- GHC.getRdrNamesInScope
1628 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1630 completeModule = wrapIdentCompleter $ \w -> do
1631 dflags <- GHC.getSessionDynFlags
1632 let pkg_mods = allExposedModules dflags
1633 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
1634 return $ filter (w `isPrefixOf`)
1635 $ map (showSDoc.ppr) $ loaded_mods ++ pkg_mods
1637 completeHomeModule = wrapIdentCompleter listHomeModules
1639 listHomeModules :: String -> GHCi [String]
1640 listHomeModules w = do
1641 g <- GHC.getModuleGraph
1642 let home_mods = map GHC.ms_mod_name g
1643 return $ sort $ filter (w `isPrefixOf`)
1644 $ map (showSDoc.ppr) home_mods
1646 completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
1647 return (filter (w `isPrefixOf`) options)
1648 where options = "args":"prog":"prompt":"editor":"stop":flagList
1649 flagList = map head $ group $ sort allFlags
1651 completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
1652 return (filter (w `isPrefixOf`) options)
1653 where options = ["args", "prog", "prompt", "editor", "stop",
1654 "modules", "bindings", "linker", "breaks",
1655 "context", "packages", "languages"]
1657 completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
1658 $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
1661 unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
1662 unionComplete f1 f2 line = do
1667 wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
1668 wrapCompleter breakChars fun = completeWord Nothing breakChars
1669 $ fmap (map simpleCompletion) . fmap sort . fun
1671 wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
1672 wrapIdentCompleter = wrapCompleter word_break_chars
1674 allExposedModules :: DynFlags -> [ModuleName]
1675 allExposedModules dflags
1676 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1678 pkg_db = pkgIdMap (pkgState dflags)
1680 completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
1683 -- ---------------------------------------------------------------------------
1684 -- User code exception handling
1686 -- This is the exception handler for exceptions generated by the
1687 -- user's code and exceptions coming from children sessions;
1688 -- it normally just prints out the exception. The
1689 -- handler must be recursive, in case showing the exception causes
1690 -- more exceptions to be raised.
1692 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1693 -- raising another exception. We therefore don't put the recursive
1694 -- handler arond the flushing operation, so if stderr is closed
1695 -- GHCi will just die gracefully rather than going into an infinite loop.
1696 handler :: SomeException -> GHCi Bool
1698 handler exception = do
1700 io installSignalHandlers
1701 ghciHandle handler (showException exception >> return False)
1703 showException :: SomeException -> GHCi ()
1705 io $ case fromException se of
1706 Just Interrupted -> putStrLn "Interrupted."
1707 -- omit the location for CmdLineError:
1708 Just (CmdLineError s) -> putStrLn s
1710 Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
1711 Just other_ghc_ex -> print other_ghc_ex
1712 Nothing -> putStrLn ("*** Exception: " ++ show se)
1714 -----------------------------------------------------------------------------
1715 -- recursive exception handlers
1717 -- Don't forget to unblock async exceptions in the handler, or if we're
1718 -- in an exception loop (eg. let a = error a in a) the ^C exception
1719 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1721 ghciHandle :: MonadException m => (SomeException -> m a) -> m a -> m a
1722 ghciHandle h m = Haskeline.catch m $ \e -> unblock (h e)
1724 ghciTry :: GHCi a -> GHCi (Either SomeException a)
1725 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
1727 -- ----------------------------------------------------------------------------
1730 -- TODO: won't work if home dir is encoded.
1731 -- (changeDirectory may not work either in that case.)
1732 expandPath :: MonadIO m => String -> InputT m String
1733 expandPath path = do
1734 exp_path <- liftIO $ expandPathIO path
1735 enc <- fmap BS.unpack $ Encoding.encode exp_path
1738 expandPathIO :: String -> IO String
1740 case dropWhile isSpace path of
1742 tilde <- getHomeDirectory -- will fail if HOME not defined
1743 return (tilde ++ '/':d)
1747 wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
1748 wantInterpretedModule str = do
1749 modl <- lookupModule str
1750 dflags <- getDynFlags
1751 when (GHC.modulePackageId modl /= thisPackage dflags) $
1752 ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
1753 is_interpreted <- GHC.moduleIsInterpreted modl
1754 when (not is_interpreted) $
1755 ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
1758 wantNameFromInterpretedModule :: GHC.GhcMonad m
1759 => (Name -> SDoc -> m ())
1763 wantNameFromInterpretedModule noCanDo str and_then =
1764 handleSourceError (GHC.printExceptionAndWarnings) $ do
1765 names <- GHC.parseName str
1769 let modl = ASSERT( isExternalName n ) GHC.nameModule n
1770 if not (GHC.isExternalName n)
1771 then noCanDo n $ ppr n <>
1772 text " is not defined in an interpreted module"
1774 is_interpreted <- GHC.moduleIsInterpreted modl
1775 if not is_interpreted
1776 then noCanDo n $ text "module " <> ppr modl <>
1777 text " is not interpreted"
1780 -- -----------------------------------------------------------------------------
1781 -- commands for debugger
1783 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1784 sprintCmd = pprintCommand False False
1785 printCmd = pprintCommand True False
1786 forceCmd = pprintCommand False True
1788 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1789 pprintCommand bind force str = do
1790 pprintClosureCommand bind force str
1792 stepCmd :: String -> GHCi ()
1793 stepCmd [] = doContinue (const True) GHC.SingleStep
1794 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1796 stepLocalCmd :: String -> GHCi ()
1797 stepLocalCmd [] = do
1798 mb_span <- getCurrentBreakSpan
1800 Nothing -> stepCmd []
1802 Just mod <- getCurrentBreakModule
1803 current_toplevel_decl <- enclosingTickSpan mod loc
1804 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1806 stepLocalCmd expression = stepCmd expression
1808 stepModuleCmd :: String -> GHCi ()
1809 stepModuleCmd [] = do
1810 mb_span <- getCurrentBreakSpan
1812 Nothing -> stepCmd []
1814 Just span <- getCurrentBreakSpan
1815 let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span
1816 doContinue f GHC.SingleStep
1818 stepModuleCmd expression = stepCmd expression
1820 -- | Returns the span of the largest tick containing the srcspan given
1821 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1822 enclosingTickSpan mod src = do
1823 ticks <- getTickArray mod
1824 let line = srcSpanStartLine src
1825 ASSERT (inRange (bounds ticks) line) do
1826 let enclosing_spans = [ span | (_,span) <- ticks ! line
1827 , srcSpanEnd span >= srcSpanEnd src]
1828 return . head . sortBy leftmost_largest $ enclosing_spans
1830 traceCmd :: String -> GHCi ()
1831 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1832 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1834 continueCmd :: String -> GHCi ()
1835 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1837 -- doContinue :: SingleStep -> GHCi ()
1838 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1839 doContinue pred step = do
1840 runResult <- resume pred step
1841 afterRunStmt pred runResult
1844 abandonCmd :: String -> GHCi ()
1845 abandonCmd = noArgs $ do
1846 b <- GHC.abandon -- the prompt will change to indicate the new context
1847 when (not b) $ io $ putStrLn "There is no computation running."
1850 deleteCmd :: String -> GHCi ()
1851 deleteCmd argLine = do
1852 deleteSwitch $ words argLine
1854 deleteSwitch :: [String] -> GHCi ()
1856 io $ putStrLn "The delete command requires at least one argument."
1857 -- delete all break points
1858 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1859 deleteSwitch idents = do
1860 mapM_ deleteOneBreak idents
1862 deleteOneBreak :: String -> GHCi ()
1864 | all isDigit str = deleteBreak (read str)
1865 | otherwise = return ()
1867 historyCmd :: String -> GHCi ()
1869 | null arg = history 20
1870 | all isDigit arg = history (read arg)
1871 | otherwise = io $ putStrLn "Syntax: :history [num]"
1874 resumes <- GHC.getResumeContext
1876 [] -> io $ putStrLn "Not stopped at a breakpoint"
1878 let hist = GHC.resumeHistory r
1879 (took,rest) = splitAt num hist
1881 [] -> io $ putStrLn $
1882 "Empty history. Perhaps you forgot to use :trace?"
1884 spans <- mapM GHC.getHistorySpan took
1885 let nums = map (printf "-%-3d:") [(1::Int)..]
1886 names = map GHC.historyEnclosingDecl took
1887 printForUser (vcat(zipWith3
1888 (\x y z -> x <+> y <+> z)
1890 (map (bold . ppr) names)
1891 (map (parens . ppr) spans)))
1892 io $ putStrLn $ if null rest then "<end of history>" else "..."
1894 bold :: SDoc -> SDoc
1895 bold c | do_bold = text start_bold <> c <> text end_bold
1898 backCmd :: String -> GHCi ()
1899 backCmd = noArgs $ do
1900 (names, _, span) <- GHC.back
1901 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span
1902 printTypeOfNames names
1903 -- run the command set with ":set stop <cmd>"
1905 enqueueCommands [stop st]
1907 forwardCmd :: String -> GHCi ()
1908 forwardCmd = noArgs $ do
1909 (names, ix, span) <- GHC.forward
1910 printForUser $ (if (ix == 0)
1911 then ptext (sLit "Stopped at")
1912 else ptext (sLit "Logged breakpoint at")) <+> ppr span
1913 printTypeOfNames names
1914 -- run the command set with ":set stop <cmd>"
1916 enqueueCommands [stop st]
1918 -- handle the "break" command
1919 breakCmd :: String -> GHCi ()
1920 breakCmd argLine = do
1921 breakSwitch $ words argLine
1923 breakSwitch :: [String] -> GHCi ()
1925 io $ putStrLn "The break command requires at least one argument."
1926 breakSwitch (arg1:rest)
1927 | looksLikeModuleName arg1 && not (null rest) = do
1928 mod <- wantInterpretedModule arg1
1929 breakByModule mod rest
1930 | all isDigit arg1 = do
1931 (toplevel, _) <- GHC.getContext
1933 (mod : _) -> breakByModuleLine mod (read arg1) rest
1935 io $ putStrLn "Cannot find default module for breakpoint."
1936 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1937 | otherwise = do -- try parsing it as an identifier
1938 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1939 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1940 if GHC.isGoodSrcLoc loc
1941 then ASSERT( isExternalName name )
1942 findBreakAndSet (GHC.nameModule name) $
1943 findBreakByCoord (Just (GHC.srcLocFile loc))
1944 (GHC.srcLocLine loc,
1946 else noCanDo name $ text "can't find its location: " <> ppr loc
1948 noCanDo n why = printForUser $
1949 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1951 breakByModule :: Module -> [String] -> GHCi ()
1952 breakByModule mod (arg1:rest)
1953 | all isDigit arg1 = do -- looks like a line number
1954 breakByModuleLine mod (read arg1) rest
1958 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1959 breakByModuleLine mod line args
1960 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1961 | [col] <- args, all isDigit col =
1962 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1963 | otherwise = breakSyntax
1966 breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1968 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1969 findBreakAndSet mod lookupTickTree = do
1970 tickArray <- getTickArray mod
1971 (breakArray, _) <- getModBreak mod
1972 case lookupTickTree tickArray of
1973 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1974 Just (tick, span) -> do
1975 success <- io $ setBreakFlag True breakArray tick
1979 recordBreak $ BreakLocation
1986 text "Breakpoint " <> ppr nm <>
1988 then text " was already set at " <> ppr span
1989 else text " activated at " <> ppr span
1991 printForUser $ text "Breakpoint could not be activated at"
1994 -- When a line number is specified, the current policy for choosing
1995 -- the best breakpoint is this:
1996 -- - the leftmost complete subexpression on the specified line, or
1997 -- - the leftmost subexpression starting on the specified line, or
1998 -- - the rightmost subexpression enclosing the specified line
2000 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2001 findBreakByLine line arr
2002 | not (inRange (bounds arr) line) = Nothing
2004 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
2005 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2006 listToMaybe (sortBy (rightmost `on` snd) ticks)
2010 starts_here = [ tick | tick@(_,span) <- ticks,
2011 GHC.srcSpanStartLine span == line ]
2013 (complete,incomplete) = partition ends_here starts_here
2014 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2016 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2017 -> Maybe (BreakIndex,SrcSpan)
2018 findBreakByCoord mb_file (line, col) arr
2019 | not (inRange (bounds arr) line) = Nothing
2021 listToMaybe (sortBy (rightmost `on` snd) contains ++
2022 sortBy (leftmost_smallest `on` snd) after_here)
2026 -- the ticks that span this coordinate
2027 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2028 is_correct_file span ]
2030 is_correct_file span
2031 | Just f <- mb_file = GHC.srcSpanFile span == f
2034 after_here = [ tick | tick@(_,span) <- ticks,
2035 GHC.srcSpanStartLine span == line,
2036 GHC.srcSpanStartCol span >= col ]
2038 -- For now, use ANSI bold on terminals that we know support it.
2039 -- Otherwise, we add a line of carets under the active expression instead.
2040 -- In particular, on Windows and when running the testsuite (which sets
2041 -- TERM to vt100 for other reasons) we get carets.
2042 -- We really ought to use a proper termcap/terminfo library.
2044 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2045 where mTerm = System.Environment.getEnv "TERM"
2046 `catchIO` \_ -> return "TERM not set"
2048 start_bold :: String
2049 start_bold = "\ESC[1m"
2051 end_bold = "\ESC[0m"
2053 listCmd :: String -> InputT GHCi ()
2055 mb_span <- lift getCurrentBreakSpan
2058 printForUser' $ text "Not stopped at a breakpoint; nothing to list"
2060 | GHC.isGoodSrcSpan span -> listAround span True
2062 do resumes <- GHC.getResumeContext
2064 [] -> panic "No resumes"
2066 do let traceIt = case GHC.resumeHistory r of
2067 [] -> text "rerunning with :trace,"
2069 doWhat = traceIt <+> text ":back then :list"
2070 printForUser' (text "Unable to list source for" <+>
2072 $$ text "Try" <+> doWhat)
2073 listCmd str = list2 (words str)
2075 list2 :: [String] -> InputT GHCi ()
2076 list2 [arg] | all isDigit arg = do
2077 (toplevel, _) <- GHC.getContext
2079 [] -> outputStrLn "No module to list"
2080 (mod : _) -> listModuleLine mod (read arg)
2081 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2082 mod <- wantInterpretedModule arg1
2083 listModuleLine mod (read arg2)
2085 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2086 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2087 if GHC.isGoodSrcLoc loc
2089 tickArray <- ASSERT( isExternalName name )
2090 lift $ getTickArray (GHC.nameModule name)
2091 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2092 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2095 Nothing -> listAround (GHC.srcLocSpan loc) False
2096 Just (_,span) -> listAround span False
2098 noCanDo name $ text "can't find its location: " <>
2101 noCanDo n why = printForUser' $
2102 text "cannot list source code for " <> ppr n <> text ": " <> why
2104 outputStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2106 listModuleLine :: Module -> Int -> InputT GHCi ()
2107 listModuleLine modl line = do
2108 graph <- GHC.getModuleGraph
2109 let this = filter ((== modl) . GHC.ms_mod) graph
2111 [] -> panic "listModuleLine"
2113 let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
2114 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2115 listAround (GHC.srcLocSpan loc) False
2117 -- | list a section of a source file around a particular SrcSpan.
2118 -- If the highlight flag is True, also highlight the span using
2119 -- start_bold\/end_bold.
2121 -- GHC files are UTF-8, so we can implement this by:
2122 -- 1) read the file in as a BS and syntax highlight it as before
2123 -- 2) convert the BS to String using utf-string, and write it out.
2124 -- It would be better if we could convert directly between UTF-8 and the
2125 -- console encoding, of course.
2126 listAround :: MonadIO m => SrcSpan -> Bool -> InputT m ()
2127 listAround span do_highlight = do
2128 contents <- liftIO $ BS.readFile (unpackFS file)
2130 lines = BS.split '\n' contents
2131 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2132 drop (line1 - 1 - pad_before) $ lines
2133 fst_line = max 1 (line1 - pad_before)
2134 line_nos = [ fst_line .. ]
2136 highlighted | do_highlight = zipWith highlight line_nos these_lines
2137 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2139 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2140 prefixed = zipWith ($) highlighted bs_line_nos
2142 let output = BS.intercalate (BS.pack "\n") prefixed
2143 utf8Decoded <- liftIO $ BS.useAsCStringLen output
2144 $ \(p,n) -> utf8DecodeString (castPtr p) n
2145 outputStrLn utf8Decoded
2147 file = GHC.srcSpanFile span
2148 line1 = GHC.srcSpanStartLine span
2149 col1 = GHC.srcSpanStartCol span
2150 line2 = GHC.srcSpanEndLine span
2151 col2 = GHC.srcSpanEndCol span
2153 pad_before | line1 == 1 = 0
2157 highlight | do_bold = highlight_bold
2158 | otherwise = highlight_carets
2160 highlight_bold no line prefix
2161 | no == line1 && no == line2
2162 = let (a,r) = BS.splitAt col1 line
2163 (b,c) = BS.splitAt (col2-col1) r
2165 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2167 = let (a,b) = BS.splitAt col1 line in
2168 BS.concat [prefix, a, BS.pack start_bold, b]
2170 = let (a,b) = BS.splitAt col2 line in
2171 BS.concat [prefix, a, BS.pack end_bold, b]
2172 | otherwise = BS.concat [prefix, line]
2174 highlight_carets no line prefix
2175 | no == line1 && no == line2
2176 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2177 BS.replicate (col2-col1) '^']
2179 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2182 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2184 | otherwise = BS.concat [prefix, line]
2186 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2187 nl = BS.singleton '\n'
2189 -- --------------------------------------------------------------------------
2192 getTickArray :: Module -> GHCi TickArray
2193 getTickArray modl = do
2195 let arrmap = tickarrays st
2196 case lookupModuleEnv arrmap modl of
2197 Just arr -> return arr
2199 (_breakArray, ticks) <- getModBreak modl
2200 let arr = mkTickArray (assocs ticks)
2201 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2204 discardTickArrays :: GHCi ()
2205 discardTickArrays = do
2207 setGHCiState st{tickarrays = emptyModuleEnv}
2209 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2211 = accumArray (flip (:)) [] (1, max_line)
2212 [ (line, (nm,span)) | (nm,span) <- ticks,
2213 line <- srcSpanLines span ]
2215 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2216 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2217 GHC.srcSpanEndLine span ]
2219 lookupModule :: GHC.GhcMonad m => String -> m Module
2220 lookupModule modName
2221 = GHC.lookupModule (GHC.mkModuleName modName) Nothing
2223 -- don't reset the counter back to zero?
2224 discardActiveBreakPoints :: GHCi ()
2225 discardActiveBreakPoints = do
2227 mapM (turnOffBreak.snd) (breaks st)
2228 setGHCiState $ st { breaks = [] }
2230 deleteBreak :: Int -> GHCi ()
2231 deleteBreak identity = do
2233 let oldLocations = breaks st
2234 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2236 then printForUser (text "Breakpoint" <+> ppr identity <+>
2237 text "does not exist")
2239 mapM (turnOffBreak.snd) this
2240 setGHCiState $ st { breaks = rest }
2242 turnOffBreak :: BreakLocation -> GHCi Bool
2243 turnOffBreak loc = do
2244 (arr, _) <- getModBreak (breakModule loc)
2245 io $ setBreakFlag False arr (breakTick loc)
2247 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2248 getModBreak mod = do
2249 Just mod_info <- GHC.getModuleInfo mod
2250 let modBreaks = GHC.modInfoModBreaks mod_info
2251 let array = GHC.modBreaks_flags modBreaks
2252 let ticks = GHC.modBreaks_locs modBreaks
2253 return (array, ticks)
2255 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2256 setBreakFlag toggle array index
2257 | toggle = GHC.setBreakOn array index
2258 | otherwise = GHC.setBreakOff array index