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) )
99 import GHC.IO.Handle ( hFlushAll )
101 import GHC.IOBase ( IOErrorType(InvalidArgument) )
104 import GHC.TopHandler
106 import Data.IORef ( IORef, readIORef, writeIORef )
108 -----------------------------------------------------------------------------
110 ghciWelcomeMsg :: String
111 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
112 ": http://www.haskell.org/ghc/ :? for help"
114 cmdName :: Command -> String
117 GLOBAL_VAR(macros_ref, [], [Command])
119 builtin_commands :: [Command]
121 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
122 ("?", keepGoing help, noCompletion),
123 ("add", keepGoingPaths addModule, completeFilename),
124 ("abandon", keepGoing abandonCmd, noCompletion),
125 ("break", keepGoing breakCmd, completeIdentifier),
126 ("back", keepGoing backCmd, noCompletion),
127 ("browse", keepGoing' (browseCmd False), completeModule),
128 ("browse!", keepGoing' (browseCmd True), completeModule),
129 ("cd", keepGoing' changeDirectory, completeFilename),
130 ("check", keepGoing' checkModule, completeHomeModule),
131 ("continue", keepGoing continueCmd, noCompletion),
132 ("cmd", keepGoing cmdCmd, completeExpression),
133 ("ctags", keepGoing createCTagsFileCmd, completeFilename),
134 ("def", keepGoing (defineMacro False), completeExpression),
135 ("def!", keepGoing (defineMacro True), completeExpression),
136 ("delete", keepGoing deleteCmd, noCompletion),
137 ("e", keepGoing editFile, completeFilename),
138 ("edit", keepGoing editFile, completeFilename),
139 ("etags", keepGoing createETagsFileCmd, completeFilename),
140 ("force", keepGoing forceCmd, completeExpression),
141 ("forward", keepGoing forwardCmd, noCompletion),
142 ("help", keepGoing help, noCompletion),
143 ("history", keepGoing historyCmd, noCompletion),
144 ("info", keepGoing' info, completeIdentifier),
145 ("kind", keepGoing' kindOfType, completeIdentifier),
146 ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),
147 ("list", keepGoing' listCmd, noCompletion),
148 ("module", keepGoing setContext, completeModule),
149 ("main", keepGoing runMain, completeFilename),
150 ("print", keepGoing printCmd, completeExpression),
151 ("quit", quit, noCompletion),
152 ("reload", keepGoing' reloadModule, noCompletion),
153 ("run", keepGoing runRun, completeFilename),
154 ("set", keepGoing setCmd, completeSetOptions),
155 ("show", keepGoing showCmd, completeShowOptions),
156 ("sprint", keepGoing sprintCmd, completeExpression),
157 ("step", keepGoing stepCmd, completeIdentifier),
158 ("steplocal", keepGoing stepLocalCmd, completeIdentifier),
159 ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),
160 ("type", keepGoing' typeOfExpr, completeExpression),
161 ("trace", keepGoing traceCmd, completeExpression),
162 ("undef", keepGoing undefineMacro, completeMacro),
163 ("unset", keepGoing unsetOptions, completeSetOptions)
167 -- We initialize readline (in the interactiveUI function) to use
168 -- word_break_chars as the default set of completion word break characters.
169 -- This can be overridden for a particular command (for example, filename
170 -- expansion shouldn't consider '/' to be a word break) by setting the third
171 -- entry in the Command tuple above.
173 -- NOTE: in order for us to override the default correctly, any custom entry
174 -- must be a SUBSET of word_break_chars.
175 word_break_chars :: String
176 word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
177 specials = "(),;[]`{}"
179 in spaces ++ specials ++ symbols
181 flagWordBreakChars :: String
182 flagWordBreakChars = " \t\n"
185 keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)
186 keepGoing a str = keepGoing' (lift . a) str
188 keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool
189 keepGoing' a str = a str >> return False
191 keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
193 = do case toArgs str of
194 Left err -> Encoding.encode err >>= liftIO . BS.hPutStrLn stderr
198 shortHelpText :: String
199 shortHelpText = "use :? for help.\n"
203 " Commands available from the prompt:\n" ++
205 " <statement> evaluate/run <statement>\n" ++
206 " : repeat last command\n" ++
207 " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
208 " :add [*]<module> ... add module(s) to the current target set\n" ++
209 " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
210 " (!: more details; *: all top-level names)\n" ++
211 " :cd <dir> change directory to <dir>\n" ++
212 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
213 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
214 " :def <cmd> <expr> define a command :<cmd>\n" ++
215 " :edit <file> edit file\n" ++
216 " :edit edit last module\n" ++
217 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
218 " :help, :? display this list of commands\n" ++
219 " :info [<name> ...] display information about the given names\n" ++
220 " :kind <type> show the kind of <type>\n" ++
221 " :load [*]<module> ... load module(s) and their dependents\n" ++
222 " :main [<arguments> ...] run the main function with the given arguments\n" ++
223 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
224 " :quit exit GHCi\n" ++
225 " :reload reload the current module set\n" ++
226 " :run function [<arguments> ...] run the function with the given arguments\n" ++
227 " :type <expr> show the type of <expr>\n" ++
228 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
229 " :!<command> run the shell command <command>\n" ++
231 " -- Commands for debugging:\n" ++
233 " :abandon at a breakpoint, abandon current computation\n" ++
234 " :back go back in the history (after :trace)\n" ++
235 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
236 " :break <name> set a breakpoint on the specified function\n" ++
237 " :continue resume after a breakpoint\n" ++
238 " :delete <number> delete the specified breakpoint\n" ++
239 " :delete * delete all breakpoints\n" ++
240 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
241 " :forward go forward in the history (after :back)\n" ++
242 " :history [<n>] after :trace, show the execution history\n" ++
243 " :list show the source code around current breakpoint\n" ++
244 " :list identifier show the source code for <identifier>\n" ++
245 " :list [<module>] <line> show the source code around line number <line>\n" ++
246 " :print [<name> ...] prints a value without forcing its computation\n" ++
247 " :sprint [<name> ...] simplifed version of :print\n" ++
248 " :step single-step after stopping at a breakpoint\n"++
249 " :step <expr> single-step into <expr>\n"++
250 " :steplocal single-step within the current top-level binding\n"++
251 " :stepmodule single-step restricted to the current module\n"++
252 " :trace trace after stopping at a breakpoint\n"++
253 " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++
256 " -- Commands for changing settings:\n" ++
258 " :set <option> ... set options\n" ++
259 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
260 " :set prog <progname> set the value returned by System.getProgName\n" ++
261 " :set prompt <prompt> set the prompt used in GHCi\n" ++
262 " :set editor <cmd> set the command used for :edit\n" ++
263 " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" ++
264 " :unset <option> ... unset options\n" ++
266 " Options for ':set' and ':unset':\n" ++
268 " +r revert top-level expressions after each evaluation\n" ++
269 " +s print timing/memory stats after each evaluation\n" ++
270 " +t print type after evaluation\n" ++
271 " -<flags> most GHC command line flags can also be set here\n" ++
272 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
273 " for GHCi-specific flags, see User's Guide,\n"++
274 " Flag reference, Interactive-mode options\n" ++
276 " -- Commands for displaying information:\n" ++
278 " :show bindings show the current bindings made at the prompt\n" ++
279 " :show breaks show the active breakpoints\n" ++
280 " :show context show the breakpoint context\n" ++
281 " :show modules show the currently loaded modules\n" ++
282 " :show packages show the currently active package flags\n" ++
283 " :show languages show the currently active language flags\n" ++
284 " :show <setting> show value of <setting>, which is one of\n" ++
285 " [args, prog, prompt, editor, stop]\n" ++
288 findEditor :: IO String
293 win <- System.Win32.getWindowsDirectory
294 return (win </> "notepad.exe")
299 interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String]
301 interactiveUI srcs maybe_exprs = do
302 -- although GHCi compiles with -prof, it is not usable: the byte-code
303 -- compiler and interpreter don't work with profiling. So we check for
304 -- this up front and emit a helpful error message (#2197)
305 m <- liftIO $ lookupSymbol "PushCostCentre"
307 ghcError (InstallationError "GHCi cannot be used when compiled with -prof")
309 -- HACK! If we happen to get into an infinite loop (eg the user
310 -- types 'let x=x in x' at the prompt), then the thread will block
311 -- on a blackhole, and become unreachable during GC. The GC will
312 -- detect that it is unreachable and send it the NonTermination
313 -- exception. However, since the thread is unreachable, everything
314 -- it refers to might be finalized, including the standard Handles.
315 -- This sounds like a bug, but we don't have a good solution right
317 liftIO $ newStablePtr stdin
318 liftIO $ newStablePtr stdout
319 liftIO $ newStablePtr stderr
321 -- Initialise buffering for the *interpreted* I/O system
324 liftIO $ when (isNothing maybe_exprs) $ do
325 -- Only for GHCi (not runghc and ghc -e):
327 -- Turn buffering off for the compiled program's stdout/stderr
329 -- Turn buffering off for GHCi's stdout
331 hSetBuffering stdout NoBuffering
332 -- We don't want the cmd line to buffer any input that might be
333 -- intended for the program, so unbuffer stdin.
334 hSetBuffering stdin NoBuffering
336 -- initial context is just the Prelude
337 prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing
338 GHC.setContext [] [prel_mod]
340 default_editor <- liftIO $ findEditor
342 startGHCi (runGHCi srcs maybe_exprs)
343 GHCiState{ progname = "<interactive>",
347 editor = default_editor,
348 -- session = session,
353 tickarrays = emptyModuleEnv,
354 last_command = Nothing,
357 ghc_e = isJust maybe_exprs
362 withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
363 withGhcAppData right left = do
364 either_dir <- IO.try (getAppUserDataDirectory "ghc")
366 Right dir -> right dir
369 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
370 runGHCi paths maybe_exprs = do
372 read_dot_files = not opt_IgnoreDotGhci
374 current_dir = return (Just ".ghci")
376 app_user_dir = io $ withGhcAppData
377 (\dir -> return (Just (dir </> "ghci.conf")))
381 either_dir <- io $ IO.try (getEnv "HOME")
383 Right home -> return (Just (home </> ".ghci"))
386 sourceConfigFile :: FilePath -> GHCi ()
387 sourceConfigFile file = do
388 exists <- io $ doesFileExist file
390 dir_ok <- io $ checkPerms (getDirectory file)
391 file_ok <- io $ checkPerms file
392 when (dir_ok && file_ok) $ do
393 either_hdl <- io $ IO.try (openFile file ReadMode)
396 -- NOTE: this assumes that runInputT won't affect the terminal;
397 -- can we assume this will always be the case?
398 -- This would be a good place for runFileInputT.
399 Right hdl -> runInputTWithPrefs defaultPrefs defaultSettings $ do
401 runCommands $ fileLoop hdl
403 getDirectory f = case takeDirectory f of "" -> "."; d -> d
405 when (read_dot_files) $ do
406 cfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
407 cfgs <- io $ mapM canonicalizePath (catMaybes cfgs0)
408 mapM_ sourceConfigFile (nub cfgs)
409 -- nub, because we don't want to read .ghci twice if the
412 -- Perform a :load for files given on the GHCi command line
413 -- When in -e mode, if the load fails then we want to stop
414 -- immediately rather than going on to evaluate the expression.
415 when (not (null paths)) $ do
416 ok <- ghciHandle (\e -> do showException e; return Failed) $
417 -- TODO: this is a hack.
418 runInputTWithPrefs defaultPrefs defaultSettings $ do
419 let (filePaths, phases) = unzip paths
420 filePaths' <- mapM (Encoding.decode . BS.pack) filePaths
421 loadModule (zip filePaths' phases)
422 when (isJust maybe_exprs && failed ok) $
423 io (exitWith (ExitFailure 1))
425 -- if verbosity is greater than 0, or we are connected to a
426 -- terminal, display the prompt in the interactive loop.
427 is_tty <- io (hIsTerminalDevice stdin)
428 dflags <- getDynFlags
429 let show_prompt = verbosity dflags > 0 || is_tty
434 -- enter the interactive loop
435 runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
437 -- just evaluate the expression we were given
438 enqueueCommands exprs
439 let handle e = do st <- getGHCiState
440 -- Jump through some hoops to get the
441 -- current progname in the exception text:
442 -- <progname>: <exception>
443 io $ withProgName (progname st)
444 -- this used to be topHandlerFastExit, see #2228
446 runInputTWithPrefs defaultPrefs defaultSettings $ do
448 runCommands' handle (return Nothing)
451 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
453 runGHCiInput :: InputT GHCi a -> GHCi a
455 histFile <- io $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
457 let settings = setComplete ghciCompleteWord
458 $ defaultSettings {historyFile = histFile}
459 runInputT settings $ do
463 nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
464 nextInputLine show_prompt is_tty
466 prompt <- if show_prompt then lift mkPrompt else return ""
469 when show_prompt $ lift mkPrompt >>= liftIO . putStr
472 -- NOTE: We only read .ghci files if they are owned by the current user,
473 -- and aren't world writable. Otherwise, we could be accidentally
474 -- running code planted by a malicious third party.
476 -- Furthermore, We only read ./.ghci if . is owned by the current user
477 -- and isn't writable by anyone else. I think this is sufficient: we
478 -- don't need to check .. and ../.. etc. because "." always refers to
479 -- the same directory while a process is running.
481 checkPerms :: String -> IO Bool
482 #ifdef mingw32_HOST_OS
487 handleIO (\_ -> return False) $ do
488 st <- getFileStatus name
490 if fileOwner st /= me then do
491 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
494 let mode = fileMode st
495 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
496 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
498 putStrLn $ "*** WARNING: " ++ name ++
499 " is writable by someone else, IGNORING!"
504 fileLoop :: MonadIO m => Handle -> InputT m (Maybe String)
506 l <- liftIO $ IO.try $ hGetLine hdl
508 Left e | isEOFError e -> return Nothing
509 | InvalidArgument <- etype -> return Nothing
510 | otherwise -> liftIO $ ioError e
511 where etype = ioeGetErrorType e
512 -- treat InvalidArgument in the same way as EOF:
513 -- this can happen if the user closed stdin, or
514 -- perhaps did getContents which closes stdin at
516 Right l -> return (Just l)
518 mkPrompt :: GHCi String
520 (toplevs,exports) <- GHC.getContext
521 resumes <- GHC.getResumeContext
522 -- st <- getGHCiState
528 let ix = GHC.resumeHistoryIx r
530 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
532 let hist = GHC.resumeHistory r !! (ix-1)
533 span <- GHC.getHistorySpan hist
534 return (brackets (ppr (negate ix) <> char ':'
535 <+> ppr span) <> space)
537 dots | _:rs <- resumes, not (null rs) = text "... "
544 -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
545 -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
546 -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
547 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
548 hsep (map (ppr . GHC.moduleName) exports)
550 deflt_prompt = dots <> context_bit <> modules_bit
552 f ('%':'s':xs) = deflt_prompt <> f xs
553 f ('%':'%':xs) = char '%' <> f xs
554 f (x:xs) = char x <> f xs
558 return (showSDoc (f (prompt st)))
561 queryQueue :: GHCi (Maybe String)
566 c:cs -> do setGHCiState st{ cmdqueue = cs }
569 runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
570 runCommands = runCommands' handler
572 runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
573 -> InputT GHCi (Maybe String) -> InputT GHCi ()
574 runCommands' eh getCmd = do
575 b <- handleGhcException (\e -> case e of
576 Interrupted -> return False
577 _other -> liftIO (print e) >> return True)
578 (runOneCommand eh getCmd)
579 if b then return () else runCommands' eh getCmd
581 runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
583 runOneCommand eh getCmd = do
584 mb_cmd <- noSpace (lift queryQueue)
585 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
587 Nothing -> return True
588 Just c -> ghciHandle (lift . eh) $
589 handleSourceError printErrorAndKeepGoing
592 printErrorAndKeepGoing err = do
593 GHC.printExceptionAndWarnings err
596 noSpace q = q >>= maybe (return Nothing)
597 (\c->case removeSpaces c of
599 ":{" -> multiLineCmd q
600 c -> return (Just c) )
602 st <- lift getGHCiState
604 lift $ setGHCiState st{ prompt = "%s| " }
605 mb_cmd <- collectCommand q ""
606 lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p }
608 -- we can't use removeSpaces for the sublines here, so
609 -- multiline commands are somewhat more brittle against
610 -- fileformat errors (such as \r in dos input on unix),
611 -- we get rid of any extra spaces for the ":}" test;
612 -- we also avoid silent failure if ":}" is not found;
613 -- and since there is no (?) valid occurrence of \r (as
614 -- opposed to its String representation, "\r") inside a
615 -- ghci command, we replace any such with ' ' (argh:-(
616 collectCommand q c = q >>=
617 maybe (liftIO (ioError collectError))
618 (\l->if removeSpaces l == ":}"
619 then return (Just $ removeSpaces c)
620 else collectCommand q (c++map normSpace l))
621 where normSpace '\r' = ' '
623 -- QUESTION: is userError the one to use here?
624 collectError = userError "unterminated multiline command :{ .. :}"
625 doCommand (':' : cmd) = specialCommand cmd
626 doCommand stmt = do timeIt $ lift $ runStmt stmt GHC.RunToCompletion
629 enqueueCommands :: [String] -> GHCi ()
630 enqueueCommands cmds = do
632 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
635 runStmt :: String -> SingleStep -> GHCi Bool
637 | null (filter (not.isSpace) stmt) = return False
638 | ["import", mod] <- words stmt = keepGoing' setContext ('+':mod)
641 #if __GLASGOW_HASKELL__ >= 611
642 -- In the new IO library, read handles buffer data even if the Handle
643 -- is set to NoBuffering. This causes problems for GHCi where there
644 -- are really two stdin Handles. So we flush any bufferred data in
645 -- GHCi's stdin Handle here (only relevant if stdin is attached to
646 -- a file, otherwise the read buffer can't be flushed).
647 liftIO $ IO.try $ hFlushAll stdin
649 result <- GhciMonad.runStmt stmt step
650 afterRunStmt (const True) result
652 --afterRunStmt :: GHC.RunResult -> GHCi Bool
653 -- False <=> the statement failed to compile
654 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
655 afterRunStmt _ (GHC.RunException e) = throw e
656 afterRunStmt step_here run_result = do
657 resumes <- GHC.getResumeContext
659 GHC.RunOk names -> do
660 show_types <- isOptionSet ShowType
661 when show_types $ printTypeOfNames names
662 GHC.RunBreak _ names mb_info
663 | isNothing mb_info ||
664 step_here (GHC.resumeSpan $ head resumes) -> do
665 mb_id_loc <- toBreakIdAndLocation mb_info
666 let breakCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
668 then printStoppedAtBreakInfo (head resumes) names
669 else enqueueCommands [breakCmd]
670 -- run the command set with ":set stop <cmd>"
672 enqueueCommands [stop st]
674 | otherwise -> resume step_here GHC.SingleStep >>=
675 afterRunStmt step_here >> return ()
679 io installSignalHandlers
680 b <- isOptionSet RevertCAFs
683 return (case run_result of GHC.RunOk _ -> True; _ -> False)
685 toBreakIdAndLocation ::
686 Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
687 toBreakIdAndLocation Nothing = return Nothing
688 toBreakIdAndLocation (Just info) = do
689 let mod = GHC.breakInfo_module info
690 nm = GHC.breakInfo_number info
692 return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
693 breakModule loc == mod,
694 breakTick loc == nm ]
696 printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
697 printStoppedAtBreakInfo resume names = do
698 printForUser $ ptext (sLit "Stopped at") <+>
699 ppr (GHC.resumeSpan resume)
700 -- printTypeOfNames session names
701 let namesSorted = sortBy compareNames names
702 tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
703 docs <- pprTypeAndContents [id | AnId id <- tythings]
704 printForUserPartWay docs
706 printTypeOfNames :: [Name] -> GHCi ()
707 printTypeOfNames names
708 = mapM_ (printTypeOfName ) $ sortBy compareNames names
710 compareNames :: Name -> Name -> Ordering
711 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
712 where compareWith n = (getOccString n, getSrcSpan n)
714 printTypeOfName :: Name -> GHCi ()
716 = do maybe_tything <- GHC.lookupName n
717 case maybe_tything of
719 Just thing -> printTyThing thing
722 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
724 specialCommand :: String -> InputT GHCi Bool
725 specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
726 specialCommand str = do
727 let (cmd,rest) = break isSpace str
728 maybe_cmd <- lift $ lookupCommand cmd
730 GotCommand (_,f,_) -> f (dropWhile isSpace rest)
732 do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
736 do liftIO $ hPutStr stdout ("there is no last command to perform\n"
740 lookupCommand :: String -> GHCi (MaybeCommand)
741 lookupCommand "" = do
743 case last_command st of
744 Just c -> return $ GotCommand c
745 Nothing -> return NoLastCommand
746 lookupCommand str = do
747 mc <- io $ lookupCommand' str
749 setGHCiState st{ last_command = mc }
751 Just c -> GotCommand c
752 Nothing -> BadCommand
754 lookupCommand' :: String -> IO (Maybe Command)
755 lookupCommand' str = do
756 macros <- readIORef macros_ref
757 let cmds = builtin_commands ++ macros
758 -- look for exact match first, then the first prefix match
759 return $ case [ c | c <- cmds, str == cmdName c ] of
761 [] -> case [ c | c@(s,_,_) <- cmds, str `isPrefixOf` s ] of
765 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
766 getCurrentBreakSpan = do
767 resumes <- GHC.getResumeContext
771 let ix = GHC.resumeHistoryIx r
773 then return (Just (GHC.resumeSpan r))
775 let hist = GHC.resumeHistory r !! (ix-1)
776 span <- GHC.getHistorySpan hist
779 getCurrentBreakModule :: GHCi (Maybe Module)
780 getCurrentBreakModule = do
781 resumes <- GHC.getResumeContext
785 let ix = GHC.resumeHistoryIx r
787 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
789 let hist = GHC.resumeHistory r !! (ix-1)
790 return $ Just $ GHC.getHistoryModule hist
792 -----------------------------------------------------------------------------
795 noArgs :: GHCi () -> String -> GHCi ()
797 noArgs _ _ = io $ putStrLn "This command takes no arguments"
799 help :: String -> GHCi ()
800 help _ = io (putStr helpText)
802 info :: String -> InputT GHCi ()
803 info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
804 info s = handleSourceError GHC.printExceptionAndWarnings $ do
805 { let names = words s
806 ; dflags <- getDynFlags
807 ; let pefas = dopt Opt_PrintExplicitForalls dflags
808 ; mapM_ (infoThing pefas) names }
810 infoThing pefas str = do
811 names <- GHC.parseName str
812 mb_stuffs <- mapM GHC.getInfo names
813 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
814 unqual <- GHC.getPrintUnqual
815 outputStrLn $ showSDocForUser unqual $
816 vcat (intersperse (text "") $
817 map (pprInfo pefas) filtered)
819 -- Filter out names whose parent is also there Good
820 -- example is '[]', which is both a type and data
821 -- constructor in the same type
822 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
823 filterOutChildren get_thing xs
824 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
826 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
828 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
829 pprInfo pefas (thing, fixity, insts)
830 = pprTyThingInContextLoc pefas thing
831 $$ show_fixity fixity
832 $$ vcat (map GHC.pprInstance insts)
835 | fix == GHC.defaultFixity = empty
836 | otherwise = ppr fix <+> ppr (GHC.getName thing)
838 runMain :: String -> GHCi ()
839 runMain s = case toArgs s of
840 Left err -> io (hPutStrLn stderr err)
842 do dflags <- getDynFlags
843 case mainFunIs dflags of
844 Nothing -> doWithArgs args "main"
845 Just f -> doWithArgs args f
847 runRun :: String -> GHCi ()
848 runRun s = case toCmdArgs s of
849 Left err -> io (hPutStrLn stderr err)
850 Right (cmd, args) -> doWithArgs args cmd
852 doWithArgs :: [String] -> String -> GHCi ()
853 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
854 show args ++ " (" ++ cmd ++ ")"]
856 addModule :: [FilePath] -> InputT GHCi ()
858 lift revertCAFs -- always revert CAFs on load/add.
859 files <- mapM expandPath files
860 targets <- mapM (\m -> GHC.guessTarget m Nothing) files
861 -- remove old targets with the same id; e.g. for :add *M
862 mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
863 mapM_ GHC.addTarget targets
864 prev_context <- GHC.getContext
865 ok <- trySuccess $ GHC.load LoadAllTargets
866 afterLoad ok False prev_context
868 changeDirectory :: String -> InputT GHCi ()
869 changeDirectory "" = do
870 -- :cd on its own changes to the user's home directory
871 either_dir <- liftIO $ IO.try getHomeDirectory
874 Right dir -> changeDirectory dir
875 changeDirectory dir = do
876 graph <- GHC.getModuleGraph
877 when (not (null graph)) $
878 outputStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
879 prev_context <- GHC.getContext
881 GHC.load LoadAllTargets
882 lift $ setContextAfterLoad prev_context False []
883 GHC.workingDirectoryChanged
884 dir <- expandPath dir
885 liftIO $ setCurrentDirectory dir
887 trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
889 handleSourceError (\e -> do GHC.printExceptionAndWarnings e
893 editFile :: String -> GHCi ()
895 do file <- if null str then chooseEditFile else return str
899 $ ghcError (CmdLineError "editor not set, use :set editor")
900 io $ system (cmd ++ ' ':file)
903 -- The user didn't specify a file so we pick one for them.
904 -- Our strategy is to pick the first module that failed to load,
905 -- or otherwise the first target.
907 -- XXX: Can we figure out what happened if the depndecy analysis fails
908 -- (e.g., because the porgrammeer mistyped the name of a module)?
909 -- XXX: Can we figure out the location of an error to pass to the editor?
910 -- XXX: if we could figure out the list of errors that occured during the
911 -- last load/reaload, then we could start the editor focused on the first
913 chooseEditFile :: GHCi String
915 do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
917 graph <- GHC.getModuleGraph
918 failed_graph <- filterM hasFailed graph
919 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
921 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
924 case pick (order failed_graph) of
925 Just file -> return file
927 do targets <- GHC.getTargets
928 case msum (map fromTarget targets) of
929 Just file -> return file
930 Nothing -> ghcError (CmdLineError "No files to edit.")
932 where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
933 fromTarget _ = Nothing -- when would we get a module target?
935 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
936 defineMacro overwrite s = do
937 let (macro_name, definition) = break isSpace s
938 macros <- io (readIORef macros_ref)
939 let defined = map cmdName macros
942 then io $ putStrLn "no macros defined"
943 else io $ putStr ("the following macros are defined:\n" ++
946 if (not overwrite && macro_name `elem` defined)
947 then ghcError (CmdLineError
948 ("macro '" ++ macro_name ++ "' is already defined"))
951 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
953 -- give the expression a type signature, so we can be sure we're getting
954 -- something of the right type.
955 let new_expr = '(' : definition ++ ") :: String -> IO String"
957 -- compile the expression
958 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
959 hv <- GHC.compileExpr new_expr
960 io (writeIORef macros_ref --
961 (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)]))
963 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
965 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
966 -- make sure we force any exceptions in the result, while we are still
967 -- inside the exception handler for commands:
968 seqList str (return ())
969 enqueueCommands (lines str)
972 undefineMacro :: String -> GHCi ()
973 undefineMacro str = mapM_ undef (words str)
974 where undef macro_name = do
975 cmds <- io (readIORef macros_ref)
976 if (macro_name `notElem` map cmdName cmds)
977 then ghcError (CmdLineError
978 ("macro '" ++ macro_name ++ "' is not defined"))
980 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
982 cmdCmd :: String -> GHCi ()
984 let expr = '(' : str ++ ") :: IO String"
985 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
986 hv <- GHC.compileExpr expr
987 cmds <- io $ (unsafeCoerce# hv :: IO String)
988 enqueueCommands (lines cmds)
991 loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
992 loadModule fs = timeIt (loadModule' fs)
994 loadModule_ :: [FilePath] -> InputT GHCi ()
995 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
997 loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
998 loadModule' files = do
999 prev_context <- GHC.getContext
1003 lift discardActiveBreakPoints
1005 GHC.load LoadAllTargets
1007 let (filenames, phases) = unzip files
1008 exp_filenames <- mapM expandPath filenames
1009 let files' = zip exp_filenames phases
1010 targets <- mapM (uncurry GHC.guessTarget) files'
1012 -- NOTE: we used to do the dependency anal first, so that if it
1013 -- fails we didn't throw away the current set of modules. This would
1014 -- require some re-working of the GHC interface, so we'll leave it
1015 -- as a ToDo for now.
1017 GHC.setTargets targets
1018 doLoad False prev_context LoadAllTargets
1020 checkModule :: String -> InputT GHCi ()
1022 let modl = GHC.mkModuleName m
1023 prev_context <- GHC.getContext
1024 ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do
1025 r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
1026 outputStrLn (showSDoc (
1027 case GHC.moduleInfo r of
1028 cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1030 (local,global) = ASSERT( all isExternalName scope )
1031 partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1033 (text "global names: " <+> ppr global) $$
1034 (text "local names: " <+> ppr local)
1037 afterLoad (successIf ok) False prev_context
1039 reloadModule :: String -> InputT GHCi ()
1041 prev_context <- GHC.getContext
1042 doLoad True prev_context $
1043 if null m then LoadAllTargets
1044 else LoadUpTo (GHC.mkModuleName m)
1047 doLoad :: Bool -> ([Module],[Module]) -> LoadHowMuch -> InputT GHCi SuccessFlag
1048 doLoad retain_context prev_context howmuch = do
1049 -- turn off breakpoints before we load: we can't turn them off later, because
1050 -- the ModBreaks will have gone away.
1051 lift discardActiveBreakPoints
1052 ok <- trySuccess $ GHC.load howmuch
1053 afterLoad ok retain_context prev_context
1056 afterLoad :: SuccessFlag -> Bool -> ([Module],[Module]) -> InputT GHCi ()
1057 afterLoad ok retain_context prev_context = do
1058 lift revertCAFs -- always revert CAFs on load.
1059 lift discardTickArrays
1060 loaded_mod_summaries <- getLoadedModules
1061 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1062 loaded_mod_names = map GHC.moduleName loaded_mods
1063 modulesLoadedMsg ok loaded_mod_names
1065 lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
1068 setContextAfterLoad :: ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi ()
1069 setContextAfterLoad prev keep_ctxt [] = do
1070 prel_mod <- getPrelude
1071 setContextKeepingPackageModules prev keep_ctxt ([], [prel_mod])
1072 setContextAfterLoad prev keep_ctxt ms = do
1073 -- load a target if one is available, otherwise load the topmost module.
1074 targets <- GHC.getTargets
1075 case [ m | Just m <- map (findTarget ms) targets ] of
1077 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1078 load_this (last graph')
1083 = case filter (`matches` t) ms of
1087 summary `matches` Target (TargetModule m) _ _
1088 = GHC.ms_mod_name summary == m
1089 summary `matches` Target (TargetFile f _) _ _
1090 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1094 load_this summary | m <- GHC.ms_mod summary = do
1095 b <- GHC.moduleIsInterpreted m
1096 if b then setContextKeepingPackageModules prev keep_ctxt ([m], [])
1098 prel_mod <- getPrelude
1099 setContextKeepingPackageModules prev keep_ctxt ([],[prel_mod,m])
1101 -- | Keep any package modules (except Prelude) when changing the context.
1102 setContextKeepingPackageModules
1103 :: ([Module],[Module]) -- previous context
1104 -> Bool -- re-execute :module commands
1105 -> ([Module],[Module]) -- new context
1107 setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do
1108 let (_,bs0) = prev_context
1109 prel_mod <- getPrelude
1110 let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1111 let bs1 = if null as then nub (prel_mod : bs) else bs
1112 GHC.setContext as (nub (bs1 ++ pkg_modules))
1116 mapM_ (playCtxtCmd False) (remembered_ctx st)
1119 setGHCiState st{ remembered_ctx = [] }
1121 isHomeModule :: Module -> Bool
1122 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1124 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi ()
1125 modulesLoadedMsg ok mods = do
1126 dflags <- getDynFlags
1127 when (verbosity dflags > 0) $ do
1129 | null mods = text "none."
1130 | otherwise = hsep (
1131 punctuate comma (map ppr mods)) <> text "."
1134 outputStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))
1136 outputStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas))
1139 typeOfExpr :: String -> InputT GHCi ()
1141 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1142 ty <- GHC.exprType str
1143 dflags <- getDynFlags
1144 let pefas = dopt Opt_PrintExplicitForalls dflags
1145 printForUser' $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]
1147 kindOfType :: String -> InputT GHCi ()
1149 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1150 ty <- GHC.typeKind str
1151 printForUser' $ text str <+> dcolon <+> ppr ty
1153 quit :: String -> InputT GHCi Bool
1154 quit _ = return True
1156 shellEscape :: String -> GHCi Bool
1157 shellEscape str = io (system str >> return False)
1159 -----------------------------------------------------------------------------
1160 -- Browsing a module's contents
1162 browseCmd :: Bool -> String -> InputT GHCi ()
1165 ['*':s] | looksLikeModuleName s -> do
1166 m <- lift $ wantInterpretedModule s
1167 browseModule bang m False
1168 [s] | looksLikeModuleName s -> do
1169 m <- lift $ lookupModule s
1170 browseModule bang m True
1172 (as,bs) <- GHC.getContext
1173 -- Guess which module the user wants to browse. Pick
1174 -- modules that are interpreted first. The most
1175 -- recently-added module occurs last, it seems.
1177 (as@(_:_), _) -> browseModule bang (last as) True
1178 ([], bs@(_:_)) -> browseModule bang (last bs) True
1179 ([], []) -> ghcError (CmdLineError ":browse: no current module")
1180 _ -> ghcError (CmdLineError "syntax: :browse <module>")
1182 -- without bang, show items in context of their parents and omit children
1183 -- with bang, show class methods and data constructors separately, and
1184 -- indicate import modules, to aid qualifying unqualified names
1185 -- with sorted, sort items alphabetically
1186 browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
1187 browseModule bang modl exports_only = do
1188 -- :browse! reports qualifiers wrt current context
1189 current_unqual <- GHC.getPrintUnqual
1190 -- Temporarily set the context to the module we're interested in,
1191 -- just so we can get an appropriate PrintUnqualified
1192 (as,bs) <- GHC.getContext
1193 prel_mod <- lift getPrelude
1194 if exports_only then GHC.setContext [] [prel_mod,modl]
1195 else GHC.setContext [modl] []
1196 target_unqual <- GHC.getPrintUnqual
1197 GHC.setContext as bs
1199 let unqual = if bang then current_unqual else target_unqual
1201 mb_mod_info <- GHC.getModuleInfo modl
1203 Nothing -> ghcError (CmdLineError ("unknown module: " ++
1204 GHC.moduleNameString (GHC.moduleName modl)))
1206 dflags <- getDynFlags
1208 | exports_only = GHC.modInfoExports mod_info
1209 | otherwise = GHC.modInfoTopLevelScope mod_info
1212 -- sort alphabetically name, but putting
1213 -- locally-defined identifiers first.
1214 -- We would like to improve this; see #1799.
1215 sorted_names = loc_sort local ++ occ_sort external
1217 (local,external) = ASSERT( all isExternalName names )
1218 partition ((==modl) . nameModule) names
1219 occ_sort = sortBy (compare `on` nameOccName)
1220 -- try to sort by src location. If the first name in
1221 -- our list has a good source location, then they all should.
1223 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1224 = sortBy (compare `on` nameSrcSpan) names
1228 mb_things <- mapM GHC.lookupName sorted_names
1229 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1231 rdr_env <- GHC.getGRE
1233 let pefas = dopt Opt_PrintExplicitForalls dflags
1234 things | bang = catMaybes mb_things
1235 | otherwise = filtered_things
1236 pretty | bang = pprTyThing
1237 | otherwise = pprTyThingInContext
1239 labels [] = text "-- not currently imported"
1240 labels l = text $ intercalate "\n" $ map qualifier l
1241 qualifier = maybe "-- defined locally"
1242 (("-- imported via "++) . intercalate ", "
1243 . map GHC.moduleNameString)
1244 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1245 modNames = map (importInfo . GHC.getName) things
1247 -- annotate groups of imports with their import modules
1248 -- the default ordering is somewhat arbitrary, so we group
1249 -- by header and sort groups; the names themselves should
1250 -- really come in order of source appearance.. (trac #1799)
1251 annotate mts = concatMap (\(m,ts)->labels m:ts)
1252 $ sortBy cmpQualifiers $ group mts
1253 where cmpQualifiers =
1254 compare `on` (map (fmap (map moduleNameFS)) . fst)
1256 group mts@((m,_):_) = (m,map snd g) : group ng
1257 where (g,ng) = partition ((==m).fst) mts
1259 let prettyThings = map (pretty pefas) things
1260 prettyThings' | bang = annotate $ zip modNames prettyThings
1261 | otherwise = prettyThings
1262 outputStrLn $ showSDocForUser unqual (vcat prettyThings')
1263 -- ToDo: modInfoInstances currently throws an exception for
1264 -- package modules. When it works, we can do this:
1265 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1267 -----------------------------------------------------------------------------
1268 -- Setting the module context
1270 setContext :: String -> GHCi ()
1272 | all sensible strs = do
1273 playCtxtCmd True (cmd, as, bs)
1275 setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] }
1276 | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1278 (cmd, strs, as, bs) =
1280 '+':stuff -> rest AddModules stuff
1281 '-':stuff -> rest RemModules stuff
1282 stuff -> rest SetContext stuff
1284 rest cmd stuff = (cmd, strs, as, bs)
1285 where strs = words stuff
1286 (as,bs) = partitionWith starred strs
1288 sensible ('*':m) = looksLikeModuleName m
1289 sensible m = looksLikeModuleName m
1291 starred ('*':m) = Left m
1294 playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi ()
1295 playCtxtCmd fail (cmd, as, bs)
1297 (as',bs') <- do_checks fail
1298 (prev_as,prev_bs) <- GHC.getContext
1302 prel_mod <- getPrelude
1303 let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs'
1307 let as_to_add = as' \\ (prev_as ++ prev_bs)
1308 bs_to_add = bs' \\ (prev_as ++ prev_bs)
1309 return (prev_as ++ as_to_add, prev_bs ++ bs_to_add)
1311 let new_as = prev_as \\ (as' ++ bs')
1312 new_bs = prev_bs \\ (as' ++ bs')
1313 return (new_as, new_bs)
1314 GHC.setContext new_as new_bs
1317 as' <- mapM wantInterpretedModule as
1318 bs' <- mapM lookupModule bs
1320 do_checks False = do
1321 as' <- mapM (trymaybe . wantInterpretedModule) as
1322 bs' <- mapM (trymaybe . lookupModule) bs
1323 return (catMaybes as', catMaybes bs')
1328 Left _ -> return Nothing
1329 Right a -> return (Just a)
1331 ----------------------------------------------------------------------------
1334 -- set options in the interpreter. Syntax is exactly the same as the
1335 -- ghc command line, except that certain options aren't available (-C,
1338 -- This is pretty fragile: most options won't work as expected. ToDo:
1339 -- figure out which ones & disallow them.
1341 setCmd :: String -> GHCi ()
1343 = do st <- getGHCiState
1344 let opts = options st
1345 io $ putStrLn (showSDoc (
1346 text "options currently set: " <>
1349 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1351 dflags <- getDynFlags
1352 io $ putStrLn (showSDoc (
1353 vcat (text "GHCi-specific dynamic flag settings:"
1354 :map (flagSetting dflags) ghciFlags)
1356 io $ putStrLn (showSDoc (
1357 vcat (text "other dynamic, non-language, flag settings:"
1358 :map (flagSetting dflags) nonLanguageDynFlags)
1360 where flagSetting dflags (str, f, _)
1361 | dopt f dflags = text " " <> text "-f" <> text str
1362 | otherwise = text " " <> text "-fno-" <> text str
1363 (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags)
1365 nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions)
1367 flags = [Opt_PrintExplicitForalls
1368 ,Opt_PrintBindResult
1369 ,Opt_BreakOnException
1371 ,Opt_PrintEvldWithShow
1374 = case getCmd str of
1375 Right ("args", rest) ->
1377 Left err -> io (hPutStrLn stderr err)
1378 Right args -> setArgs args
1379 Right ("prog", rest) ->
1381 Right [prog] -> setProg prog
1382 _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")
1383 Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1384 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1385 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1386 _ -> case toArgs str of
1387 Left err -> io (hPutStrLn stderr err)
1388 Right wds -> setOptions wds
1390 setArgs, setOptions :: [String] -> GHCi ()
1391 setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
1395 setGHCiState st{ args = args }
1399 setGHCiState st{ progname = prog }
1403 setGHCiState st{ editor = cmd }
1405 setStop str@(c:_) | isDigit c
1406 = do let (nm_str,rest) = break (not.isDigit) str
1409 let old_breaks = breaks st
1410 if all ((/= nm) . fst) old_breaks
1411 then printForUser (text "Breakpoint" <+> ppr nm <+>
1412 text "does not exist")
1414 let new_breaks = map fn old_breaks
1415 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1416 | otherwise = (i,loc)
1417 setGHCiState st{ breaks = new_breaks }
1420 setGHCiState st{ stop = cmd }
1422 setPrompt value = do
1425 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1427 '\"' : _ -> case reads value of
1428 [(value', xs)] | all isSpace xs ->
1429 setGHCiState (st { prompt = value' })
1431 io $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
1432 _ -> setGHCiState (st { prompt = value })
1435 do -- first, deal with the GHCi opts (+s, +t, etc.)
1436 let (plus_opts, minus_opts) = partitionWith isPlus wds
1437 mapM_ setOpt plus_opts
1438 -- then, dynamic flags
1439 newDynFlags minus_opts
1441 newDynFlags :: [String] -> GHCi ()
1442 newDynFlags minus_opts = do
1443 dflags <- getDynFlags
1444 let pkg_flags = packageFlags dflags
1445 (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
1446 handleFlagWarnings dflags' warns
1448 if (not (null leftovers))
1449 then ghcError $ errorsToGhcException leftovers
1452 new_pkgs <- setDynFlags dflags'
1454 -- if the package flags changed, we should reset the context
1455 -- and link the new packages.
1456 dflags <- getDynFlags
1457 when (packageFlags dflags /= pkg_flags) $ do
1458 io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
1460 GHC.load LoadAllTargets
1461 io (linkPackages dflags new_pkgs)
1462 -- package flags changed, we can't re-use any of the old context
1463 setContextAfterLoad ([],[]) False []
1467 unsetOptions :: String -> GHCi ()
1469 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1470 let opts = words str
1471 (minus_opts, rest1) = partition isMinus opts
1472 (plus_opts, rest2) = partitionWith isPlus rest1
1474 if (not (null rest2))
1475 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1478 mapM_ unsetOpt plus_opts
1480 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1481 no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
1483 no_flags <- mapM no_flag minus_opts
1484 newDynFlags no_flags
1486 isMinus :: String -> Bool
1487 isMinus ('-':_) = True
1490 isPlus :: String -> Either String String
1491 isPlus ('+':opt) = Left opt
1492 isPlus other = Right other
1494 setOpt, unsetOpt :: String -> GHCi ()
1497 = case strToGHCiOpt str of
1498 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1499 Just o -> setOption o
1502 = case strToGHCiOpt str of
1503 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1504 Just o -> unsetOption o
1506 strToGHCiOpt :: String -> (Maybe GHCiOption)
1507 strToGHCiOpt "s" = Just ShowTiming
1508 strToGHCiOpt "t" = Just ShowType
1509 strToGHCiOpt "r" = Just RevertCAFs
1510 strToGHCiOpt _ = Nothing
1512 optToStr :: GHCiOption -> String
1513 optToStr ShowTiming = "s"
1514 optToStr ShowType = "t"
1515 optToStr RevertCAFs = "r"
1517 -- ---------------------------------------------------------------------------
1520 showCmd :: String -> GHCi ()
1524 ["args"] -> io $ putStrLn (show (args st))
1525 ["prog"] -> io $ putStrLn (show (progname st))
1526 ["prompt"] -> io $ putStrLn (show (prompt st))
1527 ["editor"] -> io $ putStrLn (show (editor st))
1528 ["stop"] -> io $ putStrLn (show (stop st))
1529 ["modules" ] -> showModules
1530 ["bindings"] -> showBindings
1531 ["linker"] -> io showLinkerState
1532 ["breaks"] -> showBkptTable
1533 ["context"] -> showContext
1534 ["packages"] -> showPackages
1535 ["languages"] -> showLanguages
1536 _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
1537 " | breaks | context | packages | languages ]"))
1539 showModules :: GHCi ()
1541 loaded_mods <- getLoadedModules
1542 -- we want *loaded* modules only, see #1734
1543 let show_one ms = do m <- GHC.showModule ms; io (putStrLn m)
1544 mapM_ show_one loaded_mods
1546 getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
1547 getLoadedModules = do
1548 graph <- GHC.getModuleGraph
1549 filterM (GHC.isLoaded . GHC.ms_mod_name) graph
1551 showBindings :: GHCi ()
1553 bindings <- GHC.getBindings
1554 docs <- pprTypeAndContents
1555 [ id | AnId id <- sortBy compareTyThings bindings]
1556 printForUserPartWay docs
1558 compareTyThings :: TyThing -> TyThing -> Ordering
1559 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1561 printTyThing :: TyThing -> GHCi ()
1562 printTyThing tyth = do dflags <- getDynFlags
1563 let pefas = dopt Opt_PrintExplicitForalls dflags
1564 printForUser (pprTyThing pefas tyth)
1566 showBkptTable :: GHCi ()
1569 printForUser $ prettyLocations (breaks st)
1571 showContext :: GHCi ()
1573 resumes <- GHC.getResumeContext
1574 printForUser $ vcat (map pp_resume (reverse resumes))
1577 ptext (sLit "--> ") <> text (GHC.resumeStmt resume)
1578 $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume))
1580 showPackages :: GHCi ()
1582 pkg_flags <- fmap packageFlags getDynFlags
1583 io $ putStrLn $ showSDoc $ vcat $
1584 text ("active package flags:"++if null pkg_flags then " none" else "")
1585 : map showFlag pkg_flags
1586 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1587 io $ putStrLn $ showSDoc $ vcat $
1588 text "packages currently loaded:"
1589 : map (nest 2 . text . packageIdString)
1590 (sortBy (compare `on` packageIdFS) pkg_ids)
1591 where showFlag (ExposePackage p) = text $ " -package " ++ p
1592 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1593 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1595 showLanguages :: GHCi ()
1597 dflags <- getDynFlags
1598 io $ putStrLn $ showSDoc $ vcat $
1599 text "active language flags:" :
1600 [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags]
1602 -- -----------------------------------------------------------------------------
1605 completeCmd, completeMacro, completeIdentifier, completeModule,
1606 completeHomeModule, completeSetOptions, completeShowOptions,
1607 completeHomeModuleOrFile, completeExpression
1608 :: CompletionFunc GHCi
1610 ghciCompleteWord :: CompletionFunc GHCi
1611 ghciCompleteWord line@(left,_) = case firstWord of
1612 ':':cmd | null rest -> completeCmd line
1614 completion <- lookupCompletion cmd
1616 "import" -> completeModule line
1617 _ -> completeExpression line
1619 (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
1620 lookupCompletion ('!':_) = return completeFilename
1621 lookupCompletion c = do
1622 maybe_cmd <- liftIO $ lookupCommand' c
1624 Just (_,_,f) -> return f
1625 Nothing -> return completeFilename
1627 completeCmd = wrapCompleter " " $ \w -> do
1628 cmds <- liftIO $ readIORef macros_ref
1629 return (filter (w `isPrefixOf`) (map (':':)
1630 (map cmdName (builtin_commands ++ cmds))))
1632 completeMacro = wrapIdentCompleter $ \w -> do
1633 cmds <- liftIO $ readIORef macros_ref
1634 return (filter (w `isPrefixOf`) (map cmdName cmds))
1636 completeIdentifier = wrapIdentCompleter $ \w -> do
1637 rdrs <- GHC.getRdrNamesInScope
1638 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1640 completeModule = wrapIdentCompleter $ \w -> do
1641 dflags <- GHC.getSessionDynFlags
1642 let pkg_mods = allExposedModules dflags
1643 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
1644 return $ filter (w `isPrefixOf`)
1645 $ map (showSDoc.ppr) $ loaded_mods ++ pkg_mods
1647 completeHomeModule = wrapIdentCompleter listHomeModules
1649 listHomeModules :: String -> GHCi [String]
1650 listHomeModules w = do
1651 g <- GHC.getModuleGraph
1652 let home_mods = map GHC.ms_mod_name g
1653 return $ sort $ filter (w `isPrefixOf`)
1654 $ map (showSDoc.ppr) home_mods
1656 completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
1657 return (filter (w `isPrefixOf`) options)
1658 where options = "args":"prog":"prompt":"editor":"stop":flagList
1659 flagList = map head $ group $ sort allFlags
1661 completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
1662 return (filter (w `isPrefixOf`) options)
1663 where options = ["args", "prog", "prompt", "editor", "stop",
1664 "modules", "bindings", "linker", "breaks",
1665 "context", "packages", "languages"]
1667 completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
1668 $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
1671 unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
1672 unionComplete f1 f2 line = do
1677 wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
1678 wrapCompleter breakChars fun = completeWord Nothing breakChars
1679 $ fmap (map simpleCompletion) . fmap sort . fun
1681 wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
1682 wrapIdentCompleter = wrapCompleter word_break_chars
1684 allExposedModules :: DynFlags -> [ModuleName]
1685 allExposedModules dflags
1686 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1688 pkg_db = pkgIdMap (pkgState dflags)
1690 completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
1693 -- ---------------------------------------------------------------------------
1694 -- User code exception handling
1696 -- This is the exception handler for exceptions generated by the
1697 -- user's code and exceptions coming from children sessions;
1698 -- it normally just prints out the exception. The
1699 -- handler must be recursive, in case showing the exception causes
1700 -- more exceptions to be raised.
1702 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1703 -- raising another exception. We therefore don't put the recursive
1704 -- handler arond the flushing operation, so if stderr is closed
1705 -- GHCi will just die gracefully rather than going into an infinite loop.
1706 handler :: SomeException -> GHCi Bool
1708 handler exception = do
1710 io installSignalHandlers
1711 ghciHandle handler (showException exception >> return False)
1713 showException :: SomeException -> GHCi ()
1715 io $ case fromException se of
1716 Just Interrupted -> putStrLn "Interrupted."
1717 -- omit the location for CmdLineError:
1718 Just (CmdLineError s) -> putStrLn s
1720 Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
1721 Just other_ghc_ex -> print other_ghc_ex
1722 Nothing -> putStrLn ("*** Exception: " ++ show se)
1724 -----------------------------------------------------------------------------
1725 -- recursive exception handlers
1727 -- Don't forget to unblock async exceptions in the handler, or if we're
1728 -- in an exception loop (eg. let a = error a in a) the ^C exception
1729 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1731 ghciHandle :: MonadException m => (SomeException -> m a) -> m a -> m a
1732 ghciHandle h m = Haskeline.catch m $ \e -> unblock (h e)
1734 ghciTry :: GHCi a -> GHCi (Either SomeException a)
1735 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
1737 -- ----------------------------------------------------------------------------
1740 -- TODO: won't work if home dir is encoded.
1741 -- (changeDirectory may not work either in that case.)
1742 expandPath :: MonadIO m => String -> InputT m String
1743 expandPath path = do
1744 exp_path <- liftIO $ expandPathIO path
1745 enc <- fmap BS.unpack $ Encoding.encode exp_path
1748 expandPathIO :: String -> IO String
1750 case dropWhile isSpace path of
1752 tilde <- getHomeDirectory -- will fail if HOME not defined
1753 return (tilde ++ '/':d)
1757 wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
1758 wantInterpretedModule str = do
1759 modl <- lookupModule str
1760 dflags <- getDynFlags
1761 when (GHC.modulePackageId modl /= thisPackage dflags) $
1762 ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
1763 is_interpreted <- GHC.moduleIsInterpreted modl
1764 when (not is_interpreted) $
1765 ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
1768 wantNameFromInterpretedModule :: GHC.GhcMonad m
1769 => (Name -> SDoc -> m ())
1773 wantNameFromInterpretedModule noCanDo str and_then =
1774 handleSourceError (GHC.printExceptionAndWarnings) $ do
1775 names <- GHC.parseName str
1779 let modl = ASSERT( isExternalName n ) GHC.nameModule n
1780 if not (GHC.isExternalName n)
1781 then noCanDo n $ ppr n <>
1782 text " is not defined in an interpreted module"
1784 is_interpreted <- GHC.moduleIsInterpreted modl
1785 if not is_interpreted
1786 then noCanDo n $ text "module " <> ppr modl <>
1787 text " is not interpreted"
1790 -- -----------------------------------------------------------------------------
1791 -- commands for debugger
1793 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1794 sprintCmd = pprintCommand False False
1795 printCmd = pprintCommand True False
1796 forceCmd = pprintCommand False True
1798 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1799 pprintCommand bind force str = do
1800 pprintClosureCommand bind force str
1802 stepCmd :: String -> GHCi ()
1803 stepCmd [] = doContinue (const True) GHC.SingleStep
1804 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1806 stepLocalCmd :: String -> GHCi ()
1807 stepLocalCmd [] = do
1808 mb_span <- getCurrentBreakSpan
1810 Nothing -> stepCmd []
1812 Just mod <- getCurrentBreakModule
1813 current_toplevel_decl <- enclosingTickSpan mod loc
1814 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1816 stepLocalCmd expression = stepCmd expression
1818 stepModuleCmd :: String -> GHCi ()
1819 stepModuleCmd [] = do
1820 mb_span <- getCurrentBreakSpan
1822 Nothing -> stepCmd []
1824 Just span <- getCurrentBreakSpan
1825 let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span
1826 doContinue f GHC.SingleStep
1828 stepModuleCmd expression = stepCmd expression
1830 -- | Returns the span of the largest tick containing the srcspan given
1831 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1832 enclosingTickSpan mod src = do
1833 ticks <- getTickArray mod
1834 let line = srcSpanStartLine src
1835 ASSERT (inRange (bounds ticks) line) do
1836 let enclosing_spans = [ span | (_,span) <- ticks ! line
1837 , srcSpanEnd span >= srcSpanEnd src]
1838 return . head . sortBy leftmost_largest $ enclosing_spans
1840 traceCmd :: String -> GHCi ()
1841 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1842 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1844 continueCmd :: String -> GHCi ()
1845 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1847 -- doContinue :: SingleStep -> GHCi ()
1848 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1849 doContinue pred step = do
1850 runResult <- resume pred step
1851 afterRunStmt pred runResult
1854 abandonCmd :: String -> GHCi ()
1855 abandonCmd = noArgs $ do
1856 b <- GHC.abandon -- the prompt will change to indicate the new context
1857 when (not b) $ io $ putStrLn "There is no computation running."
1860 deleteCmd :: String -> GHCi ()
1861 deleteCmd argLine = do
1862 deleteSwitch $ words argLine
1864 deleteSwitch :: [String] -> GHCi ()
1866 io $ putStrLn "The delete command requires at least one argument."
1867 -- delete all break points
1868 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1869 deleteSwitch idents = do
1870 mapM_ deleteOneBreak idents
1872 deleteOneBreak :: String -> GHCi ()
1874 | all isDigit str = deleteBreak (read str)
1875 | otherwise = return ()
1877 historyCmd :: String -> GHCi ()
1879 | null arg = history 20
1880 | all isDigit arg = history (read arg)
1881 | otherwise = io $ putStrLn "Syntax: :history [num]"
1884 resumes <- GHC.getResumeContext
1886 [] -> io $ putStrLn "Not stopped at a breakpoint"
1888 let hist = GHC.resumeHistory r
1889 (took,rest) = splitAt num hist
1891 [] -> io $ putStrLn $
1892 "Empty history. Perhaps you forgot to use :trace?"
1894 spans <- mapM GHC.getHistorySpan took
1895 let nums = map (printf "-%-3d:") [(1::Int)..]
1896 names = map GHC.historyEnclosingDecl took
1897 printForUser (vcat(zipWith3
1898 (\x y z -> x <+> y <+> z)
1900 (map (bold . ppr) names)
1901 (map (parens . ppr) spans)))
1902 io $ putStrLn $ if null rest then "<end of history>" else "..."
1904 bold :: SDoc -> SDoc
1905 bold c | do_bold = text start_bold <> c <> text end_bold
1908 backCmd :: String -> GHCi ()
1909 backCmd = noArgs $ do
1910 (names, _, span) <- GHC.back
1911 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span
1912 printTypeOfNames names
1913 -- run the command set with ":set stop <cmd>"
1915 enqueueCommands [stop st]
1917 forwardCmd :: String -> GHCi ()
1918 forwardCmd = noArgs $ do
1919 (names, ix, span) <- GHC.forward
1920 printForUser $ (if (ix == 0)
1921 then ptext (sLit "Stopped at")
1922 else ptext (sLit "Logged breakpoint at")) <+> ppr span
1923 printTypeOfNames names
1924 -- run the command set with ":set stop <cmd>"
1926 enqueueCommands [stop st]
1928 -- handle the "break" command
1929 breakCmd :: String -> GHCi ()
1930 breakCmd argLine = do
1931 breakSwitch $ words argLine
1933 breakSwitch :: [String] -> GHCi ()
1935 io $ putStrLn "The break command requires at least one argument."
1936 breakSwitch (arg1:rest)
1937 | looksLikeModuleName arg1 && not (null rest) = do
1938 mod <- wantInterpretedModule arg1
1939 breakByModule mod rest
1940 | all isDigit arg1 = do
1941 (toplevel, _) <- GHC.getContext
1943 (mod : _) -> breakByModuleLine mod (read arg1) rest
1945 io $ putStrLn "Cannot find default module for breakpoint."
1946 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1947 | otherwise = do -- try parsing it as an identifier
1948 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1949 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1950 if GHC.isGoodSrcLoc loc
1951 then ASSERT( isExternalName name )
1952 findBreakAndSet (GHC.nameModule name) $
1953 findBreakByCoord (Just (GHC.srcLocFile loc))
1954 (GHC.srcLocLine loc,
1956 else noCanDo name $ text "can't find its location: " <> ppr loc
1958 noCanDo n why = printForUser $
1959 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1961 breakByModule :: Module -> [String] -> GHCi ()
1962 breakByModule mod (arg1:rest)
1963 | all isDigit arg1 = do -- looks like a line number
1964 breakByModuleLine mod (read arg1) rest
1968 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1969 breakByModuleLine mod line args
1970 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1971 | [col] <- args, all isDigit col =
1972 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1973 | otherwise = breakSyntax
1976 breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1978 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1979 findBreakAndSet mod lookupTickTree = do
1980 tickArray <- getTickArray mod
1981 (breakArray, _) <- getModBreak mod
1982 case lookupTickTree tickArray of
1983 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1984 Just (tick, span) -> do
1985 success <- io $ setBreakFlag True breakArray tick
1989 recordBreak $ BreakLocation
1996 text "Breakpoint " <> ppr nm <>
1998 then text " was already set at " <> ppr span
1999 else text " activated at " <> ppr span
2001 printForUser $ text "Breakpoint could not be activated at"
2004 -- When a line number is specified, the current policy for choosing
2005 -- the best breakpoint is this:
2006 -- - the leftmost complete subexpression on the specified line, or
2007 -- - the leftmost subexpression starting on the specified line, or
2008 -- - the rightmost subexpression enclosing the specified line
2010 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2011 findBreakByLine line arr
2012 | not (inRange (bounds arr) line) = Nothing
2014 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
2015 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2016 listToMaybe (sortBy (rightmost `on` snd) ticks)
2020 starts_here = [ tick | tick@(_,span) <- ticks,
2021 GHC.srcSpanStartLine span == line ]
2023 (complete,incomplete) = partition ends_here starts_here
2024 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2026 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2027 -> Maybe (BreakIndex,SrcSpan)
2028 findBreakByCoord mb_file (line, col) arr
2029 | not (inRange (bounds arr) line) = Nothing
2031 listToMaybe (sortBy (rightmost `on` snd) contains ++
2032 sortBy (leftmost_smallest `on` snd) after_here)
2036 -- the ticks that span this coordinate
2037 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2038 is_correct_file span ]
2040 is_correct_file span
2041 | Just f <- mb_file = GHC.srcSpanFile span == f
2044 after_here = [ tick | tick@(_,span) <- ticks,
2045 GHC.srcSpanStartLine span == line,
2046 GHC.srcSpanStartCol span >= col ]
2048 -- For now, use ANSI bold on terminals that we know support it.
2049 -- Otherwise, we add a line of carets under the active expression instead.
2050 -- In particular, on Windows and when running the testsuite (which sets
2051 -- TERM to vt100 for other reasons) we get carets.
2052 -- We really ought to use a proper termcap/terminfo library.
2054 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2055 where mTerm = System.Environment.getEnv "TERM"
2056 `catchIO` \_ -> return "TERM not set"
2058 start_bold :: String
2059 start_bold = "\ESC[1m"
2061 end_bold = "\ESC[0m"
2063 listCmd :: String -> InputT GHCi ()
2065 mb_span <- lift getCurrentBreakSpan
2068 printForUser' $ text "Not stopped at a breakpoint; nothing to list"
2070 | GHC.isGoodSrcSpan span -> listAround span True
2072 do resumes <- GHC.getResumeContext
2074 [] -> panic "No resumes"
2076 do let traceIt = case GHC.resumeHistory r of
2077 [] -> text "rerunning with :trace,"
2079 doWhat = traceIt <+> text ":back then :list"
2080 printForUser' (text "Unable to list source for" <+>
2082 $$ text "Try" <+> doWhat)
2083 listCmd str = list2 (words str)
2085 list2 :: [String] -> InputT GHCi ()
2086 list2 [arg] | all isDigit arg = do
2087 (toplevel, _) <- GHC.getContext
2089 [] -> outputStrLn "No module to list"
2090 (mod : _) -> listModuleLine mod (read arg)
2091 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2092 mod <- wantInterpretedModule arg1
2093 listModuleLine mod (read arg2)
2095 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2096 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2097 if GHC.isGoodSrcLoc loc
2099 tickArray <- ASSERT( isExternalName name )
2100 lift $ getTickArray (GHC.nameModule name)
2101 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2102 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2105 Nothing -> listAround (GHC.srcLocSpan loc) False
2106 Just (_,span) -> listAround span False
2108 noCanDo name $ text "can't find its location: " <>
2111 noCanDo n why = printForUser' $
2112 text "cannot list source code for " <> ppr n <> text ": " <> why
2114 outputStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2116 listModuleLine :: Module -> Int -> InputT GHCi ()
2117 listModuleLine modl line = do
2118 graph <- GHC.getModuleGraph
2119 let this = filter ((== modl) . GHC.ms_mod) graph
2121 [] -> panic "listModuleLine"
2123 let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
2124 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2125 listAround (GHC.srcLocSpan loc) False
2127 -- | list a section of a source file around a particular SrcSpan.
2128 -- If the highlight flag is True, also highlight the span using
2129 -- start_bold\/end_bold.
2131 -- GHC files are UTF-8, so we can implement this by:
2132 -- 1) read the file in as a BS and syntax highlight it as before
2133 -- 2) convert the BS to String using utf-string, and write it out.
2134 -- It would be better if we could convert directly between UTF-8 and the
2135 -- console encoding, of course.
2136 listAround :: MonadIO m => SrcSpan -> Bool -> InputT m ()
2137 listAround span do_highlight = do
2138 contents <- liftIO $ BS.readFile (unpackFS file)
2140 lines = BS.split '\n' contents
2141 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2142 drop (line1 - 1 - pad_before) $ lines
2143 fst_line = max 1 (line1 - pad_before)
2144 line_nos = [ fst_line .. ]
2146 highlighted | do_highlight = zipWith highlight line_nos these_lines
2147 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2149 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2150 prefixed = zipWith ($) highlighted bs_line_nos
2152 let output = BS.intercalate (BS.pack "\n") prefixed
2153 utf8Decoded <- liftIO $ BS.useAsCStringLen output
2154 $ \(p,n) -> utf8DecodeString (castPtr p) n
2155 outputStrLn utf8Decoded
2157 file = GHC.srcSpanFile span
2158 line1 = GHC.srcSpanStartLine span
2159 col1 = GHC.srcSpanStartCol span
2160 line2 = GHC.srcSpanEndLine span
2161 col2 = GHC.srcSpanEndCol span
2163 pad_before | line1 == 1 = 0
2167 highlight | do_bold = highlight_bold
2168 | otherwise = highlight_carets
2170 highlight_bold no line prefix
2171 | no == line1 && no == line2
2172 = let (a,r) = BS.splitAt col1 line
2173 (b,c) = BS.splitAt (col2-col1) r
2175 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2177 = let (a,b) = BS.splitAt col1 line in
2178 BS.concat [prefix, a, BS.pack start_bold, b]
2180 = let (a,b) = BS.splitAt col2 line in
2181 BS.concat [prefix, a, BS.pack end_bold, b]
2182 | otherwise = BS.concat [prefix, line]
2184 highlight_carets no line prefix
2185 | no == line1 && no == line2
2186 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2187 BS.replicate (col2-col1) '^']
2189 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2192 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2194 | otherwise = BS.concat [prefix, line]
2196 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2197 nl = BS.singleton '\n'
2199 -- --------------------------------------------------------------------------
2202 getTickArray :: Module -> GHCi TickArray
2203 getTickArray modl = do
2205 let arrmap = tickarrays st
2206 case lookupModuleEnv arrmap modl of
2207 Just arr -> return arr
2209 (_breakArray, ticks) <- getModBreak modl
2210 let arr = mkTickArray (assocs ticks)
2211 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2214 discardTickArrays :: GHCi ()
2215 discardTickArrays = do
2217 setGHCiState st{tickarrays = emptyModuleEnv}
2219 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2221 = accumArray (flip (:)) [] (1, max_line)
2222 [ (line, (nm,span)) | (nm,span) <- ticks,
2223 line <- srcSpanLines span ]
2225 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2226 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2227 GHC.srcSpanEndLine span ]
2229 lookupModule :: GHC.GhcMonad m => String -> m Module
2230 lookupModule modName
2231 = GHC.lookupModule (GHC.mkModuleName modName) Nothing
2233 -- don't reset the counter back to zero?
2234 discardActiveBreakPoints :: GHCi ()
2235 discardActiveBreakPoints = do
2237 mapM (turnOffBreak.snd) (breaks st)
2238 setGHCiState $ st { breaks = [] }
2240 deleteBreak :: Int -> GHCi ()
2241 deleteBreak identity = do
2243 let oldLocations = breaks st
2244 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2246 then printForUser (text "Breakpoint" <+> ppr identity <+>
2247 text "does not exist")
2249 mapM (turnOffBreak.snd) this
2250 setGHCiState $ st { breaks = rest }
2252 turnOffBreak :: BreakLocation -> GHCi Bool
2253 turnOffBreak loc = do
2254 (arr, _) <- getModBreak (breakModule loc)
2255 io $ setBreakFlag False arr (breakTick loc)
2257 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2258 getModBreak mod = do
2259 Just mod_info <- GHC.getModuleInfo mod
2260 let modBreaks = GHC.modInfoModBreaks mod_info
2261 let array = GHC.modBreaks_flags modBreaks
2262 let ticks = GHC.modBreaks_locs modBreaks
2263 return (array, ticks)
2265 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2266 setBreakFlag toggle array index
2267 | toggle = GHC.setBreakOn array index
2268 | otherwise = GHC.setBreakOff array index