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
43 -- Other random utilities
46 import BasicTypes hiding (isTopLevel)
47 import Panic hiding (showException)
53 import Maybes ( orElse, expectJust )
58 #ifndef mingw32_HOST_OS
59 import System.Posix hiding (getEnv)
61 import qualified System.Win32
64 import System.Console.Haskeline as Haskeline
65 import qualified System.Console.Haskeline.Encoding as Encoding
66 import Control.Monad.Trans
70 import Exception hiding (catch, block, unblock)
71 import qualified Exception
73 -- import Control.Concurrent
75 import System.FilePath
76 import qualified Data.ByteString.Char8 as BS
80 import System.Environment
81 import System.Exit ( exitWith, ExitCode(..) )
82 import System.Directory
84 import System.IO.Error as IO
87 import Control.Monad as Monad
90 import GHC.Exts ( unsafeCoerce# )
92 #if __GLASGOW_HASKELL__ >= 611
93 import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
94 import GHC.IO.Handle ( hFlushAll )
96 import GHC.IOBase ( IOErrorType(InvalidArgument) )
101 import Data.IORef ( IORef, readIORef, writeIORef )
103 -----------------------------------------------------------------------------
105 ghciWelcomeMsg :: String
106 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
107 ": http://www.haskell.org/ghc/ :? for help"
109 cmdName :: Command -> String
112 GLOBAL_VAR(macros_ref, [], [Command])
114 builtin_commands :: [Command]
116 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
117 ("?", keepGoing help, noCompletion),
118 ("add", keepGoingPaths addModule, completeFilename),
119 ("abandon", keepGoing abandonCmd, noCompletion),
120 ("break", keepGoing breakCmd, completeIdentifier),
121 ("back", keepGoing backCmd, noCompletion),
122 ("browse", keepGoing' (browseCmd False), completeModule),
123 ("browse!", keepGoing' (browseCmd True), completeModule),
124 ("cd", keepGoing' changeDirectory, completeFilename),
125 ("check", keepGoing' checkModule, completeHomeModule),
126 ("continue", keepGoing continueCmd, noCompletion),
127 ("cmd", keepGoing cmdCmd, completeExpression),
128 ("ctags", keepGoing createCTagsFileCmd, completeFilename),
129 ("def", keepGoing (defineMacro False), completeExpression),
130 ("def!", keepGoing (defineMacro True), completeExpression),
131 ("delete", keepGoing deleteCmd, noCompletion),
132 ("e", keepGoing editFile, completeFilename),
133 ("edit", keepGoing editFile, completeFilename),
134 ("etags", keepGoing createETagsFileCmd, completeFilename),
135 ("force", keepGoing forceCmd, completeExpression),
136 ("forward", keepGoing forwardCmd, noCompletion),
137 ("help", keepGoing help, noCompletion),
138 ("history", keepGoing historyCmd, noCompletion),
139 ("info", keepGoing' info, completeIdentifier),
140 ("kind", keepGoing' kindOfType, completeIdentifier),
141 ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),
142 ("list", keepGoing' listCmd, noCompletion),
143 ("module", keepGoing setContext, completeModule),
144 ("main", keepGoing runMain, completeFilename),
145 ("print", keepGoing printCmd, completeExpression),
146 ("quit", quit, noCompletion),
147 ("reload", keepGoing' reloadModule, noCompletion),
148 ("run", keepGoing runRun, completeFilename),
149 ("set", keepGoing setCmd, completeSetOptions),
150 ("show", keepGoing showCmd, completeShowOptions),
151 ("sprint", keepGoing sprintCmd, completeExpression),
152 ("step", keepGoing stepCmd, completeIdentifier),
153 ("steplocal", keepGoing stepLocalCmd, completeIdentifier),
154 ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),
155 ("type", keepGoing' typeOfExpr, completeExpression),
156 ("trace", keepGoing traceCmd, completeExpression),
157 ("undef", keepGoing undefineMacro, completeMacro),
158 ("unset", keepGoing unsetOptions, completeSetOptions)
162 -- We initialize readline (in the interactiveUI function) to use
163 -- word_break_chars as the default set of completion word break characters.
164 -- This can be overridden for a particular command (for example, filename
165 -- expansion shouldn't consider '/' to be a word break) by setting the third
166 -- entry in the Command tuple above.
168 -- NOTE: in order for us to override the default correctly, any custom entry
169 -- must be a SUBSET of word_break_chars.
170 word_break_chars :: String
171 word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
172 specials = "(),;[]`{}"
174 in spaces ++ specials ++ symbols
176 flagWordBreakChars :: String
177 flagWordBreakChars = " \t\n"
180 keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)
181 keepGoing a str = keepGoing' (lift . a) str
183 keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool
184 keepGoing' a str = a str >> return False
186 keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
188 = do case toArgs str of
189 Left err -> Encoding.encode err >>= liftIO . BS.hPutStrLn stderr
193 shortHelpText :: String
194 shortHelpText = "use :? for help.\n"
198 " Commands available from the prompt:\n" ++
200 " <statement> evaluate/run <statement>\n" ++
201 " : repeat last command\n" ++
202 " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
203 " :add [*]<module> ... add module(s) to the current target set\n" ++
204 " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
205 " (!: more details; *: all top-level names)\n" ++
206 " :cd <dir> change directory to <dir>\n" ++
207 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
208 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
209 " :def <cmd> <expr> define a command :<cmd>\n" ++
210 " :edit <file> edit file\n" ++
211 " :edit edit last module\n" ++
212 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
213 " :help, :? display this list of commands\n" ++
214 " :info [<name> ...] display information about the given names\n" ++
215 " :kind <type> show the kind of <type>\n" ++
216 " :load [*]<module> ... load module(s) and their dependents\n" ++
217 " :main [<arguments> ...] run the main function with the given arguments\n" ++
218 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
219 " :quit exit GHCi\n" ++
220 " :reload reload the current module set\n" ++
221 " :run function [<arguments> ...] run the function with the given arguments\n" ++
222 " :type <expr> show the type of <expr>\n" ++
223 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
224 " :!<command> run the shell command <command>\n" ++
226 " -- Commands for debugging:\n" ++
228 " :abandon at a breakpoint, abandon current computation\n" ++
229 " :back go back in the history (after :trace)\n" ++
230 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
231 " :break <name> set a breakpoint on the specified function\n" ++
232 " :continue resume after a breakpoint\n" ++
233 " :delete <number> delete the specified breakpoint\n" ++
234 " :delete * delete all breakpoints\n" ++
235 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
236 " :forward go forward in the history (after :back)\n" ++
237 " :history [<n>] after :trace, show the execution history\n" ++
238 " :list show the source code around current breakpoint\n" ++
239 " :list identifier show the source code for <identifier>\n" ++
240 " :list [<module>] <line> show the source code around line number <line>\n" ++
241 " :print [<name> ...] prints a value without forcing its computation\n" ++
242 " :sprint [<name> ...] simplifed version of :print\n" ++
243 " :step single-step after stopping at a breakpoint\n"++
244 " :step <expr> single-step into <expr>\n"++
245 " :steplocal single-step within the current top-level binding\n"++
246 " :stepmodule single-step restricted to the current module\n"++
247 " :trace trace after stopping at a breakpoint\n"++
248 " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++
251 " -- Commands for changing settings:\n" ++
253 " :set <option> ... set options\n" ++
254 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
255 " :set prog <progname> set the value returned by System.getProgName\n" ++
256 " :set prompt <prompt> set the prompt used in GHCi\n" ++
257 " :set editor <cmd> set the command used for :edit\n" ++
258 " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" ++
259 " :unset <option> ... unset options\n" ++
261 " Options for ':set' and ':unset':\n" ++
263 " +r revert top-level expressions after each evaluation\n" ++
264 " +s print timing/memory stats after each evaluation\n" ++
265 " +t print type after evaluation\n" ++
266 " -<flags> most GHC command line flags can also be set here\n" ++
267 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
268 " for GHCi-specific flags, see User's Guide,\n"++
269 " Flag reference, Interactive-mode options\n" ++
271 " -- Commands for displaying information:\n" ++
273 " :show bindings show the current bindings made at the prompt\n" ++
274 " :show breaks show the active breakpoints\n" ++
275 " :show context show the breakpoint context\n" ++
276 " :show modules show the currently loaded modules\n" ++
277 " :show packages show the currently active package flags\n" ++
278 " :show languages show the currently active language flags\n" ++
279 " :show <setting> show value of <setting>, which is one of\n" ++
280 " [args, prog, prompt, editor, stop]\n" ++
283 findEditor :: IO String
288 win <- System.Win32.getWindowsDirectory
289 return (win </> "notepad.exe")
294 foreign import ccall unsafe "rts_isProfiled" isProfiled :: IO CInt
296 interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String]
298 interactiveUI srcs maybe_exprs = do
299 -- although GHCi compiles with -prof, it is not usable: the byte-code
300 -- compiler and interpreter don't work with profiling. So we check for
301 -- this up front and emit a helpful error message (#2197)
302 i <- liftIO $ isProfiled
304 ghcError (InstallationError "GHCi cannot be used when compiled with -prof")
306 -- HACK! If we happen to get into an infinite loop (eg the user
307 -- types 'let x=x in x' at the prompt), then the thread will block
308 -- on a blackhole, and become unreachable during GC. The GC will
309 -- detect that it is unreachable and send it the NonTermination
310 -- exception. However, since the thread is unreachable, everything
311 -- it refers to might be finalized, including the standard Handles.
312 -- This sounds like a bug, but we don't have a good solution right
314 _ <- liftIO $ newStablePtr stdin
315 _ <- liftIO $ newStablePtr stdout
316 _ <- liftIO $ newStablePtr stderr
318 -- Initialise buffering for the *interpreted* I/O system
321 liftIO $ when (isNothing maybe_exprs) $ do
322 -- Only for GHCi (not runghc and ghc -e):
324 -- Turn buffering off for the compiled program's stdout/stderr
326 -- Turn buffering off for GHCi's stdout
328 hSetBuffering stdout NoBuffering
329 -- We don't want the cmd line to buffer any input that might be
330 -- intended for the program, so unbuffer stdin.
331 hSetBuffering stdin NoBuffering
333 -- initial context is just the Prelude
334 prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing
335 GHC.setContext [] [prel_mod]
337 default_editor <- liftIO $ findEditor
339 startGHCi (runGHCi srcs maybe_exprs)
340 GHCiState{ progname = "<interactive>",
344 editor = default_editor,
345 -- session = session,
350 tickarrays = emptyModuleEnv,
351 last_command = Nothing,
354 ghc_e = isJust maybe_exprs
359 withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
360 withGhcAppData right left = do
361 either_dir <- IO.try (getAppUserDataDirectory "ghc")
363 Right dir -> right dir
366 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
367 runGHCi paths maybe_exprs = do
369 read_dot_files = not opt_IgnoreDotGhci
371 current_dir = return (Just ".ghci")
373 app_user_dir = io $ withGhcAppData
374 (\dir -> return (Just (dir </> "ghci.conf")))
378 either_dir <- io $ IO.try (getEnv "HOME")
380 Right home -> return (Just (home </> ".ghci"))
383 sourceConfigFile :: FilePath -> GHCi ()
384 sourceConfigFile file = do
385 exists <- io $ doesFileExist file
387 dir_ok <- io $ checkPerms (getDirectory file)
388 file_ok <- io $ checkPerms file
389 when (dir_ok && file_ok) $ do
390 either_hdl <- io $ IO.try (openFile file ReadMode)
393 -- NOTE: this assumes that runInputT won't affect the terminal;
394 -- can we assume this will always be the case?
395 -- This would be a good place for runFileInputT.
396 Right hdl -> runInputTWithPrefs defaultPrefs defaultSettings $ do
398 runCommands $ fileLoop hdl
400 getDirectory f = case takeDirectory f of "" -> "."; d -> d
402 when (read_dot_files) $ do
403 cfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
404 cfgs <- io $ mapM canonicalizePath (catMaybes cfgs0)
405 mapM_ sourceConfigFile (nub cfgs)
406 -- nub, because we don't want to read .ghci twice if the
409 -- Perform a :load for files given on the GHCi command line
410 -- When in -e mode, if the load fails then we want to stop
411 -- immediately rather than going on to evaluate the expression.
412 when (not (null paths)) $ do
413 ok <- ghciHandle (\e -> do showException e; return Failed) $
414 -- TODO: this is a hack.
415 runInputTWithPrefs defaultPrefs defaultSettings $ do
416 let (filePaths, phases) = unzip paths
417 filePaths' <- mapM (Encoding.decode . BS.pack) filePaths
418 loadModule (zip filePaths' phases)
419 when (isJust maybe_exprs && failed ok) $
420 io (exitWith (ExitFailure 1))
422 -- if verbosity is greater than 0, or we are connected to a
423 -- terminal, display the prompt in the interactive loop.
424 is_tty <- io (hIsTerminalDevice stdin)
425 dflags <- getDynFlags
426 let show_prompt = verbosity dflags > 0 || is_tty
431 -- enter the interactive loop
432 runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
434 -- just evaluate the expression we were given
435 enqueueCommands exprs
436 let handle e = do st <- getGHCiState
437 -- Jump through some hoops to get the
438 -- current progname in the exception text:
439 -- <progname>: <exception>
440 io $ withProgName (progname st)
441 -- this used to be topHandlerFastExit, see #2228
443 runInputTWithPrefs defaultPrefs defaultSettings $ do
445 runCommands' handle (return Nothing)
448 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
450 runGHCiInput :: InputT GHCi a -> GHCi a
452 histFile <- io $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
454 let settings = setComplete ghciCompleteWord
455 $ defaultSettings {historyFile = histFile}
456 runInputT settings $ do
460 nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
461 nextInputLine show_prompt is_tty
463 prompt <- if show_prompt then lift mkPrompt else return ""
466 when show_prompt $ lift mkPrompt >>= liftIO . putStr
469 -- NOTE: We only read .ghci files if they are owned by the current user,
470 -- and aren't world writable. Otherwise, we could be accidentally
471 -- running code planted by a malicious third party.
473 -- Furthermore, We only read ./.ghci if . is owned by the current user
474 -- and isn't writable by anyone else. I think this is sufficient: we
475 -- don't need to check .. and ../.. etc. because "." always refers to
476 -- the same directory while a process is running.
478 checkPerms :: String -> IO Bool
479 #ifdef mingw32_HOST_OS
484 handleIO (\_ -> return False) $ do
485 st <- getFileStatus name
487 if fileOwner st /= me then do
488 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
491 let mode = fileMode st
492 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
493 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
495 putStrLn $ "*** WARNING: " ++ name ++
496 " is writable by someone else, IGNORING!"
501 fileLoop :: MonadIO m => Handle -> InputT m (Maybe String)
503 l <- liftIO $ IO.try $ hGetLine hdl
505 Left e | isEOFError e -> return Nothing
506 | InvalidArgument <- etype -> return Nothing
507 | otherwise -> liftIO $ ioError e
508 where etype = ioeGetErrorType e
509 -- treat InvalidArgument in the same way as EOF:
510 -- this can happen if the user closed stdin, or
511 -- perhaps did getContents which closes stdin at
513 Right l -> return (Just l)
515 mkPrompt :: GHCi String
517 (toplevs,exports) <- GHC.getContext
518 resumes <- GHC.getResumeContext
519 -- st <- getGHCiState
525 let ix = GHC.resumeHistoryIx r
527 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
529 let hist = GHC.resumeHistory r !! (ix-1)
530 span <- GHC.getHistorySpan hist
531 return (brackets (ppr (negate ix) <> char ':'
532 <+> ppr span) <> space)
534 dots | _:rs <- resumes, not (null rs) = text "... "
541 -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
542 -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
543 -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
544 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
545 hsep (map (ppr . GHC.moduleName) exports)
547 deflt_prompt = dots <> context_bit <> modules_bit
549 f ('%':'s':xs) = deflt_prompt <> f xs
550 f ('%':'%':xs) = char '%' <> f xs
551 f (x:xs) = char x <> f xs
555 return (showSDoc (f (prompt st)))
558 queryQueue :: GHCi (Maybe String)
563 c:cs -> do setGHCiState st{ cmdqueue = cs }
566 runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
567 runCommands = runCommands' handler
569 runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
570 -> InputT GHCi (Maybe String) -> InputT GHCi ()
571 runCommands' eh getCmd = do
572 b <- handleGhcException (\e -> case e of
573 Interrupted -> return False
574 _other -> liftIO (print e) >> return True)
575 (runOneCommand eh getCmd)
576 if b then return () else runCommands' eh getCmd
578 runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
580 runOneCommand eh getCmd = do
581 mb_cmd <- noSpace (lift queryQueue)
582 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
584 Nothing -> return True
585 Just c -> ghciHandle (lift . eh) $
586 handleSourceError printErrorAndKeepGoing
589 printErrorAndKeepGoing err = do
590 GHC.printExceptionAndWarnings err
593 noSpace q = q >>= maybe (return Nothing)
594 (\c->case removeSpaces c of
596 ":{" -> multiLineCmd q
597 c -> return (Just c) )
599 st <- lift getGHCiState
601 lift $ setGHCiState st{ prompt = "%s| " }
602 mb_cmd <- collectCommand q ""
603 lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p }
605 -- we can't use removeSpaces for the sublines here, so
606 -- multiline commands are somewhat more brittle against
607 -- fileformat errors (such as \r in dos input on unix),
608 -- we get rid of any extra spaces for the ":}" test;
609 -- we also avoid silent failure if ":}" is not found;
610 -- and since there is no (?) valid occurrence of \r (as
611 -- opposed to its String representation, "\r") inside a
612 -- ghci command, we replace any such with ' ' (argh:-(
613 collectCommand q c = q >>=
614 maybe (liftIO (ioError collectError))
615 (\l->if removeSpaces l == ":}"
616 then return (Just $ removeSpaces c)
617 else collectCommand q (c++map normSpace l))
618 where normSpace '\r' = ' '
620 -- QUESTION: is userError the one to use here?
621 collectError = userError "unterminated multiline command :{ .. :}"
622 doCommand (':' : cmd) = specialCommand cmd
623 doCommand stmt = do _ <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion
626 enqueueCommands :: [String] -> GHCi ()
627 enqueueCommands cmds = do
629 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
632 runStmt :: String -> SingleStep -> GHCi Bool
634 | null (filter (not.isSpace) stmt) = return False
635 | ["import", mod] <- words stmt = keepGoing' setContext ('+':mod)
638 #if __GLASGOW_HASKELL__ >= 611
639 -- In the new IO library, read handles buffer data even if the Handle
640 -- is set to NoBuffering. This causes problems for GHCi where there
641 -- are really two stdin Handles. So we flush any bufferred data in
642 -- GHCi's stdin Handle here (only relevant if stdin is attached to
643 -- a file, otherwise the read buffer can't be flushed).
644 _ <- liftIO $ IO.try $ hFlushAll stdin
646 result <- GhciMonad.runStmt stmt step
647 afterRunStmt (const True) result
649 --afterRunStmt :: GHC.RunResult -> GHCi Bool
650 -- False <=> the statement failed to compile
651 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
652 afterRunStmt _ (GHC.RunException e) = throw e
653 afterRunStmt step_here run_result = do
654 resumes <- GHC.getResumeContext
656 GHC.RunOk names -> do
657 show_types <- isOptionSet ShowType
658 when show_types $ printTypeOfNames names
659 GHC.RunBreak _ names mb_info
660 | isNothing mb_info ||
661 step_here (GHC.resumeSpan $ head resumes) -> do
662 mb_id_loc <- toBreakIdAndLocation mb_info
663 let breakCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
665 then printStoppedAtBreakInfo (head resumes) names
666 else enqueueCommands [breakCmd]
667 -- run the command set with ":set stop <cmd>"
669 enqueueCommands [stop st]
671 | otherwise -> resume step_here GHC.SingleStep >>=
672 afterRunStmt step_here >> return ()
676 io installSignalHandlers
677 b <- isOptionSet RevertCAFs
680 return (case run_result of GHC.RunOk _ -> True; _ -> False)
682 toBreakIdAndLocation ::
683 Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
684 toBreakIdAndLocation Nothing = return Nothing
685 toBreakIdAndLocation (Just info) = do
686 let mod = GHC.breakInfo_module info
687 nm = GHC.breakInfo_number info
689 return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
690 breakModule loc == mod,
691 breakTick loc == nm ]
693 printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
694 printStoppedAtBreakInfo resume names = do
695 printForUser $ ptext (sLit "Stopped at") <+>
696 ppr (GHC.resumeSpan resume)
697 -- printTypeOfNames session names
698 let namesSorted = sortBy compareNames names
699 tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
700 docs <- pprTypeAndContents [id | AnId id <- tythings]
701 printForUserPartWay docs
703 printTypeOfNames :: [Name] -> GHCi ()
704 printTypeOfNames names
705 = mapM_ (printTypeOfName ) $ sortBy compareNames names
707 compareNames :: Name -> Name -> Ordering
708 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
709 where compareWith n = (getOccString n, getSrcSpan n)
711 printTypeOfName :: Name -> GHCi ()
713 = do maybe_tything <- GHC.lookupName n
714 case maybe_tything of
716 Just thing -> printTyThing thing
719 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
721 specialCommand :: String -> InputT GHCi Bool
722 specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
723 specialCommand str = do
724 let (cmd,rest) = break isSpace str
725 maybe_cmd <- lift $ lookupCommand cmd
727 GotCommand (_,f,_) -> f (dropWhile isSpace rest)
729 do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
733 do liftIO $ hPutStr stdout ("there is no last command to perform\n"
737 lookupCommand :: String -> GHCi (MaybeCommand)
738 lookupCommand "" = do
740 case last_command st of
741 Just c -> return $ GotCommand c
742 Nothing -> return NoLastCommand
743 lookupCommand str = do
744 mc <- io $ lookupCommand' str
746 setGHCiState st{ last_command = mc }
748 Just c -> GotCommand c
749 Nothing -> BadCommand
751 lookupCommand' :: String -> IO (Maybe Command)
752 lookupCommand' str = do
753 macros <- readIORef macros_ref
754 let cmds = builtin_commands ++ macros
755 -- look for exact match first, then the first prefix match
756 return $ case [ c | c <- cmds, str == cmdName c ] of
758 [] -> case [ c | c@(s,_,_) <- cmds, str `isPrefixOf` s ] of
762 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
763 getCurrentBreakSpan = do
764 resumes <- GHC.getResumeContext
768 let ix = GHC.resumeHistoryIx r
770 then return (Just (GHC.resumeSpan r))
772 let hist = GHC.resumeHistory r !! (ix-1)
773 span <- GHC.getHistorySpan hist
776 getCurrentBreakModule :: GHCi (Maybe Module)
777 getCurrentBreakModule = do
778 resumes <- GHC.getResumeContext
782 let ix = GHC.resumeHistoryIx r
784 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
786 let hist = GHC.resumeHistory r !! (ix-1)
787 return $ Just $ GHC.getHistoryModule hist
789 -----------------------------------------------------------------------------
792 noArgs :: GHCi () -> String -> GHCi ()
794 noArgs _ _ = io $ putStrLn "This command takes no arguments"
796 help :: String -> GHCi ()
797 help _ = io (putStr helpText)
799 info :: String -> InputT GHCi ()
800 info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
801 info s = handleSourceError GHC.printExceptionAndWarnings $ do
802 { let names = words s
803 ; dflags <- getDynFlags
804 ; let pefas = dopt Opt_PrintExplicitForalls dflags
805 ; mapM_ (infoThing pefas) names }
807 infoThing pefas str = do
808 names <- GHC.parseName str
809 mb_stuffs <- mapM GHC.getInfo names
810 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
811 unqual <- GHC.getPrintUnqual
812 outputStrLn $ showSDocForUser unqual $
813 vcat (intersperse (text "") $
814 map (pprInfo pefas) filtered)
816 -- Filter out names whose parent is also there Good
817 -- example is '[]', which is both a type and data
818 -- constructor in the same type
819 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
820 filterOutChildren get_thing xs
821 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
823 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
825 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
826 pprInfo pefas (thing, fixity, insts)
827 = pprTyThingInContextLoc pefas thing
828 $$ show_fixity fixity
829 $$ vcat (map GHC.pprInstance insts)
832 | fix == GHC.defaultFixity = empty
833 | otherwise = ppr fix <+> ppr (GHC.getName thing)
835 runMain :: String -> GHCi ()
836 runMain s = case toArgs s of
837 Left err -> io (hPutStrLn stderr err)
839 do dflags <- getDynFlags
840 case mainFunIs dflags of
841 Nothing -> doWithArgs args "main"
842 Just f -> doWithArgs args f
844 runRun :: String -> GHCi ()
845 runRun s = case toCmdArgs s of
846 Left err -> io (hPutStrLn stderr err)
847 Right (cmd, args) -> doWithArgs args cmd
849 doWithArgs :: [String] -> String -> GHCi ()
850 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
851 show args ++ " (" ++ cmd ++ ")"]
853 addModule :: [FilePath] -> InputT GHCi ()
855 lift revertCAFs -- always revert CAFs on load/add.
856 files <- mapM expandPath files
857 targets <- mapM (\m -> GHC.guessTarget m Nothing) files
858 -- remove old targets with the same id; e.g. for :add *M
859 mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
860 mapM_ GHC.addTarget targets
861 prev_context <- GHC.getContext
862 ok <- trySuccess $ GHC.load LoadAllTargets
863 afterLoad ok False prev_context
865 changeDirectory :: String -> InputT GHCi ()
866 changeDirectory "" = do
867 -- :cd on its own changes to the user's home directory
868 either_dir <- liftIO $ IO.try getHomeDirectory
871 Right dir -> changeDirectory dir
872 changeDirectory dir = do
873 graph <- GHC.getModuleGraph
874 when (not (null graph)) $
875 outputStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
876 prev_context <- GHC.getContext
878 _ <- GHC.load LoadAllTargets
879 lift $ setContextAfterLoad prev_context False []
880 GHC.workingDirectoryChanged
881 dir <- expandPath dir
882 liftIO $ setCurrentDirectory dir
884 trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
886 handleSourceError (\e -> do GHC.printExceptionAndWarnings e
890 editFile :: String -> GHCi ()
892 do file <- if null str then chooseEditFile else return str
896 $ ghcError (CmdLineError "editor not set, use :set editor")
897 _ <- io $ system (cmd ++ ' ':file)
900 -- The user didn't specify a file so we pick one for them.
901 -- Our strategy is to pick the first module that failed to load,
902 -- or otherwise the first target.
904 -- XXX: Can we figure out what happened if the depndecy analysis fails
905 -- (e.g., because the porgrammeer mistyped the name of a module)?
906 -- XXX: Can we figure out the location of an error to pass to the editor?
907 -- XXX: if we could figure out the list of errors that occured during the
908 -- last load/reaload, then we could start the editor focused on the first
910 chooseEditFile :: GHCi String
912 do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
914 graph <- GHC.getModuleGraph
915 failed_graph <- filterM hasFailed graph
916 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
918 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
921 case pick (order failed_graph) of
922 Just file -> return file
924 do targets <- GHC.getTargets
925 case msum (map fromTarget targets) of
926 Just file -> return file
927 Nothing -> ghcError (CmdLineError "No files to edit.")
929 where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
930 fromTarget _ = Nothing -- when would we get a module target?
932 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
933 defineMacro overwrite s = do
934 let (macro_name, definition) = break isSpace s
935 macros <- io (readIORef macros_ref)
936 let defined = map cmdName macros
939 then io $ putStrLn "no macros defined"
940 else io $ putStr ("the following macros are defined:\n" ++
943 if (not overwrite && macro_name `elem` defined)
944 then ghcError (CmdLineError
945 ("macro '" ++ macro_name ++ "' is already defined"))
948 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
950 -- give the expression a type signature, so we can be sure we're getting
951 -- something of the right type.
952 let new_expr = '(' : definition ++ ") :: String -> IO String"
954 -- compile the expression
955 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
956 hv <- GHC.compileExpr new_expr
957 io (writeIORef macros_ref --
958 (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)]))
960 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
962 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
963 -- make sure we force any exceptions in the result, while we are still
964 -- inside the exception handler for commands:
965 seqList str (return ())
966 enqueueCommands (lines str)
969 undefineMacro :: String -> GHCi ()
970 undefineMacro str = mapM_ undef (words str)
971 where undef macro_name = do
972 cmds <- io (readIORef macros_ref)
973 if (macro_name `notElem` map cmdName cmds)
974 then ghcError (CmdLineError
975 ("macro '" ++ macro_name ++ "' is not defined"))
977 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
979 cmdCmd :: String -> GHCi ()
981 let expr = '(' : str ++ ") :: IO String"
982 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
983 hv <- GHC.compileExpr expr
984 cmds <- io $ (unsafeCoerce# hv :: IO String)
985 enqueueCommands (lines cmds)
988 loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
989 loadModule fs = timeIt (loadModule' fs)
991 loadModule_ :: [FilePath] -> InputT GHCi ()
992 loadModule_ fs = loadModule (zip fs (repeat Nothing)) >> return ()
994 loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
995 loadModule' files = do
996 prev_context <- GHC.getContext
1000 lift discardActiveBreakPoints
1002 _ <- GHC.load LoadAllTargets
1004 let (filenames, phases) = unzip files
1005 exp_filenames <- mapM expandPath filenames
1006 let files' = zip exp_filenames phases
1007 targets <- mapM (uncurry GHC.guessTarget) files'
1009 -- NOTE: we used to do the dependency anal first, so that if it
1010 -- fails we didn't throw away the current set of modules. This would
1011 -- require some re-working of the GHC interface, so we'll leave it
1012 -- as a ToDo for now.
1014 GHC.setTargets targets
1015 doLoad False prev_context LoadAllTargets
1017 checkModule :: String -> InputT GHCi ()
1019 let modl = GHC.mkModuleName m
1020 prev_context <- GHC.getContext
1021 ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do
1022 r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
1023 outputStrLn (showSDoc (
1024 case GHC.moduleInfo r of
1025 cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1027 (local,global) = ASSERT( all isExternalName scope )
1028 partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1030 (text "global names: " <+> ppr global) $$
1031 (text "local names: " <+> ppr local)
1034 afterLoad (successIf ok) False prev_context
1036 reloadModule :: String -> InputT GHCi ()
1038 prev_context <- GHC.getContext
1039 _ <- doLoad True prev_context $
1040 if null m then LoadAllTargets
1041 else LoadUpTo (GHC.mkModuleName m)
1044 doLoad :: Bool -> ([Module],[Module]) -> LoadHowMuch -> InputT GHCi SuccessFlag
1045 doLoad retain_context prev_context howmuch = do
1046 -- turn off breakpoints before we load: we can't turn them off later, because
1047 -- the ModBreaks will have gone away.
1048 lift discardActiveBreakPoints
1049 ok <- trySuccess $ GHC.load howmuch
1050 afterLoad ok retain_context prev_context
1053 afterLoad :: SuccessFlag -> Bool -> ([Module],[Module]) -> InputT GHCi ()
1054 afterLoad ok retain_context prev_context = do
1055 lift revertCAFs -- always revert CAFs on load.
1056 lift discardTickArrays
1057 loaded_mod_summaries <- getLoadedModules
1058 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1059 loaded_mod_names = map GHC.moduleName loaded_mods
1060 modulesLoadedMsg ok loaded_mod_names
1062 lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
1065 setContextAfterLoad :: ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi ()
1066 setContextAfterLoad prev keep_ctxt [] = do
1067 prel_mod <- getPrelude
1068 setContextKeepingPackageModules prev keep_ctxt ([], [prel_mod])
1069 setContextAfterLoad prev keep_ctxt ms = do
1070 -- load a target if one is available, otherwise load the topmost module.
1071 targets <- GHC.getTargets
1072 case [ m | Just m <- map (findTarget ms) targets ] of
1074 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1075 load_this (last graph')
1080 = case filter (`matches` t) ms of
1084 summary `matches` Target (TargetModule m) _ _
1085 = GHC.ms_mod_name summary == m
1086 summary `matches` Target (TargetFile f _) _ _
1087 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1091 load_this summary | m <- GHC.ms_mod summary = do
1092 b <- GHC.moduleIsInterpreted m
1093 if b then setContextKeepingPackageModules prev keep_ctxt ([m], [])
1095 prel_mod <- getPrelude
1096 setContextKeepingPackageModules prev keep_ctxt ([],[prel_mod,m])
1098 -- | Keep any package modules (except Prelude) when changing the context.
1099 setContextKeepingPackageModules
1100 :: ([Module],[Module]) -- previous context
1101 -> Bool -- re-execute :module commands
1102 -> ([Module],[Module]) -- new context
1104 setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do
1105 let (_,bs0) = prev_context
1106 prel_mod <- getPrelude
1107 let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1108 let bs1 = if null as then nub (prel_mod : bs) else bs
1109 GHC.setContext as (nub (bs1 ++ pkg_modules))
1113 mapM_ (playCtxtCmd False) (remembered_ctx st)
1116 setGHCiState st{ remembered_ctx = [] }
1118 isHomeModule :: Module -> Bool
1119 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1121 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi ()
1122 modulesLoadedMsg ok mods = do
1123 dflags <- getDynFlags
1124 when (verbosity dflags > 0) $ do
1126 | null mods = text "none."
1127 | otherwise = hsep (
1128 punctuate comma (map ppr mods)) <> text "."
1131 outputStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))
1133 outputStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas))
1136 typeOfExpr :: String -> InputT GHCi ()
1138 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1139 ty <- GHC.exprType str
1140 dflags <- getDynFlags
1141 let pefas = dopt Opt_PrintExplicitForalls dflags
1142 printForUser' $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]
1144 kindOfType :: String -> InputT GHCi ()
1146 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1147 ty <- GHC.typeKind str
1148 printForUser' $ text str <+> dcolon <+> ppr ty
1150 quit :: String -> InputT GHCi Bool
1151 quit _ = return True
1153 shellEscape :: String -> GHCi Bool
1154 shellEscape str = io (system str >> return False)
1156 -----------------------------------------------------------------------------
1157 -- Browsing a module's contents
1159 browseCmd :: Bool -> String -> InputT GHCi ()
1162 ['*':s] | looksLikeModuleName s -> do
1163 m <- lift $ wantInterpretedModule s
1164 browseModule bang m False
1165 [s] | looksLikeModuleName s -> do
1166 m <- lift $ lookupModule s
1167 browseModule bang m True
1169 (as,bs) <- GHC.getContext
1170 -- Guess which module the user wants to browse. Pick
1171 -- modules that are interpreted first. The most
1172 -- recently-added module occurs last, it seems.
1174 (as@(_:_), _) -> browseModule bang (last as) True
1175 ([], bs@(_:_)) -> browseModule bang (last bs) True
1176 ([], []) -> ghcError (CmdLineError ":browse: no current module")
1177 _ -> ghcError (CmdLineError "syntax: :browse <module>")
1179 -- without bang, show items in context of their parents and omit children
1180 -- with bang, show class methods and data constructors separately, and
1181 -- indicate import modules, to aid qualifying unqualified names
1182 -- with sorted, sort items alphabetically
1183 browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
1184 browseModule bang modl exports_only = do
1185 -- :browse! reports qualifiers wrt current context
1186 current_unqual <- GHC.getPrintUnqual
1187 -- Temporarily set the context to the module we're interested in,
1188 -- just so we can get an appropriate PrintUnqualified
1189 (as,bs) <- GHC.getContext
1190 prel_mod <- lift getPrelude
1191 if exports_only then GHC.setContext [] [prel_mod,modl]
1192 else GHC.setContext [modl] []
1193 target_unqual <- GHC.getPrintUnqual
1194 GHC.setContext as bs
1196 let unqual = if bang then current_unqual else target_unqual
1198 mb_mod_info <- GHC.getModuleInfo modl
1200 Nothing -> ghcError (CmdLineError ("unknown module: " ++
1201 GHC.moduleNameString (GHC.moduleName modl)))
1203 dflags <- getDynFlags
1205 | exports_only = GHC.modInfoExports mod_info
1206 | otherwise = GHC.modInfoTopLevelScope mod_info
1209 -- sort alphabetically name, but putting
1210 -- locally-defined identifiers first.
1211 -- We would like to improve this; see #1799.
1212 sorted_names = loc_sort local ++ occ_sort external
1214 (local,external) = ASSERT( all isExternalName names )
1215 partition ((==modl) . nameModule) names
1216 occ_sort = sortBy (compare `on` nameOccName)
1217 -- try to sort by src location. If the first name in
1218 -- our list has a good source location, then they all should.
1220 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1221 = sortBy (compare `on` nameSrcSpan) names
1225 mb_things <- mapM GHC.lookupName sorted_names
1226 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1228 rdr_env <- GHC.getGRE
1230 let pefas = dopt Opt_PrintExplicitForalls dflags
1231 things | bang = catMaybes mb_things
1232 | otherwise = filtered_things
1233 pretty | bang = pprTyThing
1234 | otherwise = pprTyThingInContext
1236 labels [] = text "-- not currently imported"
1237 labels l = text $ intercalate "\n" $ map qualifier l
1238 qualifier = maybe "-- defined locally"
1239 (("-- imported via "++) . intercalate ", "
1240 . map GHC.moduleNameString)
1241 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1242 modNames = map (importInfo . GHC.getName) things
1244 -- annotate groups of imports with their import modules
1245 -- the default ordering is somewhat arbitrary, so we group
1246 -- by header and sort groups; the names themselves should
1247 -- really come in order of source appearance.. (trac #1799)
1248 annotate mts = concatMap (\(m,ts)->labels m:ts)
1249 $ sortBy cmpQualifiers $ group mts
1250 where cmpQualifiers =
1251 compare `on` (map (fmap (map moduleNameFS)) . fst)
1253 group mts@((m,_):_) = (m,map snd g) : group ng
1254 where (g,ng) = partition ((==m).fst) mts
1256 let prettyThings = map (pretty pefas) things
1257 prettyThings' | bang = annotate $ zip modNames prettyThings
1258 | otherwise = prettyThings
1259 outputStrLn $ showSDocForUser unqual (vcat prettyThings')
1260 -- ToDo: modInfoInstances currently throws an exception for
1261 -- package modules. When it works, we can do this:
1262 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1264 -----------------------------------------------------------------------------
1265 -- Setting the module context
1267 setContext :: String -> GHCi ()
1269 | all sensible strs = do
1270 playCtxtCmd True (cmd, as, bs)
1272 setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] }
1273 | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1275 (cmd, strs, as, bs) =
1277 '+':stuff -> rest AddModules stuff
1278 '-':stuff -> rest RemModules stuff
1279 stuff -> rest SetContext stuff
1281 rest cmd stuff = (cmd, strs, as, bs)
1282 where strs = words stuff
1283 (as,bs) = partitionWith starred strs
1285 sensible ('*':m) = looksLikeModuleName m
1286 sensible m = looksLikeModuleName m
1288 starred ('*':m) = Left m
1291 playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi ()
1292 playCtxtCmd fail (cmd, as, bs)
1294 (as',bs') <- do_checks fail
1295 (prev_as,prev_bs) <- GHC.getContext
1299 prel_mod <- getPrelude
1300 let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs'
1304 let as_to_add = as' \\ (prev_as ++ prev_bs)
1305 bs_to_add = bs' \\ (prev_as ++ prev_bs)
1306 return (prev_as ++ as_to_add, prev_bs ++ bs_to_add)
1308 let new_as = prev_as \\ (as' ++ bs')
1309 new_bs = prev_bs \\ (as' ++ bs')
1310 return (new_as, new_bs)
1311 GHC.setContext new_as new_bs
1314 as' <- mapM wantInterpretedModule as
1315 bs' <- mapM lookupModule bs
1317 do_checks False = do
1318 as' <- mapM (trymaybe . wantInterpretedModule) as
1319 bs' <- mapM (trymaybe . lookupModule) bs
1320 return (catMaybes as', catMaybes bs')
1325 Left _ -> return Nothing
1326 Right a -> return (Just a)
1328 ----------------------------------------------------------------------------
1331 -- set options in the interpreter. Syntax is exactly the same as the
1332 -- ghc command line, except that certain options aren't available (-C,
1335 -- This is pretty fragile: most options won't work as expected. ToDo:
1336 -- figure out which ones & disallow them.
1338 setCmd :: String -> GHCi ()
1340 = do st <- getGHCiState
1341 let opts = options st
1342 io $ putStrLn (showSDoc (
1343 text "options currently set: " <>
1346 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1348 dflags <- getDynFlags
1349 io $ putStrLn (showSDoc (
1350 vcat (text "GHCi-specific dynamic flag settings:"
1351 :map (flagSetting dflags) ghciFlags)
1353 io $ putStrLn (showSDoc (
1354 vcat (text "other dynamic, non-language, flag settings:"
1355 :map (flagSetting dflags) nonLanguageDynFlags)
1357 where flagSetting dflags (str, f, _)
1358 | dopt f dflags = text " " <> text "-f" <> text str
1359 | otherwise = text " " <> text "-fno-" <> text str
1360 (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags)
1362 nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions)
1364 flags = [Opt_PrintExplicitForalls
1365 ,Opt_PrintBindResult
1366 ,Opt_BreakOnException
1368 ,Opt_PrintEvldWithShow
1371 = case getCmd str of
1372 Right ("args", rest) ->
1374 Left err -> io (hPutStrLn stderr err)
1375 Right args -> setArgs args
1376 Right ("prog", rest) ->
1378 Right [prog] -> setProg prog
1379 _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")
1380 Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1381 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1382 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1383 _ -> case toArgs str of
1384 Left err -> io (hPutStrLn stderr err)
1385 Right wds -> setOptions wds
1387 setArgs, setOptions :: [String] -> GHCi ()
1388 setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
1392 setGHCiState st{ args = args }
1396 setGHCiState st{ progname = prog }
1400 setGHCiState st{ editor = cmd }
1402 setStop str@(c:_) | isDigit c
1403 = do let (nm_str,rest) = break (not.isDigit) str
1406 let old_breaks = breaks st
1407 if all ((/= nm) . fst) old_breaks
1408 then printForUser (text "Breakpoint" <+> ppr nm <+>
1409 text "does not exist")
1411 let new_breaks = map fn old_breaks
1412 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1413 | otherwise = (i,loc)
1414 setGHCiState st{ breaks = new_breaks }
1417 setGHCiState st{ stop = cmd }
1419 setPrompt value = do
1422 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1424 '\"' : _ -> case reads value of
1425 [(value', xs)] | all isSpace xs ->
1426 setGHCiState (st { prompt = value' })
1428 io $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
1429 _ -> setGHCiState (st { prompt = value })
1432 do -- first, deal with the GHCi opts (+s, +t, etc.)
1433 let (plus_opts, minus_opts) = partitionWith isPlus wds
1434 mapM_ setOpt plus_opts
1435 -- then, dynamic flags
1436 newDynFlags minus_opts
1438 newDynFlags :: [String] -> GHCi ()
1439 newDynFlags minus_opts = do
1440 dflags <- getDynFlags
1441 let pkg_flags = packageFlags dflags
1442 (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
1443 handleFlagWarnings dflags' warns
1445 if (not (null leftovers))
1446 then ghcError $ errorsToGhcException leftovers
1449 new_pkgs <- setDynFlags dflags'
1451 -- if the package flags changed, we should reset the context
1452 -- and link the new packages.
1453 dflags <- getDynFlags
1454 when (packageFlags dflags /= pkg_flags) $ do
1455 io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
1457 _ <- GHC.load LoadAllTargets
1458 io (linkPackages dflags new_pkgs)
1459 -- package flags changed, we can't re-use any of the old context
1460 setContextAfterLoad ([],[]) False []
1464 unsetOptions :: String -> GHCi ()
1466 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1467 let opts = words str
1468 (minus_opts, rest1) = partition isMinus opts
1469 (plus_opts, rest2) = partitionWith isPlus rest1
1471 if (not (null rest2))
1472 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1475 mapM_ unsetOpt plus_opts
1477 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1478 no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
1480 no_flags <- mapM no_flag minus_opts
1481 newDynFlags no_flags
1483 isMinus :: String -> Bool
1484 isMinus ('-':_) = True
1487 isPlus :: String -> Either String String
1488 isPlus ('+':opt) = Left opt
1489 isPlus other = Right other
1491 setOpt, unsetOpt :: String -> GHCi ()
1494 = case strToGHCiOpt str of
1495 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1496 Just o -> setOption o
1499 = case strToGHCiOpt str of
1500 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1501 Just o -> unsetOption o
1503 strToGHCiOpt :: String -> (Maybe GHCiOption)
1504 strToGHCiOpt "s" = Just ShowTiming
1505 strToGHCiOpt "t" = Just ShowType
1506 strToGHCiOpt "r" = Just RevertCAFs
1507 strToGHCiOpt _ = Nothing
1509 optToStr :: GHCiOption -> String
1510 optToStr ShowTiming = "s"
1511 optToStr ShowType = "t"
1512 optToStr RevertCAFs = "r"
1514 -- ---------------------------------------------------------------------------
1517 showCmd :: String -> GHCi ()
1521 ["args"] -> io $ putStrLn (show (args st))
1522 ["prog"] -> io $ putStrLn (show (progname st))
1523 ["prompt"] -> io $ putStrLn (show (prompt st))
1524 ["editor"] -> io $ putStrLn (show (editor st))
1525 ["stop"] -> io $ putStrLn (show (stop st))
1526 ["modules" ] -> showModules
1527 ["bindings"] -> showBindings
1528 ["linker"] -> io showLinkerState
1529 ["breaks"] -> showBkptTable
1530 ["context"] -> showContext
1531 ["packages"] -> showPackages
1532 ["languages"] -> showLanguages
1533 _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
1534 " | breaks | context | packages | languages ]"))
1536 showModules :: GHCi ()
1538 loaded_mods <- getLoadedModules
1539 -- we want *loaded* modules only, see #1734
1540 let show_one ms = do m <- GHC.showModule ms; io (putStrLn m)
1541 mapM_ show_one loaded_mods
1543 getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
1544 getLoadedModules = do
1545 graph <- GHC.getModuleGraph
1546 filterM (GHC.isLoaded . GHC.ms_mod_name) graph
1548 showBindings :: GHCi ()
1550 bindings <- GHC.getBindings
1551 docs <- pprTypeAndContents
1552 [ id | AnId id <- sortBy compareTyThings bindings]
1553 printForUserPartWay docs
1555 compareTyThings :: TyThing -> TyThing -> Ordering
1556 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1558 printTyThing :: TyThing -> GHCi ()
1559 printTyThing tyth = do dflags <- getDynFlags
1560 let pefas = dopt Opt_PrintExplicitForalls dflags
1561 printForUser (pprTyThing pefas tyth)
1563 showBkptTable :: GHCi ()
1566 printForUser $ prettyLocations (breaks st)
1568 showContext :: GHCi ()
1570 resumes <- GHC.getResumeContext
1571 printForUser $ vcat (map pp_resume (reverse resumes))
1574 ptext (sLit "--> ") <> text (GHC.resumeStmt resume)
1575 $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume))
1577 showPackages :: GHCi ()
1579 pkg_flags <- fmap packageFlags getDynFlags
1580 io $ putStrLn $ showSDoc $ vcat $
1581 text ("active package flags:"++if null pkg_flags then " none" else "")
1582 : map showFlag pkg_flags
1583 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1584 io $ putStrLn $ showSDoc $ vcat $
1585 text "packages currently loaded:"
1586 : map (nest 2 . text . packageIdString)
1587 (sortBy (compare `on` packageIdFS) pkg_ids)
1588 where showFlag (ExposePackage p) = text $ " -package " ++ p
1589 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1590 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1592 showLanguages :: GHCi ()
1594 dflags <- getDynFlags
1595 io $ putStrLn $ showSDoc $ vcat $
1596 text "active language flags:" :
1597 [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags]
1599 -- -----------------------------------------------------------------------------
1602 completeCmd, completeMacro, completeIdentifier, completeModule,
1603 completeHomeModule, completeSetOptions, completeShowOptions,
1604 completeHomeModuleOrFile, completeExpression
1605 :: CompletionFunc GHCi
1607 ghciCompleteWord :: CompletionFunc GHCi
1608 ghciCompleteWord line@(left,_) = case firstWord of
1609 ':':cmd | null rest -> completeCmd line
1611 completion <- lookupCompletion cmd
1613 "import" -> completeModule line
1614 _ -> completeExpression line
1616 (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
1617 lookupCompletion ('!':_) = return completeFilename
1618 lookupCompletion c = do
1619 maybe_cmd <- liftIO $ lookupCommand' c
1621 Just (_,_,f) -> return f
1622 Nothing -> return completeFilename
1624 completeCmd = wrapCompleter " " $ \w -> do
1625 cmds <- liftIO $ readIORef macros_ref
1626 return (filter (w `isPrefixOf`) (map (':':)
1627 (map cmdName (builtin_commands ++ cmds))))
1629 completeMacro = wrapIdentCompleter $ \w -> do
1630 cmds <- liftIO $ readIORef macros_ref
1631 return (filter (w `isPrefixOf`) (map cmdName cmds))
1633 completeIdentifier = wrapIdentCompleter $ \w -> do
1634 rdrs <- GHC.getRdrNamesInScope
1635 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1637 completeModule = wrapIdentCompleter $ \w -> do
1638 dflags <- GHC.getSessionDynFlags
1639 let pkg_mods = allExposedModules dflags
1640 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
1641 return $ filter (w `isPrefixOf`)
1642 $ map (showSDoc.ppr) $ loaded_mods ++ pkg_mods
1644 completeHomeModule = wrapIdentCompleter listHomeModules
1646 listHomeModules :: String -> GHCi [String]
1647 listHomeModules w = do
1648 g <- GHC.getModuleGraph
1649 let home_mods = map GHC.ms_mod_name g
1650 return $ sort $ filter (w `isPrefixOf`)
1651 $ map (showSDoc.ppr) home_mods
1653 completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
1654 return (filter (w `isPrefixOf`) options)
1655 where options = "args":"prog":"prompt":"editor":"stop":flagList
1656 flagList = map head $ group $ sort allFlags
1658 completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
1659 return (filter (w `isPrefixOf`) options)
1660 where options = ["args", "prog", "prompt", "editor", "stop",
1661 "modules", "bindings", "linker", "breaks",
1662 "context", "packages", "languages"]
1664 completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
1665 $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
1668 unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
1669 unionComplete f1 f2 line = do
1674 wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
1675 wrapCompleter breakChars fun = completeWord Nothing breakChars
1676 $ fmap (map simpleCompletion) . fmap sort . fun
1678 wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
1679 wrapIdentCompleter = wrapCompleter word_break_chars
1681 allExposedModules :: DynFlags -> [ModuleName]
1682 allExposedModules dflags
1683 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1685 pkg_db = pkgIdMap (pkgState dflags)
1687 completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
1690 -- ---------------------------------------------------------------------------
1691 -- User code exception handling
1693 -- This is the exception handler for exceptions generated by the
1694 -- user's code and exceptions coming from children sessions;
1695 -- it normally just prints out the exception. The
1696 -- handler must be recursive, in case showing the exception causes
1697 -- more exceptions to be raised.
1699 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1700 -- raising another exception. We therefore don't put the recursive
1701 -- handler arond the flushing operation, so if stderr is closed
1702 -- GHCi will just die gracefully rather than going into an infinite loop.
1703 handler :: SomeException -> GHCi Bool
1705 handler exception = do
1707 io installSignalHandlers
1708 ghciHandle handler (showException exception >> return False)
1710 showException :: SomeException -> GHCi ()
1712 io $ case fromException se of
1713 Just Interrupted -> putStrLn "Interrupted."
1714 -- omit the location for CmdLineError:
1715 Just (CmdLineError s) -> putStrLn s
1717 Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
1718 Just other_ghc_ex -> print other_ghc_ex
1719 Nothing -> putStrLn ("*** Exception: " ++ show se)
1721 -----------------------------------------------------------------------------
1722 -- recursive exception handlers
1724 -- Don't forget to unblock async exceptions in the handler, or if we're
1725 -- in an exception loop (eg. let a = error a in a) the ^C exception
1726 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1728 ghciHandle :: MonadException m => (SomeException -> m a) -> m a -> m a
1729 ghciHandle h m = Haskeline.catch m $ \e -> unblock (h e)
1731 ghciTry :: GHCi a -> GHCi (Either SomeException a)
1732 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
1734 -- ----------------------------------------------------------------------------
1737 -- TODO: won't work if home dir is encoded.
1738 -- (changeDirectory may not work either in that case.)
1739 expandPath :: MonadIO m => String -> InputT m String
1740 expandPath path = do
1741 exp_path <- liftIO $ expandPathIO path
1742 enc <- fmap BS.unpack $ Encoding.encode exp_path
1745 expandPathIO :: String -> IO String
1747 case dropWhile isSpace path of
1749 tilde <- getHomeDirectory -- will fail if HOME not defined
1750 return (tilde ++ '/':d)
1754 wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
1755 wantInterpretedModule str = do
1756 modl <- lookupModule str
1757 dflags <- getDynFlags
1758 when (GHC.modulePackageId modl /= thisPackage dflags) $
1759 ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
1760 is_interpreted <- GHC.moduleIsInterpreted modl
1761 when (not is_interpreted) $
1762 ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
1765 wantNameFromInterpretedModule :: GHC.GhcMonad m
1766 => (Name -> SDoc -> m ())
1770 wantNameFromInterpretedModule noCanDo str and_then =
1771 handleSourceError (GHC.printExceptionAndWarnings) $ do
1772 names <- GHC.parseName str
1776 let modl = ASSERT( isExternalName n ) GHC.nameModule n
1777 if not (GHC.isExternalName n)
1778 then noCanDo n $ ppr n <>
1779 text " is not defined in an interpreted module"
1781 is_interpreted <- GHC.moduleIsInterpreted modl
1782 if not is_interpreted
1783 then noCanDo n $ text "module " <> ppr modl <>
1784 text " is not interpreted"
1787 -- -----------------------------------------------------------------------------
1788 -- commands for debugger
1790 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1791 sprintCmd = pprintCommand False False
1792 printCmd = pprintCommand True False
1793 forceCmd = pprintCommand False True
1795 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1796 pprintCommand bind force str = do
1797 pprintClosureCommand bind force str
1799 stepCmd :: String -> GHCi ()
1800 stepCmd [] = doContinue (const True) GHC.SingleStep
1801 stepCmd expression = runStmt expression GHC.SingleStep >> return ()
1803 stepLocalCmd :: String -> GHCi ()
1804 stepLocalCmd [] = do
1805 mb_span <- getCurrentBreakSpan
1807 Nothing -> stepCmd []
1809 Just mod <- getCurrentBreakModule
1810 current_toplevel_decl <- enclosingTickSpan mod loc
1811 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1813 stepLocalCmd expression = stepCmd expression
1815 stepModuleCmd :: String -> GHCi ()
1816 stepModuleCmd [] = do
1817 mb_span <- getCurrentBreakSpan
1819 Nothing -> stepCmd []
1821 Just span <- getCurrentBreakSpan
1822 let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span
1823 doContinue f GHC.SingleStep
1825 stepModuleCmd expression = stepCmd expression
1827 -- | Returns the span of the largest tick containing the srcspan given
1828 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1829 enclosingTickSpan mod src = do
1830 ticks <- getTickArray mod
1831 let line = srcSpanStartLine src
1832 ASSERT (inRange (bounds ticks) line) do
1833 let enclosing_spans = [ span | (_,span) <- ticks ! line
1834 , srcSpanEnd span >= srcSpanEnd src]
1835 return . head . sortBy leftmost_largest $ enclosing_spans
1837 traceCmd :: String -> GHCi ()
1838 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1839 traceCmd expression = runStmt expression GHC.RunAndLogSteps >> return ()
1841 continueCmd :: String -> GHCi ()
1842 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1844 -- doContinue :: SingleStep -> GHCi ()
1845 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1846 doContinue pred step = do
1847 runResult <- resume pred step
1848 _ <- afterRunStmt pred runResult
1851 abandonCmd :: String -> GHCi ()
1852 abandonCmd = noArgs $ do
1853 b <- GHC.abandon -- the prompt will change to indicate the new context
1854 when (not b) $ io $ putStrLn "There is no computation running."
1857 deleteCmd :: String -> GHCi ()
1858 deleteCmd argLine = do
1859 deleteSwitch $ words argLine
1861 deleteSwitch :: [String] -> GHCi ()
1863 io $ putStrLn "The delete command requires at least one argument."
1864 -- delete all break points
1865 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1866 deleteSwitch idents = do
1867 mapM_ deleteOneBreak idents
1869 deleteOneBreak :: String -> GHCi ()
1871 | all isDigit str = deleteBreak (read str)
1872 | otherwise = return ()
1874 historyCmd :: String -> GHCi ()
1876 | null arg = history 20
1877 | all isDigit arg = history (read arg)
1878 | otherwise = io $ putStrLn "Syntax: :history [num]"
1881 resumes <- GHC.getResumeContext
1883 [] -> io $ putStrLn "Not stopped at a breakpoint"
1885 let hist = GHC.resumeHistory r
1886 (took,rest) = splitAt num hist
1888 [] -> io $ putStrLn $
1889 "Empty history. Perhaps you forgot to use :trace?"
1891 spans <- mapM GHC.getHistorySpan took
1892 let nums = map (printf "-%-3d:") [(1::Int)..]
1893 names = map GHC.historyEnclosingDecl took
1894 printForUser (vcat(zipWith3
1895 (\x y z -> x <+> y <+> z)
1897 (map (bold . ppr) names)
1898 (map (parens . ppr) spans)))
1899 io $ putStrLn $ if null rest then "<end of history>" else "..."
1901 bold :: SDoc -> SDoc
1902 bold c | do_bold = text start_bold <> c <> text end_bold
1905 backCmd :: String -> GHCi ()
1906 backCmd = noArgs $ do
1907 (names, _, span) <- GHC.back
1908 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span
1909 printTypeOfNames names
1910 -- run the command set with ":set stop <cmd>"
1912 enqueueCommands [stop st]
1914 forwardCmd :: String -> GHCi ()
1915 forwardCmd = noArgs $ do
1916 (names, ix, span) <- GHC.forward
1917 printForUser $ (if (ix == 0)
1918 then ptext (sLit "Stopped at")
1919 else ptext (sLit "Logged breakpoint at")) <+> ppr span
1920 printTypeOfNames names
1921 -- run the command set with ":set stop <cmd>"
1923 enqueueCommands [stop st]
1925 -- handle the "break" command
1926 breakCmd :: String -> GHCi ()
1927 breakCmd argLine = do
1928 breakSwitch $ words argLine
1930 breakSwitch :: [String] -> GHCi ()
1932 io $ putStrLn "The break command requires at least one argument."
1933 breakSwitch (arg1:rest)
1934 | looksLikeModuleName arg1 && not (null rest) = do
1935 mod <- wantInterpretedModule arg1
1936 breakByModule mod rest
1937 | all isDigit arg1 = do
1938 (toplevel, _) <- GHC.getContext
1940 (mod : _) -> breakByModuleLine mod (read arg1) rest
1942 io $ putStrLn "Cannot find default module for breakpoint."
1943 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1944 | otherwise = do -- try parsing it as an identifier
1945 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1946 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1947 if GHC.isGoodSrcLoc loc
1948 then ASSERT( isExternalName name )
1949 findBreakAndSet (GHC.nameModule name) $
1950 findBreakByCoord (Just (GHC.srcLocFile loc))
1951 (GHC.srcLocLine loc,
1953 else noCanDo name $ text "can't find its location: " <> ppr loc
1955 noCanDo n why = printForUser $
1956 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1958 breakByModule :: Module -> [String] -> GHCi ()
1959 breakByModule mod (arg1:rest)
1960 | all isDigit arg1 = do -- looks like a line number
1961 breakByModuleLine mod (read arg1) rest
1965 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1966 breakByModuleLine mod line args
1967 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1968 | [col] <- args, all isDigit col =
1969 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1970 | otherwise = breakSyntax
1973 breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1975 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1976 findBreakAndSet mod lookupTickTree = do
1977 tickArray <- getTickArray mod
1978 (breakArray, _) <- getModBreak mod
1979 case lookupTickTree tickArray of
1980 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1981 Just (tick, span) -> do
1982 success <- io $ setBreakFlag True breakArray tick
1986 recordBreak $ BreakLocation
1993 text "Breakpoint " <> ppr nm <>
1995 then text " was already set at " <> ppr span
1996 else text " activated at " <> ppr span
1998 printForUser $ text "Breakpoint could not be activated at"
2001 -- When a line number is specified, the current policy for choosing
2002 -- the best breakpoint is this:
2003 -- - the leftmost complete subexpression on the specified line, or
2004 -- - the leftmost subexpression starting on the specified line, or
2005 -- - the rightmost subexpression enclosing the specified line
2007 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2008 findBreakByLine line arr
2009 | not (inRange (bounds arr) line) = Nothing
2011 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
2012 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2013 listToMaybe (sortBy (rightmost `on` snd) ticks)
2017 starts_here = [ tick | tick@(_,span) <- ticks,
2018 GHC.srcSpanStartLine span == line ]
2020 (complete,incomplete) = partition ends_here starts_here
2021 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2023 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2024 -> Maybe (BreakIndex,SrcSpan)
2025 findBreakByCoord mb_file (line, col) arr
2026 | not (inRange (bounds arr) line) = Nothing
2028 listToMaybe (sortBy (rightmost `on` snd) contains ++
2029 sortBy (leftmost_smallest `on` snd) after_here)
2033 -- the ticks that span this coordinate
2034 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2035 is_correct_file span ]
2037 is_correct_file span
2038 | Just f <- mb_file = GHC.srcSpanFile span == f
2041 after_here = [ tick | tick@(_,span) <- ticks,
2042 GHC.srcSpanStartLine span == line,
2043 GHC.srcSpanStartCol span >= col ]
2045 -- For now, use ANSI bold on terminals that we know support it.
2046 -- Otherwise, we add a line of carets under the active expression instead.
2047 -- In particular, on Windows and when running the testsuite (which sets
2048 -- TERM to vt100 for other reasons) we get carets.
2049 -- We really ought to use a proper termcap/terminfo library.
2051 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2052 where mTerm = System.Environment.getEnv "TERM"
2053 `catchIO` \_ -> return "TERM not set"
2055 start_bold :: String
2056 start_bold = "\ESC[1m"
2058 end_bold = "\ESC[0m"
2060 listCmd :: String -> InputT GHCi ()
2062 mb_span <- lift getCurrentBreakSpan
2065 printForUser' $ text "Not stopped at a breakpoint; nothing to list"
2067 | GHC.isGoodSrcSpan span -> listAround span True
2069 do resumes <- GHC.getResumeContext
2071 [] -> panic "No resumes"
2073 do let traceIt = case GHC.resumeHistory r of
2074 [] -> text "rerunning with :trace,"
2076 doWhat = traceIt <+> text ":back then :list"
2077 printForUser' (text "Unable to list source for" <+>
2079 $$ text "Try" <+> doWhat)
2080 listCmd str = list2 (words str)
2082 list2 :: [String] -> InputT GHCi ()
2083 list2 [arg] | all isDigit arg = do
2084 (toplevel, _) <- GHC.getContext
2086 [] -> outputStrLn "No module to list"
2087 (mod : _) -> listModuleLine mod (read arg)
2088 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2089 mod <- wantInterpretedModule arg1
2090 listModuleLine mod (read arg2)
2092 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2093 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2094 if GHC.isGoodSrcLoc loc
2096 tickArray <- ASSERT( isExternalName name )
2097 lift $ getTickArray (GHC.nameModule name)
2098 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2099 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2102 Nothing -> listAround (GHC.srcLocSpan loc) False
2103 Just (_,span) -> listAround span False
2105 noCanDo name $ text "can't find its location: " <>
2108 noCanDo n why = printForUser' $
2109 text "cannot list source code for " <> ppr n <> text ": " <> why
2111 outputStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2113 listModuleLine :: Module -> Int -> InputT GHCi ()
2114 listModuleLine modl line = do
2115 graph <- GHC.getModuleGraph
2116 let this = filter ((== modl) . GHC.ms_mod) graph
2118 [] -> panic "listModuleLine"
2120 let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
2121 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2122 listAround (GHC.srcLocSpan loc) False
2124 -- | list a section of a source file around a particular SrcSpan.
2125 -- If the highlight flag is True, also highlight the span using
2126 -- start_bold\/end_bold.
2128 -- GHC files are UTF-8, so we can implement this by:
2129 -- 1) read the file in as a BS and syntax highlight it as before
2130 -- 2) convert the BS to String using utf-string, and write it out.
2131 -- It would be better if we could convert directly between UTF-8 and the
2132 -- console encoding, of course.
2133 listAround :: MonadIO m => SrcSpan -> Bool -> InputT m ()
2134 listAround span do_highlight = do
2135 contents <- liftIO $ BS.readFile (unpackFS file)
2137 lines = BS.split '\n' contents
2138 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2139 drop (line1 - 1 - pad_before) $ lines
2140 fst_line = max 1 (line1 - pad_before)
2141 line_nos = [ fst_line .. ]
2143 highlighted | do_highlight = zipWith highlight line_nos these_lines
2144 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2146 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2147 prefixed = zipWith ($) highlighted bs_line_nos
2149 let output = BS.intercalate (BS.pack "\n") prefixed
2150 utf8Decoded <- liftIO $ BS.useAsCStringLen output
2151 $ \(p,n) -> utf8DecodeString (castPtr p) n
2152 outputStrLn utf8Decoded
2154 file = GHC.srcSpanFile span
2155 line1 = GHC.srcSpanStartLine span
2156 col1 = GHC.srcSpanStartCol span
2157 line2 = GHC.srcSpanEndLine span
2158 col2 = GHC.srcSpanEndCol span
2160 pad_before | line1 == 1 = 0
2164 highlight | do_bold = highlight_bold
2165 | otherwise = highlight_carets
2167 highlight_bold no line prefix
2168 | no == line1 && no == line2
2169 = let (a,r) = BS.splitAt col1 line
2170 (b,c) = BS.splitAt (col2-col1) r
2172 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2174 = let (a,b) = BS.splitAt col1 line in
2175 BS.concat [prefix, a, BS.pack start_bold, b]
2177 = let (a,b) = BS.splitAt col2 line in
2178 BS.concat [prefix, a, BS.pack end_bold, b]
2179 | otherwise = BS.concat [prefix, line]
2181 highlight_carets no line prefix
2182 | no == line1 && no == line2
2183 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2184 BS.replicate (col2-col1) '^']
2186 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2189 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2191 | otherwise = BS.concat [prefix, line]
2193 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2194 nl = BS.singleton '\n'
2196 -- --------------------------------------------------------------------------
2199 getTickArray :: Module -> GHCi TickArray
2200 getTickArray modl = do
2202 let arrmap = tickarrays st
2203 case lookupModuleEnv arrmap modl of
2204 Just arr -> return arr
2206 (_breakArray, ticks) <- getModBreak modl
2207 let arr = mkTickArray (assocs ticks)
2208 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2211 discardTickArrays :: GHCi ()
2212 discardTickArrays = do
2214 setGHCiState st{tickarrays = emptyModuleEnv}
2216 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2218 = accumArray (flip (:)) [] (1, max_line)
2219 [ (line, (nm,span)) | (nm,span) <- ticks,
2220 line <- srcSpanLines span ]
2222 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2223 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2224 GHC.srcSpanEndLine span ]
2226 lookupModule :: GHC.GhcMonad m => String -> m Module
2227 lookupModule modName
2228 = GHC.lookupModule (GHC.mkModuleName modName) Nothing
2230 -- don't reset the counter back to zero?
2231 discardActiveBreakPoints :: GHCi ()
2232 discardActiveBreakPoints = do
2234 mapM_ (turnOffBreak.snd) (breaks st)
2235 setGHCiState $ st { breaks = [] }
2237 deleteBreak :: Int -> GHCi ()
2238 deleteBreak identity = do
2240 let oldLocations = breaks st
2241 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2243 then printForUser (text "Breakpoint" <+> ppr identity <+>
2244 text "does not exist")
2246 mapM_ (turnOffBreak.snd) this
2247 setGHCiState $ st { breaks = rest }
2249 turnOffBreak :: BreakLocation -> GHCi Bool
2250 turnOffBreak loc = do
2251 (arr, _) <- getModBreak (breakModule loc)
2252 io $ setBreakFlag False arr (breakTick loc)
2254 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2255 getModBreak mod = do
2256 Just mod_info <- GHC.getModuleInfo mod
2257 let modBreaks = GHC.modInfoModBreaks mod_info
2258 let array = GHC.modBreaks_flags modBreaks
2259 let ticks = GHC.modBreaks_locs modBreaks
2260 return (array, ticks)
2262 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2263 setBreakFlag toggle array index
2264 | toggle = GHC.setBreakOn array index
2265 | otherwise = GHC.setBreakOff array index