1 {-# OPTIONS -fno-cse #-}
2 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
4 {-# OPTIONS -#include "Linker.h" #-}
5 -----------------------------------------------------------------------------
7 -- GHC Interactive User Interface
9 -- (c) The GHC Team 2005-2006
11 -----------------------------------------------------------------------------
13 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
15 #include "HsVersions.h"
17 import qualified GhciMonad
18 import GhciMonad hiding (runStmt)
23 import qualified GHC hiding (resume, runStmt)
24 import GHC ( LoadHowMuch(..), Target(..), TargetId(..),
25 Module, ModuleName, TyThing(..), Phase,
26 BreakIndex, SrcSpan, Resume, SingleStep,
27 Ghc, handleSourceError )
35 import HscTypes ( implicitTyThings, handleFlagWarnings )
36 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
37 import Outputable hiding (printForUser, printForUserPartWay)
38 import Module -- for ModuleEnv
43 -- Other random utilities
46 import BasicTypes hiding (isTopLevel)
47 import Panic hiding (showException)
53 import Maybes ( orElse, expectJust )
57 #ifndef mingw32_HOST_OS
58 import System.Posix hiding (getEnv)
60 import qualified System.Win32
63 import System.Console.Haskeline as Haskeline
64 import qualified System.Console.Haskeline.Encoding as Encoding
65 import Control.Monad.Trans
69 import Exception hiding (catch, block, unblock)
70 import qualified Exception
72 -- import Control.Concurrent
74 import System.FilePath
75 import qualified Data.ByteString.Char8 as BS
79 import System.Environment
80 import System.Exit ( exitWith, ExitCode(..) )
81 import System.Directory
83 import System.IO.Error as IO
86 import Control.Monad as Monad
89 import GHC.Exts ( unsafeCoerce# )
90 import GHC.IOBase ( IOErrorType(InvalidArgument) )
93 import Data.IORef ( IORef, readIORef, writeIORef )
95 -----------------------------------------------------------------------------
97 ghciWelcomeMsg :: String
98 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
99 ": http://www.haskell.org/ghc/ :? for help"
101 cmdName :: Command -> String
104 GLOBAL_VAR(macros_ref, [], [Command])
106 builtin_commands :: [Command]
108 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
109 ("?", keepGoing help, noCompletion),
110 ("add", keepGoingPaths addModule, completeFilename),
111 ("abandon", keepGoing abandonCmd, noCompletion),
112 ("break", keepGoing breakCmd, completeIdentifier),
113 ("back", keepGoing backCmd, noCompletion),
114 ("browse", keepGoing' (browseCmd False), completeModule),
115 ("browse!", keepGoing' (browseCmd True), completeModule),
116 ("cd", keepGoing' changeDirectory, completeFilename),
117 ("check", keepGoing' checkModule, completeHomeModule),
118 ("continue", keepGoing continueCmd, noCompletion),
119 ("cmd", keepGoing cmdCmd, completeExpression),
120 ("ctags", keepGoing createCTagsFileCmd, completeFilename),
121 ("def", keepGoing (defineMacro False), completeExpression),
122 ("def!", keepGoing (defineMacro True), completeExpression),
123 ("delete", keepGoing deleteCmd, noCompletion),
124 ("e", keepGoing editFile, completeFilename),
125 ("edit", keepGoing editFile, completeFilename),
126 ("etags", keepGoing createETagsFileCmd, completeFilename),
127 ("force", keepGoing forceCmd, completeExpression),
128 ("forward", keepGoing forwardCmd, noCompletion),
129 ("help", keepGoing help, noCompletion),
130 ("history", keepGoing historyCmd, noCompletion),
131 ("info", keepGoing' info, completeIdentifier),
132 ("kind", keepGoing' kindOfType, completeIdentifier),
133 ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),
134 ("list", keepGoing' listCmd, noCompletion),
135 ("module", keepGoing setContext, completeModule),
136 ("main", keepGoing runMain, completeFilename),
137 ("print", keepGoing printCmd, completeExpression),
138 ("quit", quit, noCompletion),
139 ("reload", keepGoing' reloadModule, noCompletion),
140 ("run", keepGoing runRun, completeFilename),
141 ("set", keepGoing setCmd, completeSetOptions),
142 ("show", keepGoing showCmd, completeShowOptions),
143 ("sprint", keepGoing sprintCmd, completeExpression),
144 ("step", keepGoing stepCmd, completeIdentifier),
145 ("steplocal", keepGoing stepLocalCmd, completeIdentifier),
146 ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),
147 ("type", keepGoing' typeOfExpr, completeExpression),
148 ("trace", keepGoing traceCmd, completeExpression),
149 ("undef", keepGoing undefineMacro, completeMacro),
150 ("unset", keepGoing unsetOptions, completeSetOptions)
154 -- We initialize readline (in the interactiveUI function) to use
155 -- word_break_chars as the default set of completion word break characters.
156 -- This can be overridden for a particular command (for example, filename
157 -- expansion shouldn't consider '/' to be a word break) by setting the third
158 -- entry in the Command tuple above.
160 -- NOTE: in order for us to override the default correctly, any custom entry
161 -- must be a SUBSET of word_break_chars.
162 word_break_chars :: String
163 word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
164 specials = "(),;[]`{}"
166 in spaces ++ specials ++ symbols
168 flagWordBreakChars :: String
169 flagWordBreakChars = " \t\n"
172 keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)
173 keepGoing a str = keepGoing' (lift . a) str
175 keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool
176 keepGoing' a str = a str >> return False
178 keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
180 = do case toArgs str of
181 Left err -> Encoding.encode err >>= liftIO . BS.hPutStrLn stderr
185 shortHelpText :: String
186 shortHelpText = "use :? for help.\n"
190 " Commands available from the prompt:\n" ++
192 " <statement> evaluate/run <statement>\n" ++
193 " : repeat last command\n" ++
194 " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
195 " :add [*]<module> ... add module(s) to the current target set\n" ++
196 " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
197 " (!: more details; *: all top-level names)\n" ++
198 " :cd <dir> change directory to <dir>\n" ++
199 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
200 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
201 " :def <cmd> <expr> define a command :<cmd>\n" ++
202 " :edit <file> edit file\n" ++
203 " :edit edit last module\n" ++
204 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
205 " :help, :? display this list of commands\n" ++
206 " :info [<name> ...] display information about the given names\n" ++
207 " :kind <type> show the kind of <type>\n" ++
208 " :load [*]<module> ... load module(s) and their dependents\n" ++
209 " :main [<arguments> ...] run the main function with the given arguments\n" ++
210 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
211 " :quit exit GHCi\n" ++
212 " :reload reload the current module set\n" ++
213 " :run function [<arguments> ...] run the function with the given arguments\n" ++
214 " :type <expr> show the type of <expr>\n" ++
215 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
216 " :!<command> run the shell command <command>\n" ++
218 " -- Commands for debugging:\n" ++
220 " :abandon at a breakpoint, abandon current computation\n" ++
221 " :back go back in the history (after :trace)\n" ++
222 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
223 " :break <name> set a breakpoint on the specified function\n" ++
224 " :continue resume after a breakpoint\n" ++
225 " :delete <number> delete the specified breakpoint\n" ++
226 " :delete * delete all breakpoints\n" ++
227 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
228 " :forward go forward in the history (after :back)\n" ++
229 " :history [<n>] after :trace, show the execution history\n" ++
230 " :list show the source code around current breakpoint\n" ++
231 " :list identifier show the source code for <identifier>\n" ++
232 " :list [<module>] <line> show the source code around line number <line>\n" ++
233 " :print [<name> ...] prints a value without forcing its computation\n" ++
234 " :sprint [<name> ...] simplifed version of :print\n" ++
235 " :step single-step after stopping at a breakpoint\n"++
236 " :step <expr> single-step into <expr>\n"++
237 " :steplocal single-step within the current top-level binding\n"++
238 " :stepmodule single-step restricted to the current module\n"++
239 " :trace trace after stopping at a breakpoint\n"++
240 " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++
243 " -- Commands for changing settings:\n" ++
245 " :set <option> ... set options\n" ++
246 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
247 " :set prog <progname> set the value returned by System.getProgName\n" ++
248 " :set prompt <prompt> set the prompt used in GHCi\n" ++
249 " :set editor <cmd> set the command used for :edit\n" ++
250 " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" ++
251 " :unset <option> ... unset options\n" ++
253 " Options for ':set' and ':unset':\n" ++
255 " +r revert top-level expressions after each evaluation\n" ++
256 " +s print timing/memory stats after each evaluation\n" ++
257 " +t print type after evaluation\n" ++
258 " -<flags> most GHC command line flags can also be set here\n" ++
259 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
260 " for GHCi-specific flags, see User's Guide,\n"++
261 " Flag reference, Interactive-mode options\n" ++
263 " -- Commands for displaying information:\n" ++
265 " :show bindings show the current bindings made at the prompt\n" ++
266 " :show breaks show the active breakpoints\n" ++
267 " :show context show the breakpoint context\n" ++
268 " :show modules show the currently loaded modules\n" ++
269 " :show packages show the currently active package flags\n" ++
270 " :show languages show the currently active language flags\n" ++
271 " :show <setting> show value of <setting>, which is one of\n" ++
272 " [args, prog, prompt, editor, stop]\n" ++
275 findEditor :: IO String
280 win <- System.Win32.getWindowsDirectory
281 return (win </> "notepad.exe")
286 interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String]
288 interactiveUI srcs maybe_exprs = do
289 -- although GHCi compiles with -prof, it is not usable: the byte-code
290 -- compiler and interpreter don't work with profiling. So we check for
291 -- this up front and emit a helpful error message (#2197)
292 m <- liftIO $ lookupSymbol "PushCostCentre"
294 ghcError (InstallationError "GHCi cannot be used when compiled with -prof")
296 -- HACK! If we happen to get into an infinite loop (eg the user
297 -- types 'let x=x in x' at the prompt), then the thread will block
298 -- on a blackhole, and become unreachable during GC. The GC will
299 -- detect that it is unreachable and send it the NonTermination
300 -- exception. However, since the thread is unreachable, everything
301 -- it refers to might be finalized, including the standard Handles.
302 -- This sounds like a bug, but we don't have a good solution right
304 liftIO $ newStablePtr stdin
305 liftIO $ newStablePtr stdout
306 liftIO $ newStablePtr stderr
308 -- Initialise buffering for the *interpreted* I/O system
311 liftIO $ when (isNothing maybe_exprs) $ do
312 -- Only for GHCi (not runghc and ghc -e):
314 -- Turn buffering off for the compiled program's stdout/stderr
316 -- Turn buffering off for GHCi's stdout
318 hSetBuffering stdout NoBuffering
319 -- We don't want the cmd line to buffer any input that might be
320 -- intended for the program, so unbuffer stdin.
321 hSetBuffering stdin NoBuffering
323 -- initial context is just the Prelude
324 prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing
325 GHC.setContext [] [prel_mod]
327 default_editor <- liftIO $ findEditor
329 startGHCi (runGHCi srcs maybe_exprs)
330 GHCiState{ progname = "<interactive>",
334 editor = default_editor,
335 -- session = session,
340 tickarrays = emptyModuleEnv,
341 last_command = Nothing,
344 ghc_e = isJust maybe_exprs
349 withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
350 withGhcAppData right left = do
351 either_dir <- IO.try (getAppUserDataDirectory "ghc")
353 Right dir -> right dir
356 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
357 runGHCi paths maybe_exprs = do
359 read_dot_files = not opt_IgnoreDotGhci
361 current_dir = return (Just ".ghci")
363 app_user_dir = io $ withGhcAppData
364 (\dir -> return (Just (dir </> "ghci.conf")))
368 either_dir <- io $ IO.try (getEnv "HOME")
370 Right home -> return (Just (home </> ".ghci"))
373 sourceConfigFile :: FilePath -> GHCi ()
374 sourceConfigFile file = do
375 exists <- io $ doesFileExist file
377 dir_ok <- io $ checkPerms (getDirectory file)
378 file_ok <- io $ checkPerms file
379 when (dir_ok && file_ok) $ do
380 either_hdl <- io $ IO.try (openFile file ReadMode)
383 -- NOTE: this assumes that runInputT won't affect the terminal;
384 -- can we assume this will always be the case?
385 -- This would be a good place for runFileInputT.
386 Right hdl -> runInputTWithPrefs defaultPrefs defaultSettings $ do
388 runCommands $ fileLoop hdl
390 getDirectory f = case takeDirectory f of "" -> "."; d -> d
392 when (read_dot_files) $ do
393 cfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
394 cfgs <- io $ mapM canonicalizePath (catMaybes cfgs0)
395 mapM_ sourceConfigFile (nub cfgs)
396 -- nub, because we don't want to read .ghci twice if the
399 -- Perform a :load for files given on the GHCi command line
400 -- When in -e mode, if the load fails then we want to stop
401 -- immediately rather than going on to evaluate the expression.
402 when (not (null paths)) $ do
403 ok <- ghciHandle (\e -> do showException e; return Failed) $
404 -- TODO: this is a hack.
405 runInputTWithPrefs defaultPrefs defaultSettings $ do
406 let (filePaths, phases) = unzip paths
407 filePaths' <- mapM (Encoding.decode . BS.pack) filePaths
408 loadModule (zip filePaths' phases)
409 when (isJust maybe_exprs && failed ok) $
410 io (exitWith (ExitFailure 1))
412 -- if verbosity is greater than 0, or we are connected to a
413 -- terminal, display the prompt in the interactive loop.
414 is_tty <- io (hIsTerminalDevice stdin)
415 dflags <- getDynFlags
416 let show_prompt = verbosity dflags > 0 || is_tty
421 -- enter the interactive loop
422 runGHCiInput $ runCommands $ haskelineLoop show_prompt
424 -- just evaluate the expression we were given
425 enqueueCommands exprs
426 let handle e = do st <- getGHCiState
427 -- Jump through some hoops to get the
428 -- current progname in the exception text:
429 -- <progname>: <exception>
430 io $ withProgName (progname st)
431 -- this used to be topHandlerFastExit, see #2228
433 runInputTWithPrefs defaultPrefs defaultSettings $ do
435 runCommands' handle (return Nothing)
438 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
440 runGHCiInput :: InputT GHCi a -> GHCi a
442 histFile <- io $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
444 let settings = setComplete ghciCompleteWord
445 $ defaultSettings {historyFile = histFile}
446 runInputT settings $ do
450 -- TODO really bad name
451 haskelineLoop :: Bool -> InputT GHCi (Maybe String)
452 haskelineLoop show_prompt = do
453 prompt <- if show_prompt then lift mkPrompt else return ""
454 l <- getInputLine prompt
458 -- NOTE: We only read .ghci files if they are owned by the current user,
459 -- and aren't world writable. Otherwise, we could be accidentally
460 -- running code planted by a malicious third party.
462 -- Furthermore, We only read ./.ghci if . is owned by the current user
463 -- and isn't writable by anyone else. I think this is sufficient: we
464 -- don't need to check .. and ../.. etc. because "." always refers to
465 -- the same directory while a process is running.
467 checkPerms :: String -> IO Bool
468 #ifdef mingw32_HOST_OS
473 handleIO (\_ -> return False) $ do
474 st <- getFileStatus name
476 if fileOwner st /= me then do
477 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
480 let mode = fileMode st
481 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
482 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
484 putStrLn $ "*** WARNING: " ++ name ++
485 " is writable by someone else, IGNORING!"
490 fileLoop :: MonadIO m => Handle -> InputT m (Maybe String)
492 l <- liftIO $ IO.try (BS.hGetLine hdl)
494 Left e | isEOFError e -> return Nothing
495 | InvalidArgument <- etype -> return Nothing
496 | otherwise -> liftIO $ ioError e
497 where etype = ioeGetErrorType e
498 -- treat InvalidArgument in the same way as EOF:
499 -- this can happen if the user closed stdin, or
500 -- perhaps did getContents which closes stdin at
502 Right l -> fmap Just (Encoding.decode l)
504 mkPrompt :: GHCi String
506 (toplevs,exports) <- GHC.getContext
507 resumes <- GHC.getResumeContext
508 -- st <- getGHCiState
514 let ix = GHC.resumeHistoryIx r
516 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
518 let hist = GHC.resumeHistory r !! (ix-1)
519 span <- GHC.getHistorySpan hist
520 return (brackets (ppr (negate ix) <> char ':'
521 <+> ppr span) <> space)
523 dots | _:rs <- resumes, not (null rs) = text "... "
530 -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
531 -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
532 -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
533 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
534 hsep (map (ppr . GHC.moduleName) exports)
536 deflt_prompt = dots <> context_bit <> modules_bit
538 f ('%':'s':xs) = deflt_prompt <> f xs
539 f ('%':'%':xs) = char '%' <> f xs
540 f (x:xs) = char x <> f xs
544 return (showSDoc (f (prompt st)))
547 queryQueue :: GHCi (Maybe String)
552 c:cs -> do setGHCiState st{ cmdqueue = cs }
555 runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
556 runCommands = runCommands' handler
558 runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
559 -> InputT GHCi (Maybe String) -> InputT GHCi ()
560 runCommands' eh getCmd = do
561 b <- handleGhcException (\e -> case e of
562 Interrupted -> return False
563 _other -> liftIO (print e) >> return True)
564 (runOneCommand eh getCmd)
565 if b then return () else runCommands' eh getCmd
567 runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
569 runOneCommand eh getCmd = do
570 mb_cmd <- noSpace (lift queryQueue)
571 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
573 Nothing -> return True
574 Just c -> ghciHandle (lift . eh) $
575 handleSourceError printErrorAndKeepGoing
578 printErrorAndKeepGoing err = do
579 GHC.printExceptionAndWarnings err
582 noSpace q = q >>= maybe (return Nothing)
583 (\c->case removeSpaces c of
585 ":{" -> multiLineCmd q
586 c -> return (Just c) )
588 st <- lift getGHCiState
590 lift $ setGHCiState st{ prompt = "%s| " }
591 mb_cmd <- collectCommand q ""
592 lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p }
594 -- we can't use removeSpaces for the sublines here, so
595 -- multiline commands are somewhat more brittle against
596 -- fileformat errors (such as \r in dos input on unix),
597 -- we get rid of any extra spaces for the ":}" test;
598 -- we also avoid silent failure if ":}" is not found;
599 -- and since there is no (?) valid occurrence of \r (as
600 -- opposed to its String representation, "\r") inside a
601 -- ghci command, we replace any such with ' ' (argh:-(
602 collectCommand q c = q >>=
603 maybe (liftIO (ioError collectError))
604 (\l->if removeSpaces l == ":}"
605 then return (Just $ removeSpaces c)
606 else collectCommand q (c++map normSpace l))
607 where normSpace '\r' = ' '
609 -- QUESTION: is userError the one to use here?
610 collectError = userError "unterminated multiline command :{ .. :}"
611 doCommand (':' : cmd) = specialCommand cmd
612 doCommand stmt = do timeIt $ lift $ runStmt stmt GHC.RunToCompletion
615 enqueueCommands :: [String] -> GHCi ()
616 enqueueCommands cmds = do
618 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
621 runStmt :: String -> SingleStep -> GHCi Bool
623 | null (filter (not.isSpace) stmt) = return False
624 | ["import", mod] <- words stmt = keepGoing' setContext ('+':mod)
626 = do result <- GhciMonad.runStmt stmt step
627 afterRunStmt (const True) result
629 --afterRunStmt :: GHC.RunResult -> GHCi Bool
630 -- False <=> the statement failed to compile
631 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
632 afterRunStmt _ (GHC.RunException e) = throw e
633 afterRunStmt step_here run_result = do
634 resumes <- GHC.getResumeContext
636 GHC.RunOk names -> do
637 show_types <- isOptionSet ShowType
638 when show_types $ printTypeOfNames names
639 GHC.RunBreak _ names mb_info
640 | isNothing mb_info ||
641 step_here (GHC.resumeSpan $ head resumes) -> do
642 mb_id_loc <- toBreakIdAndLocation mb_info
643 let breakCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
645 then printStoppedAtBreakInfo (head resumes) names
646 else enqueueCommands [breakCmd]
647 -- run the command set with ":set stop <cmd>"
649 enqueueCommands [stop st]
651 | otherwise -> resume step_here GHC.SingleStep >>=
652 afterRunStmt step_here >> return ()
656 io installSignalHandlers
657 b <- isOptionSet RevertCAFs
660 return (case run_result of GHC.RunOk _ -> True; _ -> False)
662 toBreakIdAndLocation ::
663 Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
664 toBreakIdAndLocation Nothing = return Nothing
665 toBreakIdAndLocation (Just info) = do
666 let mod = GHC.breakInfo_module info
667 nm = GHC.breakInfo_number info
669 return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
670 breakModule loc == mod,
671 breakTick loc == nm ]
673 printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
674 printStoppedAtBreakInfo resume names = do
675 printForUser $ ptext (sLit "Stopped at") <+>
676 ppr (GHC.resumeSpan resume)
677 -- printTypeOfNames session names
678 let namesSorted = sortBy compareNames names
679 tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
680 docs <- pprTypeAndContents [id | AnId id <- tythings]
681 printForUserPartWay docs
683 printTypeOfNames :: [Name] -> GHCi ()
684 printTypeOfNames names
685 = mapM_ (printTypeOfName ) $ sortBy compareNames names
687 compareNames :: Name -> Name -> Ordering
688 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
689 where compareWith n = (getOccString n, getSrcSpan n)
691 printTypeOfName :: Name -> GHCi ()
693 = do maybe_tything <- GHC.lookupName n
694 case maybe_tything of
696 Just thing -> printTyThing thing
699 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
701 specialCommand :: String -> InputT GHCi Bool
702 specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
703 specialCommand str = do
704 let (cmd,rest) = break isSpace str
705 maybe_cmd <- lift $ lookupCommand cmd
707 GotCommand (_,f,_) -> f (dropWhile isSpace rest)
709 do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
713 do liftIO $ hPutStr stdout ("there is no last command to perform\n"
717 lookupCommand :: String -> GHCi (MaybeCommand)
718 lookupCommand "" = do
720 case last_command st of
721 Just c -> return $ GotCommand c
722 Nothing -> return NoLastCommand
723 lookupCommand str = do
724 mc <- io $ lookupCommand' str
726 setGHCiState st{ last_command = mc }
728 Just c -> GotCommand c
729 Nothing -> BadCommand
731 lookupCommand' :: String -> IO (Maybe Command)
732 lookupCommand' str = do
733 macros <- readIORef macros_ref
734 let cmds = builtin_commands ++ macros
735 -- look for exact match first, then the first prefix match
736 return $ case [ c | c <- cmds, str == cmdName c ] of
738 [] -> case [ c | c@(s,_,_) <- cmds, str `isPrefixOf` s ] of
742 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
743 getCurrentBreakSpan = do
744 resumes <- GHC.getResumeContext
748 let ix = GHC.resumeHistoryIx r
750 then return (Just (GHC.resumeSpan r))
752 let hist = GHC.resumeHistory r !! (ix-1)
753 span <- GHC.getHistorySpan hist
756 getCurrentBreakModule :: GHCi (Maybe Module)
757 getCurrentBreakModule = do
758 resumes <- GHC.getResumeContext
762 let ix = GHC.resumeHistoryIx r
764 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
766 let hist = GHC.resumeHistory r !! (ix-1)
767 return $ Just $ GHC.getHistoryModule hist
769 -----------------------------------------------------------------------------
772 noArgs :: GHCi () -> String -> GHCi ()
774 noArgs _ _ = io $ putStrLn "This command takes no arguments"
776 help :: String -> GHCi ()
777 help _ = io (putStr helpText)
779 info :: String -> InputT GHCi ()
780 info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
781 info s = handleSourceError GHC.printExceptionAndWarnings $ do
782 { let names = words s
783 ; dflags <- getDynFlags
784 ; let pefas = dopt Opt_PrintExplicitForalls dflags
785 ; mapM_ (infoThing pefas) names }
787 infoThing pefas str = do
788 names <- GHC.parseName str
789 mb_stuffs <- mapM GHC.getInfo names
790 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
791 unqual <- GHC.getPrintUnqual
792 outputStrLn $ showSDocForUser unqual $
793 vcat (intersperse (text "") $
794 map (pprInfo pefas) filtered)
796 -- Filter out names whose parent is also there Good
797 -- example is '[]', which is both a type and data
798 -- constructor in the same type
799 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
800 filterOutChildren get_thing xs
801 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
803 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
805 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
806 pprInfo pefas (thing, fixity, insts)
807 = pprTyThingInContextLoc pefas thing
808 $$ show_fixity fixity
809 $$ vcat (map GHC.pprInstance insts)
812 | fix == GHC.defaultFixity = empty
813 | otherwise = ppr fix <+> ppr (GHC.getName thing)
815 runMain :: String -> GHCi ()
816 runMain s = case toArgs s of
817 Left err -> io (hPutStrLn stderr err)
819 do dflags <- getDynFlags
820 case mainFunIs dflags of
821 Nothing -> doWithArgs args "main"
822 Just f -> doWithArgs args f
824 runRun :: String -> GHCi ()
825 runRun s = case toCmdArgs s of
826 Left err -> io (hPutStrLn stderr err)
827 Right (cmd, args) -> doWithArgs args cmd
829 doWithArgs :: [String] -> String -> GHCi ()
830 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
831 show args ++ " (" ++ cmd ++ ")"]
833 addModule :: [FilePath] -> InputT GHCi ()
835 lift revertCAFs -- always revert CAFs on load/add.
836 files <- mapM expandPath files
837 targets <- mapM (\m -> GHC.guessTarget m Nothing) files
838 -- remove old targets with the same id; e.g. for :add *M
839 mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
840 mapM_ GHC.addTarget targets
841 prev_context <- GHC.getContext
842 ok <- trySuccess $ GHC.load LoadAllTargets
843 afterLoad ok False prev_context
845 changeDirectory :: String -> InputT GHCi ()
846 changeDirectory "" = do
847 -- :cd on its own changes to the user's home directory
848 either_dir <- liftIO $ IO.try getHomeDirectory
851 Right dir -> changeDirectory dir
852 changeDirectory dir = do
853 graph <- GHC.getModuleGraph
854 when (not (null graph)) $
855 outputStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
856 prev_context <- GHC.getContext
858 GHC.load LoadAllTargets
859 lift $ setContextAfterLoad prev_context False []
860 GHC.workingDirectoryChanged
861 dir <- expandPath dir
862 liftIO $ setCurrentDirectory dir
864 trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
866 handleSourceError (\e -> do GHC.printExceptionAndWarnings e
870 editFile :: String -> GHCi ()
872 do file <- if null str then chooseEditFile else return str
876 $ ghcError (CmdLineError "editor not set, use :set editor")
877 io $ system (cmd ++ ' ':file)
880 -- The user didn't specify a file so we pick one for them.
881 -- Our strategy is to pick the first module that failed to load,
882 -- or otherwise the first target.
884 -- XXX: Can we figure out what happened if the depndecy analysis fails
885 -- (e.g., because the porgrammeer mistyped the name of a module)?
886 -- XXX: Can we figure out the location of an error to pass to the editor?
887 -- XXX: if we could figure out the list of errors that occured during the
888 -- last load/reaload, then we could start the editor focused on the first
890 chooseEditFile :: GHCi String
892 do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
894 graph <- GHC.getModuleGraph
895 failed_graph <- filterM hasFailed graph
896 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
898 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
901 case pick (order failed_graph) of
902 Just file -> return file
904 do targets <- GHC.getTargets
905 case msum (map fromTarget targets) of
906 Just file -> return file
907 Nothing -> ghcError (CmdLineError "No files to edit.")
909 where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
910 fromTarget _ = Nothing -- when would we get a module target?
912 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
913 defineMacro overwrite s = do
914 let (macro_name, definition) = break isSpace s
915 macros <- io (readIORef macros_ref)
916 let defined = map cmdName macros
919 then io $ putStrLn "no macros defined"
920 else io $ putStr ("the following macros are defined:\n" ++
923 if (not overwrite && macro_name `elem` defined)
924 then ghcError (CmdLineError
925 ("macro '" ++ macro_name ++ "' is already defined"))
928 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
930 -- give the expression a type signature, so we can be sure we're getting
931 -- something of the right type.
932 let new_expr = '(' : definition ++ ") :: String -> IO String"
934 -- compile the expression
935 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
936 hv <- GHC.compileExpr new_expr
937 io (writeIORef macros_ref --
938 (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)]))
940 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
942 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
943 -- make sure we force any exceptions in the result, while we are still
944 -- inside the exception handler for commands:
945 seqList str (return ())
946 enqueueCommands (lines str)
949 undefineMacro :: String -> GHCi ()
950 undefineMacro str = mapM_ undef (words str)
951 where undef macro_name = do
952 cmds <- io (readIORef macros_ref)
953 if (macro_name `notElem` map cmdName cmds)
954 then ghcError (CmdLineError
955 ("macro '" ++ macro_name ++ "' is not defined"))
957 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
959 cmdCmd :: String -> GHCi ()
961 let expr = '(' : str ++ ") :: IO String"
962 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
963 hv <- GHC.compileExpr expr
964 cmds <- io $ (unsafeCoerce# hv :: IO String)
965 enqueueCommands (lines cmds)
968 loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
969 loadModule fs = timeIt (loadModule' fs)
971 loadModule_ :: [FilePath] -> InputT GHCi ()
972 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
974 loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
975 loadModule' files = do
976 prev_context <- GHC.getContext
980 lift discardActiveBreakPoints
982 GHC.load LoadAllTargets
984 let (filenames, phases) = unzip files
985 exp_filenames <- mapM expandPath filenames
986 let files' = zip exp_filenames phases
987 targets <- mapM (uncurry GHC.guessTarget) files'
989 -- NOTE: we used to do the dependency anal first, so that if it
990 -- fails we didn't throw away the current set of modules. This would
991 -- require some re-working of the GHC interface, so we'll leave it
992 -- as a ToDo for now.
994 GHC.setTargets targets
995 doLoad False prev_context LoadAllTargets
997 checkModule :: String -> InputT GHCi ()
999 let modl = GHC.mkModuleName m
1000 prev_context <- GHC.getContext
1001 ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do
1002 r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
1003 outputStrLn (showSDoc (
1004 case GHC.moduleInfo r of
1005 cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1007 (local,global) = ASSERT( all isExternalName scope )
1008 partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1010 (text "global names: " <+> ppr global) $$
1011 (text "local names: " <+> ppr local)
1014 afterLoad (successIf ok) False prev_context
1016 reloadModule :: String -> InputT GHCi ()
1018 prev_context <- GHC.getContext
1019 doLoad True prev_context $
1020 if null m then LoadAllTargets
1021 else LoadUpTo (GHC.mkModuleName m)
1024 doLoad :: Bool -> ([Module],[Module]) -> LoadHowMuch -> InputT GHCi SuccessFlag
1025 doLoad retain_context prev_context howmuch = do
1026 -- turn off breakpoints before we load: we can't turn them off later, because
1027 -- the ModBreaks will have gone away.
1028 lift discardActiveBreakPoints
1029 ok <- trySuccess $ GHC.load howmuch
1030 afterLoad ok retain_context prev_context
1033 afterLoad :: SuccessFlag -> Bool -> ([Module],[Module]) -> InputT GHCi ()
1034 afterLoad ok retain_context prev_context = do
1035 lift revertCAFs -- always revert CAFs on load.
1036 lift discardTickArrays
1037 loaded_mod_summaries <- getLoadedModules
1038 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1039 loaded_mod_names = map GHC.moduleName loaded_mods
1040 modulesLoadedMsg ok loaded_mod_names
1042 lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
1045 setContextAfterLoad :: ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi ()
1046 setContextAfterLoad prev keep_ctxt [] = do
1047 prel_mod <- getPrelude
1048 setContextKeepingPackageModules prev keep_ctxt ([], [prel_mod])
1049 setContextAfterLoad prev keep_ctxt ms = do
1050 -- load a target if one is available, otherwise load the topmost module.
1051 targets <- GHC.getTargets
1052 case [ m | Just m <- map (findTarget ms) targets ] of
1054 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1055 load_this (last graph')
1060 = case filter (`matches` t) ms of
1064 summary `matches` Target (TargetModule m) _ _
1065 = GHC.ms_mod_name summary == m
1066 summary `matches` Target (TargetFile f _) _ _
1067 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1071 load_this summary | m <- GHC.ms_mod summary = do
1072 b <- GHC.moduleIsInterpreted m
1073 if b then setContextKeepingPackageModules prev keep_ctxt ([m], [])
1075 prel_mod <- getPrelude
1076 setContextKeepingPackageModules prev keep_ctxt ([],[prel_mod,m])
1078 -- | Keep any package modules (except Prelude) when changing the context.
1079 setContextKeepingPackageModules
1080 :: ([Module],[Module]) -- previous context
1081 -> Bool -- re-execute :module commands
1082 -> ([Module],[Module]) -- new context
1084 setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do
1085 let (_,bs0) = prev_context
1086 prel_mod <- getPrelude
1087 let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1088 let bs1 = if null as then nub (prel_mod : bs) else bs
1089 GHC.setContext as (nub (bs1 ++ pkg_modules))
1093 mapM_ (playCtxtCmd False) (remembered_ctx st)
1096 setGHCiState st{ remembered_ctx = [] }
1098 isHomeModule :: Module -> Bool
1099 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1101 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi ()
1102 modulesLoadedMsg ok mods = do
1103 dflags <- getDynFlags
1104 when (verbosity dflags > 0) $ do
1106 | null mods = text "none."
1107 | otherwise = hsep (
1108 punctuate comma (map ppr mods)) <> text "."
1111 outputStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))
1113 outputStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas))
1116 typeOfExpr :: String -> InputT GHCi ()
1118 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1119 ty <- GHC.exprType str
1120 dflags <- getDynFlags
1121 let pefas = dopt Opt_PrintExplicitForalls dflags
1122 printForUser' $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]
1124 kindOfType :: String -> InputT GHCi ()
1126 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1127 ty <- GHC.typeKind str
1128 printForUser' $ text str <+> dcolon <+> ppr ty
1130 quit :: String -> InputT GHCi Bool
1131 quit _ = return True
1133 shellEscape :: String -> GHCi Bool
1134 shellEscape str = io (system str >> return False)
1136 -----------------------------------------------------------------------------
1137 -- Browsing a module's contents
1139 browseCmd :: Bool -> String -> InputT GHCi ()
1142 ['*':s] | looksLikeModuleName s -> do
1143 m <- lift $ wantInterpretedModule s
1144 browseModule bang m False
1145 [s] | looksLikeModuleName s -> do
1146 m <- lift $ lookupModule s
1147 browseModule bang m True
1149 (as,bs) <- GHC.getContext
1150 -- Guess which module the user wants to browse. Pick
1151 -- modules that are interpreted first. The most
1152 -- recently-added module occurs last, it seems.
1154 (as@(_:_), _) -> browseModule bang (last as) True
1155 ([], bs@(_:_)) -> browseModule bang (last bs) True
1156 ([], []) -> ghcError (CmdLineError ":browse: no current module")
1157 _ -> ghcError (CmdLineError "syntax: :browse <module>")
1159 -- without bang, show items in context of their parents and omit children
1160 -- with bang, show class methods and data constructors separately, and
1161 -- indicate import modules, to aid qualifying unqualified names
1162 -- with sorted, sort items alphabetically
1163 browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
1164 browseModule bang modl exports_only = do
1165 -- :browse! reports qualifiers wrt current context
1166 current_unqual <- GHC.getPrintUnqual
1167 -- Temporarily set the context to the module we're interested in,
1168 -- just so we can get an appropriate PrintUnqualified
1169 (as,bs) <- GHC.getContext
1170 prel_mod <- lift getPrelude
1171 if exports_only then GHC.setContext [] [prel_mod,modl]
1172 else GHC.setContext [modl] []
1173 target_unqual <- GHC.getPrintUnqual
1174 GHC.setContext as bs
1176 let unqual = if bang then current_unqual else target_unqual
1178 mb_mod_info <- GHC.getModuleInfo modl
1180 Nothing -> ghcError (CmdLineError ("unknown module: " ++
1181 GHC.moduleNameString (GHC.moduleName modl)))
1183 dflags <- getDynFlags
1185 | exports_only = GHC.modInfoExports mod_info
1186 | otherwise = GHC.modInfoTopLevelScope mod_info
1189 -- sort alphabetically name, but putting
1190 -- locally-defined identifiers first.
1191 -- We would like to improve this; see #1799.
1192 sorted_names = loc_sort local ++ occ_sort external
1194 (local,external) = ASSERT( all isExternalName names )
1195 partition ((==modl) . nameModule) names
1196 occ_sort = sortBy (compare `on` nameOccName)
1197 -- try to sort by src location. If the first name in
1198 -- our list has a good source location, then they all should.
1200 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1201 = sortBy (compare `on` nameSrcSpan) names
1205 mb_things <- mapM GHC.lookupName sorted_names
1206 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1208 rdr_env <- GHC.getGRE
1210 let pefas = dopt Opt_PrintExplicitForalls dflags
1211 things | bang = catMaybes mb_things
1212 | otherwise = filtered_things
1213 pretty | bang = pprTyThing
1214 | otherwise = pprTyThingInContext
1216 labels [] = text "-- not currently imported"
1217 labels l = text $ intercalate "\n" $ map qualifier l
1218 qualifier = maybe "-- defined locally"
1219 (("-- imported via "++) . intercalate ", "
1220 . map GHC.moduleNameString)
1221 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1222 modNames = map (importInfo . GHC.getName) things
1224 -- annotate groups of imports with their import modules
1225 -- the default ordering is somewhat arbitrary, so we group
1226 -- by header and sort groups; the names themselves should
1227 -- really come in order of source appearance.. (trac #1799)
1228 annotate mts = concatMap (\(m,ts)->labels m:ts)
1229 $ sortBy cmpQualifiers $ group mts
1230 where cmpQualifiers =
1231 compare `on` (map (fmap (map moduleNameFS)) . fst)
1233 group mts@((m,_):_) = (m,map snd g) : group ng
1234 where (g,ng) = partition ((==m).fst) mts
1236 let prettyThings = map (pretty pefas) things
1237 prettyThings' | bang = annotate $ zip modNames prettyThings
1238 | otherwise = prettyThings
1239 outputStrLn $ showSDocForUser unqual (vcat prettyThings')
1240 -- ToDo: modInfoInstances currently throws an exception for
1241 -- package modules. When it works, we can do this:
1242 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1244 -----------------------------------------------------------------------------
1245 -- Setting the module context
1247 setContext :: String -> GHCi ()
1249 | all sensible strs = do
1250 playCtxtCmd True (cmd, as, bs)
1252 setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] }
1253 | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1255 (cmd, strs, as, bs) =
1257 '+':stuff -> rest AddModules stuff
1258 '-':stuff -> rest RemModules stuff
1259 stuff -> rest SetContext stuff
1261 rest cmd stuff = (cmd, strs, as, bs)
1262 where strs = words stuff
1263 (as,bs) = partitionWith starred strs
1265 sensible ('*':m) = looksLikeModuleName m
1266 sensible m = looksLikeModuleName m
1268 starred ('*':m) = Left m
1271 playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi ()
1272 playCtxtCmd fail (cmd, as, bs)
1274 (as',bs') <- do_checks fail
1275 (prev_as,prev_bs) <- GHC.getContext
1279 prel_mod <- getPrelude
1280 let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs'
1284 let as_to_add = as' \\ (prev_as ++ prev_bs)
1285 bs_to_add = bs' \\ (prev_as ++ prev_bs)
1286 return (prev_as ++ as_to_add, prev_bs ++ bs_to_add)
1288 let new_as = prev_as \\ (as' ++ bs')
1289 new_bs = prev_bs \\ (as' ++ bs')
1290 return (new_as, new_bs)
1291 GHC.setContext new_as new_bs
1294 as' <- mapM wantInterpretedModule as
1295 bs' <- mapM lookupModule bs
1297 do_checks False = do
1298 as' <- mapM (trymaybe . wantInterpretedModule) as
1299 bs' <- mapM (trymaybe . lookupModule) bs
1300 return (catMaybes as', catMaybes bs')
1305 Left _ -> return Nothing
1306 Right a -> return (Just a)
1308 ----------------------------------------------------------------------------
1311 -- set options in the interpreter. Syntax is exactly the same as the
1312 -- ghc command line, except that certain options aren't available (-C,
1315 -- This is pretty fragile: most options won't work as expected. ToDo:
1316 -- figure out which ones & disallow them.
1318 setCmd :: String -> GHCi ()
1320 = do st <- getGHCiState
1321 let opts = options st
1322 io $ putStrLn (showSDoc (
1323 text "options currently set: " <>
1326 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1328 dflags <- getDynFlags
1329 io $ putStrLn (showSDoc (
1330 vcat (text "GHCi-specific dynamic flag settings:"
1331 :map (flagSetting dflags) ghciFlags)
1333 io $ putStrLn (showSDoc (
1334 vcat (text "other dynamic, non-language, flag settings:"
1335 :map (flagSetting dflags) nonLanguageDynFlags)
1337 where flagSetting dflags (str, f, _)
1338 | dopt f dflags = text " " <> text "-f" <> text str
1339 | otherwise = text " " <> text "-fno-" <> text str
1340 (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags)
1342 nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions)
1344 flags = [Opt_PrintExplicitForalls
1345 ,Opt_PrintBindResult
1346 ,Opt_BreakOnException
1348 ,Opt_PrintEvldWithShow
1351 = case getCmd str of
1352 Right ("args", rest) ->
1354 Left err -> io (hPutStrLn stderr err)
1355 Right args -> setArgs args
1356 Right ("prog", rest) ->
1358 Right [prog] -> setProg prog
1359 _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")
1360 Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1361 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1362 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1363 _ -> case toArgs str of
1364 Left err -> io (hPutStrLn stderr err)
1365 Right wds -> setOptions wds
1367 setArgs, setOptions :: [String] -> GHCi ()
1368 setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
1372 setGHCiState st{ args = args }
1376 setGHCiState st{ progname = prog }
1380 setGHCiState st{ editor = cmd }
1382 setStop str@(c:_) | isDigit c
1383 = do let (nm_str,rest) = break (not.isDigit) str
1386 let old_breaks = breaks st
1387 if all ((/= nm) . fst) old_breaks
1388 then printForUser (text "Breakpoint" <+> ppr nm <+>
1389 text "does not exist")
1391 let new_breaks = map fn old_breaks
1392 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1393 | otherwise = (i,loc)
1394 setGHCiState st{ breaks = new_breaks }
1397 setGHCiState st{ stop = cmd }
1399 setPrompt value = do
1402 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1404 '\"' : _ -> case reads value of
1405 [(value', xs)] | all isSpace xs ->
1406 setGHCiState (st { prompt = value' })
1408 io $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
1409 _ -> setGHCiState (st { prompt = value })
1412 do -- first, deal with the GHCi opts (+s, +t, etc.)
1413 let (plus_opts, minus_opts) = partitionWith isPlus wds
1414 mapM_ setOpt plus_opts
1415 -- then, dynamic flags
1416 newDynFlags minus_opts
1418 newDynFlags :: [String] -> GHCi ()
1419 newDynFlags minus_opts = do
1420 dflags <- getDynFlags
1421 let pkg_flags = packageFlags dflags
1422 (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
1423 handleFlagWarnings dflags' warns
1425 if (not (null leftovers))
1426 then ghcError $ errorsToGhcException leftovers
1429 new_pkgs <- setDynFlags dflags'
1431 -- if the package flags changed, we should reset the context
1432 -- and link the new packages.
1433 dflags <- getDynFlags
1434 when (packageFlags dflags /= pkg_flags) $ do
1435 io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
1437 GHC.load LoadAllTargets
1438 io (linkPackages dflags new_pkgs)
1439 -- package flags changed, we can't re-use any of the old context
1440 setContextAfterLoad ([],[]) False []
1444 unsetOptions :: String -> GHCi ()
1446 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1447 let opts = words str
1448 (minus_opts, rest1) = partition isMinus opts
1449 (plus_opts, rest2) = partitionWith isPlus rest1
1451 if (not (null rest2))
1452 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1455 mapM_ unsetOpt plus_opts
1457 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1458 no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
1460 no_flags <- mapM no_flag minus_opts
1461 newDynFlags no_flags
1463 isMinus :: String -> Bool
1464 isMinus ('-':_) = True
1467 isPlus :: String -> Either String String
1468 isPlus ('+':opt) = Left opt
1469 isPlus other = Right other
1471 setOpt, unsetOpt :: String -> GHCi ()
1474 = case strToGHCiOpt str of
1475 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1476 Just o -> setOption o
1479 = case strToGHCiOpt str of
1480 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1481 Just o -> unsetOption o
1483 strToGHCiOpt :: String -> (Maybe GHCiOption)
1484 strToGHCiOpt "s" = Just ShowTiming
1485 strToGHCiOpt "t" = Just ShowType
1486 strToGHCiOpt "r" = Just RevertCAFs
1487 strToGHCiOpt _ = Nothing
1489 optToStr :: GHCiOption -> String
1490 optToStr ShowTiming = "s"
1491 optToStr ShowType = "t"
1492 optToStr RevertCAFs = "r"
1494 -- ---------------------------------------------------------------------------
1497 showCmd :: String -> GHCi ()
1501 ["args"] -> io $ putStrLn (show (args st))
1502 ["prog"] -> io $ putStrLn (show (progname st))
1503 ["prompt"] -> io $ putStrLn (show (prompt st))
1504 ["editor"] -> io $ putStrLn (show (editor st))
1505 ["stop"] -> io $ putStrLn (show (stop st))
1506 ["modules" ] -> showModules
1507 ["bindings"] -> showBindings
1508 ["linker"] -> io showLinkerState
1509 ["breaks"] -> showBkptTable
1510 ["context"] -> showContext
1511 ["packages"] -> showPackages
1512 ["languages"] -> showLanguages
1513 _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
1514 " | breaks | context | packages | languages ]"))
1516 showModules :: GHCi ()
1518 loaded_mods <- getLoadedModules
1519 -- we want *loaded* modules only, see #1734
1520 let show_one ms = do m <- GHC.showModule ms; io (putStrLn m)
1521 mapM_ show_one loaded_mods
1523 getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
1524 getLoadedModules = do
1525 graph <- GHC.getModuleGraph
1526 filterM (GHC.isLoaded . GHC.ms_mod_name) graph
1528 showBindings :: GHCi ()
1530 bindings <- GHC.getBindings
1531 docs <- pprTypeAndContents
1532 [ id | AnId id <- sortBy compareTyThings bindings]
1533 printForUserPartWay docs
1535 compareTyThings :: TyThing -> TyThing -> Ordering
1536 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1538 printTyThing :: TyThing -> GHCi ()
1539 printTyThing tyth = do dflags <- getDynFlags
1540 let pefas = dopt Opt_PrintExplicitForalls dflags
1541 printForUser (pprTyThing pefas tyth)
1543 showBkptTable :: GHCi ()
1546 printForUser $ prettyLocations (breaks st)
1548 showContext :: GHCi ()
1550 resumes <- GHC.getResumeContext
1551 printForUser $ vcat (map pp_resume (reverse resumes))
1554 ptext (sLit "--> ") <> text (GHC.resumeStmt resume)
1555 $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume))
1557 showPackages :: GHCi ()
1559 pkg_flags <- fmap packageFlags getDynFlags
1560 io $ putStrLn $ showSDoc $ vcat $
1561 text ("active package flags:"++if null pkg_flags then " none" else "")
1562 : map showFlag pkg_flags
1563 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1564 io $ putStrLn $ showSDoc $ vcat $
1565 text "packages currently loaded:"
1566 : map (nest 2 . text . packageIdString)
1567 (sortBy (compare `on` packageIdFS) pkg_ids)
1568 where showFlag (ExposePackage p) = text $ " -package " ++ p
1569 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1570 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1572 showLanguages :: GHCi ()
1574 dflags <- getDynFlags
1575 io $ putStrLn $ showSDoc $ vcat $
1576 text "active language flags:" :
1577 [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags]
1579 -- -----------------------------------------------------------------------------
1582 completeCmd, completeMacro, completeIdentifier, completeModule,
1583 completeHomeModule, completeSetOptions, completeShowOptions,
1584 completeHomeModuleOrFile, completeExpression
1585 :: CompletionFunc GHCi
1587 ghciCompleteWord :: CompletionFunc GHCi
1588 ghciCompleteWord line@(left,_) = case firstWord of
1589 ':':cmd | null rest -> completeCmd line
1591 completion <- lookupCompletion cmd
1593 "import" -> completeModule line
1594 _ -> completeExpression line
1596 (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
1597 lookupCompletion ('!':_) = return completeFilename
1598 lookupCompletion c = do
1599 maybe_cmd <- liftIO $ lookupCommand' c
1601 Just (_,_,f) -> return f
1602 Nothing -> return completeFilename
1604 completeCmd = wrapCompleter " " $ \w -> do
1605 cmds <- liftIO $ readIORef macros_ref
1606 return (filter (w `isPrefixOf`) (map (':':)
1607 (map cmdName (builtin_commands ++ cmds))))
1609 completeMacro = wrapIdentCompleter $ \w -> do
1610 cmds <- liftIO $ readIORef macros_ref
1611 return (filter (w `isPrefixOf`) (map cmdName cmds))
1613 completeIdentifier = wrapIdentCompleter $ \w -> do
1614 rdrs <- GHC.getRdrNamesInScope
1615 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1617 completeModule = wrapIdentCompleter $ \w -> do
1618 dflags <- GHC.getSessionDynFlags
1619 let pkg_mods = allExposedModules dflags
1620 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
1621 return $ filter (w `isPrefixOf`)
1622 $ map (showSDoc.ppr) $ loaded_mods ++ pkg_mods
1624 completeHomeModule = wrapIdentCompleter listHomeModules
1626 listHomeModules :: String -> GHCi [String]
1627 listHomeModules w = do
1628 g <- GHC.getModuleGraph
1629 let home_mods = map GHC.ms_mod_name g
1630 return $ sort $ filter (w `isPrefixOf`)
1631 $ map (showSDoc.ppr) home_mods
1633 completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
1634 return (filter (w `isPrefixOf`) options)
1635 where options = "args":"prog":"prompt":"editor":"stop":flagList
1636 flagList = map head $ group $ sort allFlags
1638 completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
1639 return (filter (w `isPrefixOf`) options)
1640 where options = ["args", "prog", "prompt", "editor", "stop",
1641 "modules", "bindings", "linker", "breaks",
1642 "context", "packages", "languages"]
1644 completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
1645 $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
1648 unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
1649 unionComplete f1 f2 line = do
1654 wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
1655 wrapCompleter breakChars fun = completeWord Nothing breakChars
1656 $ fmap (map simpleCompletion) . fmap sort . fun
1658 wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
1659 wrapIdentCompleter = wrapCompleter word_break_chars
1661 allExposedModules :: DynFlags -> [ModuleName]
1662 allExposedModules dflags
1663 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1665 pkg_db = pkgIdMap (pkgState dflags)
1667 completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
1670 -- ---------------------------------------------------------------------------
1671 -- User code exception handling
1673 -- This is the exception handler for exceptions generated by the
1674 -- user's code and exceptions coming from children sessions;
1675 -- it normally just prints out the exception. The
1676 -- handler must be recursive, in case showing the exception causes
1677 -- more exceptions to be raised.
1679 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1680 -- raising another exception. We therefore don't put the recursive
1681 -- handler arond the flushing operation, so if stderr is closed
1682 -- GHCi will just die gracefully rather than going into an infinite loop.
1683 handler :: SomeException -> GHCi Bool
1685 handler exception = do
1687 io installSignalHandlers
1688 ghciHandle handler (showException exception >> return False)
1690 showException :: SomeException -> GHCi ()
1692 io $ case fromException se of
1693 Just Interrupted -> putStrLn "Interrupted."
1694 -- omit the location for CmdLineError:
1695 Just (CmdLineError s) -> putStrLn s
1697 Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
1698 Just other_ghc_ex -> print other_ghc_ex
1699 Nothing -> putStrLn ("*** Exception: " ++ show se)
1701 -----------------------------------------------------------------------------
1702 -- recursive exception handlers
1704 -- Don't forget to unblock async exceptions in the handler, or if we're
1705 -- in an exception loop (eg. let a = error a in a) the ^C exception
1706 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1708 ghciHandle :: MonadException m => (SomeException -> m a) -> m a -> m a
1709 ghciHandle h m = Haskeline.catch m $ \e -> unblock (h e)
1711 ghciTry :: GHCi a -> GHCi (Either SomeException a)
1712 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
1714 -- ----------------------------------------------------------------------------
1717 -- TODO: won't work if home dir is encoded.
1718 -- (changeDirectory may not work either in that case.)
1719 expandPath :: MonadIO m => String -> InputT m String
1720 expandPath path = do
1721 exp_path <- liftIO $ expandPathIO path
1722 enc <- fmap BS.unpack $ Encoding.encode exp_path
1725 expandPathIO :: String -> IO String
1727 case dropWhile isSpace path of
1729 tilde <- getHomeDirectory -- will fail if HOME not defined
1730 return (tilde ++ '/':d)
1734 wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
1735 wantInterpretedModule str = do
1736 modl <- lookupModule str
1737 dflags <- getDynFlags
1738 when (GHC.modulePackageId modl /= thisPackage dflags) $
1739 ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
1740 is_interpreted <- GHC.moduleIsInterpreted modl
1741 when (not is_interpreted) $
1742 ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
1745 wantNameFromInterpretedModule :: GHC.GhcMonad m
1746 => (Name -> SDoc -> m ())
1750 wantNameFromInterpretedModule noCanDo str and_then =
1751 handleSourceError (GHC.printExceptionAndWarnings) $ do
1752 names <- GHC.parseName str
1756 let modl = ASSERT( isExternalName n ) GHC.nameModule n
1757 if not (GHC.isExternalName n)
1758 then noCanDo n $ ppr n <>
1759 text " is not defined in an interpreted module"
1761 is_interpreted <- GHC.moduleIsInterpreted modl
1762 if not is_interpreted
1763 then noCanDo n $ text "module " <> ppr modl <>
1764 text " is not interpreted"
1767 -- -----------------------------------------------------------------------------
1768 -- commands for debugger
1770 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1771 sprintCmd = pprintCommand False False
1772 printCmd = pprintCommand True False
1773 forceCmd = pprintCommand False True
1775 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1776 pprintCommand bind force str = do
1777 pprintClosureCommand bind force str
1779 stepCmd :: String -> GHCi ()
1780 stepCmd [] = doContinue (const True) GHC.SingleStep
1781 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1783 stepLocalCmd :: String -> GHCi ()
1784 stepLocalCmd [] = do
1785 mb_span <- getCurrentBreakSpan
1787 Nothing -> stepCmd []
1789 Just mod <- getCurrentBreakModule
1790 current_toplevel_decl <- enclosingTickSpan mod loc
1791 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1793 stepLocalCmd expression = stepCmd expression
1795 stepModuleCmd :: String -> GHCi ()
1796 stepModuleCmd [] = do
1797 mb_span <- getCurrentBreakSpan
1799 Nothing -> stepCmd []
1801 Just span <- getCurrentBreakSpan
1802 let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span
1803 doContinue f GHC.SingleStep
1805 stepModuleCmd expression = stepCmd expression
1807 -- | Returns the span of the largest tick containing the srcspan given
1808 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1809 enclosingTickSpan mod src = do
1810 ticks <- getTickArray mod
1811 let line = srcSpanStartLine src
1812 ASSERT (inRange (bounds ticks) line) do
1813 let enclosing_spans = [ span | (_,span) <- ticks ! line
1814 , srcSpanEnd span >= srcSpanEnd src]
1815 return . head . sortBy leftmost_largest $ enclosing_spans
1817 traceCmd :: String -> GHCi ()
1818 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1819 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1821 continueCmd :: String -> GHCi ()
1822 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1824 -- doContinue :: SingleStep -> GHCi ()
1825 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1826 doContinue pred step = do
1827 runResult <- resume pred step
1828 afterRunStmt pred runResult
1831 abandonCmd :: String -> GHCi ()
1832 abandonCmd = noArgs $ do
1833 b <- GHC.abandon -- the prompt will change to indicate the new context
1834 when (not b) $ io $ putStrLn "There is no computation running."
1837 deleteCmd :: String -> GHCi ()
1838 deleteCmd argLine = do
1839 deleteSwitch $ words argLine
1841 deleteSwitch :: [String] -> GHCi ()
1843 io $ putStrLn "The delete command requires at least one argument."
1844 -- delete all break points
1845 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1846 deleteSwitch idents = do
1847 mapM_ deleteOneBreak idents
1849 deleteOneBreak :: String -> GHCi ()
1851 | all isDigit str = deleteBreak (read str)
1852 | otherwise = return ()
1854 historyCmd :: String -> GHCi ()
1856 | null arg = history 20
1857 | all isDigit arg = history (read arg)
1858 | otherwise = io $ putStrLn "Syntax: :history [num]"
1861 resumes <- GHC.getResumeContext
1863 [] -> io $ putStrLn "Not stopped at a breakpoint"
1865 let hist = GHC.resumeHistory r
1866 (took,rest) = splitAt num hist
1868 [] -> io $ putStrLn $
1869 "Empty history. Perhaps you forgot to use :trace?"
1871 spans <- mapM GHC.getHistorySpan took
1872 let nums = map (printf "-%-3d:") [(1::Int)..]
1873 names = map GHC.historyEnclosingDecl took
1874 printForUser (vcat(zipWith3
1875 (\x y z -> x <+> y <+> z)
1877 (map (bold . ppr) names)
1878 (map (parens . ppr) spans)))
1879 io $ putStrLn $ if null rest then "<end of history>" else "..."
1881 bold :: SDoc -> SDoc
1882 bold c | do_bold = text start_bold <> c <> text end_bold
1885 backCmd :: String -> GHCi ()
1886 backCmd = noArgs $ do
1887 (names, _, span) <- GHC.back
1888 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span
1889 printTypeOfNames names
1890 -- run the command set with ":set stop <cmd>"
1892 enqueueCommands [stop st]
1894 forwardCmd :: String -> GHCi ()
1895 forwardCmd = noArgs $ do
1896 (names, ix, span) <- GHC.forward
1897 printForUser $ (if (ix == 0)
1898 then ptext (sLit "Stopped at")
1899 else ptext (sLit "Logged breakpoint at")) <+> ppr span
1900 printTypeOfNames names
1901 -- run the command set with ":set stop <cmd>"
1903 enqueueCommands [stop st]
1905 -- handle the "break" command
1906 breakCmd :: String -> GHCi ()
1907 breakCmd argLine = do
1908 breakSwitch $ words argLine
1910 breakSwitch :: [String] -> GHCi ()
1912 io $ putStrLn "The break command requires at least one argument."
1913 breakSwitch (arg1:rest)
1914 | looksLikeModuleName arg1 && not (null rest) = do
1915 mod <- wantInterpretedModule arg1
1916 breakByModule mod rest
1917 | all isDigit arg1 = do
1918 (toplevel, _) <- GHC.getContext
1920 (mod : _) -> breakByModuleLine mod (read arg1) rest
1922 io $ putStrLn "Cannot find default module for breakpoint."
1923 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1924 | otherwise = do -- try parsing it as an identifier
1925 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1926 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1927 if GHC.isGoodSrcLoc loc
1928 then ASSERT( isExternalName name )
1929 findBreakAndSet (GHC.nameModule name) $
1930 findBreakByCoord (Just (GHC.srcLocFile loc))
1931 (GHC.srcLocLine loc,
1933 else noCanDo name $ text "can't find its location: " <> ppr loc
1935 noCanDo n why = printForUser $
1936 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1938 breakByModule :: Module -> [String] -> GHCi ()
1939 breakByModule mod (arg1:rest)
1940 | all isDigit arg1 = do -- looks like a line number
1941 breakByModuleLine mod (read arg1) rest
1945 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1946 breakByModuleLine mod line args
1947 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1948 | [col] <- args, all isDigit col =
1949 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1950 | otherwise = breakSyntax
1953 breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1955 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1956 findBreakAndSet mod lookupTickTree = do
1957 tickArray <- getTickArray mod
1958 (breakArray, _) <- getModBreak mod
1959 case lookupTickTree tickArray of
1960 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1961 Just (tick, span) -> do
1962 success <- io $ setBreakFlag True breakArray tick
1966 recordBreak $ BreakLocation
1973 text "Breakpoint " <> ppr nm <>
1975 then text " was already set at " <> ppr span
1976 else text " activated at " <> ppr span
1978 printForUser $ text "Breakpoint could not be activated at"
1981 -- When a line number is specified, the current policy for choosing
1982 -- the best breakpoint is this:
1983 -- - the leftmost complete subexpression on the specified line, or
1984 -- - the leftmost subexpression starting on the specified line, or
1985 -- - the rightmost subexpression enclosing the specified line
1987 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1988 findBreakByLine line arr
1989 | not (inRange (bounds arr) line) = Nothing
1991 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
1992 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
1993 listToMaybe (sortBy (rightmost `on` snd) ticks)
1997 starts_here = [ tick | tick@(_,span) <- ticks,
1998 GHC.srcSpanStartLine span == line ]
2000 (complete,incomplete) = partition ends_here starts_here
2001 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2003 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2004 -> Maybe (BreakIndex,SrcSpan)
2005 findBreakByCoord mb_file (line, col) arr
2006 | not (inRange (bounds arr) line) = Nothing
2008 listToMaybe (sortBy (rightmost `on` snd) contains ++
2009 sortBy (leftmost_smallest `on` snd) after_here)
2013 -- the ticks that span this coordinate
2014 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2015 is_correct_file span ]
2017 is_correct_file span
2018 | Just f <- mb_file = GHC.srcSpanFile span == f
2021 after_here = [ tick | tick@(_,span) <- ticks,
2022 GHC.srcSpanStartLine span == line,
2023 GHC.srcSpanStartCol span >= col ]
2025 -- For now, use ANSI bold on terminals that we know support it.
2026 -- Otherwise, we add a line of carets under the active expression instead.
2027 -- In particular, on Windows and when running the testsuite (which sets
2028 -- TERM to vt100 for other reasons) we get carets.
2029 -- We really ought to use a proper termcap/terminfo library.
2031 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2032 where mTerm = System.Environment.getEnv "TERM"
2033 `catchIO` \_ -> return "TERM not set"
2035 start_bold :: String
2036 start_bold = "\ESC[1m"
2038 end_bold = "\ESC[0m"
2040 listCmd :: String -> InputT GHCi ()
2042 mb_span <- lift getCurrentBreakSpan
2045 printForUser' $ text "Not stopped at a breakpoint; nothing to list"
2047 | GHC.isGoodSrcSpan span -> listAround span True
2049 do resumes <- GHC.getResumeContext
2051 [] -> panic "No resumes"
2053 do let traceIt = case GHC.resumeHistory r of
2054 [] -> text "rerunning with :trace,"
2056 doWhat = traceIt <+> text ":back then :list"
2057 printForUser' (text "Unable to list source for" <+>
2059 $$ text "Try" <+> doWhat)
2060 listCmd str = list2 (words str)
2062 list2 :: [String] -> InputT GHCi ()
2063 list2 [arg] | all isDigit arg = do
2064 (toplevel, _) <- GHC.getContext
2066 [] -> outputStrLn "No module to list"
2067 (mod : _) -> listModuleLine mod (read arg)
2068 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2069 mod <- wantInterpretedModule arg1
2070 listModuleLine mod (read arg2)
2072 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2073 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2074 if GHC.isGoodSrcLoc loc
2076 tickArray <- ASSERT( isExternalName name )
2077 lift $ getTickArray (GHC.nameModule name)
2078 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2079 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2082 Nothing -> listAround (GHC.srcLocSpan loc) False
2083 Just (_,span) -> listAround span False
2085 noCanDo name $ text "can't find its location: " <>
2088 noCanDo n why = printForUser' $
2089 text "cannot list source code for " <> ppr n <> text ": " <> why
2091 outputStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2093 listModuleLine :: Module -> Int -> InputT GHCi ()
2094 listModuleLine modl line = do
2095 graph <- GHC.getModuleGraph
2096 let this = filter ((== modl) . GHC.ms_mod) graph
2098 [] -> panic "listModuleLine"
2100 let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
2101 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2102 listAround (GHC.srcLocSpan loc) False
2104 -- | list a section of a source file around a particular SrcSpan.
2105 -- If the highlight flag is True, also highlight the span using
2106 -- start_bold\/end_bold.
2108 -- GHC files are UTF-8, so we can implement this by:
2109 -- 1) read the file in as a BS and syntax highlight it as before
2110 -- 2) convert the BS to String using utf-string, and write it out.
2111 -- It would be better if we could convert directly between UTF-8 and the
2112 -- console encoding, of course.
2113 listAround :: MonadIO m => SrcSpan -> Bool -> InputT m ()
2114 listAround span do_highlight = do
2115 contents <- liftIO $ BS.readFile (unpackFS file)
2117 lines = BS.split '\n' contents
2118 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2119 drop (line1 - 1 - pad_before) $ lines
2120 fst_line = max 1 (line1 - pad_before)
2121 line_nos = [ fst_line .. ]
2123 highlighted | do_highlight = zipWith highlight line_nos these_lines
2124 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2126 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2127 prefixed = zipWith ($) highlighted bs_line_nos
2129 let output = BS.intercalate (BS.pack "\n") prefixed
2130 utf8Decoded <- liftIO $ BS.useAsCStringLen output
2131 $ \(p,n) -> utf8DecodeString (castPtr p) n
2132 outputStrLn utf8Decoded
2134 file = GHC.srcSpanFile span
2135 line1 = GHC.srcSpanStartLine span
2136 col1 = GHC.srcSpanStartCol span
2137 line2 = GHC.srcSpanEndLine span
2138 col2 = GHC.srcSpanEndCol span
2140 pad_before | line1 == 1 = 0
2144 highlight | do_bold = highlight_bold
2145 | otherwise = highlight_carets
2147 highlight_bold no line prefix
2148 | no == line1 && no == line2
2149 = let (a,r) = BS.splitAt col1 line
2150 (b,c) = BS.splitAt (col2-col1) r
2152 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2154 = let (a,b) = BS.splitAt col1 line in
2155 BS.concat [prefix, a, BS.pack start_bold, b]
2157 = let (a,b) = BS.splitAt col2 line in
2158 BS.concat [prefix, a, BS.pack end_bold, b]
2159 | otherwise = BS.concat [prefix, line]
2161 highlight_carets no line prefix
2162 | no == line1 && no == line2
2163 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2164 BS.replicate (col2-col1) '^']
2166 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2169 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2171 | otherwise = BS.concat [prefix, line]
2173 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2174 nl = BS.singleton '\n'
2176 -- --------------------------------------------------------------------------
2179 getTickArray :: Module -> GHCi TickArray
2180 getTickArray modl = do
2182 let arrmap = tickarrays st
2183 case lookupModuleEnv arrmap modl of
2184 Just arr -> return arr
2186 (_breakArray, ticks) <- getModBreak modl
2187 let arr = mkTickArray (assocs ticks)
2188 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2191 discardTickArrays :: GHCi ()
2192 discardTickArrays = do
2194 setGHCiState st{tickarrays = emptyModuleEnv}
2196 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2198 = accumArray (flip (:)) [] (1, max_line)
2199 [ (line, (nm,span)) | (nm,span) <- ticks,
2200 line <- srcSpanLines span ]
2202 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2203 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2204 GHC.srcSpanEndLine span ]
2206 lookupModule :: GHC.GhcMonad m => String -> m Module
2207 lookupModule modName
2208 = GHC.lookupModule (GHC.mkModuleName modName) Nothing
2210 -- don't reset the counter back to zero?
2211 discardActiveBreakPoints :: GHCi ()
2212 discardActiveBreakPoints = do
2214 mapM (turnOffBreak.snd) (breaks st)
2215 setGHCiState $ st { breaks = [] }
2217 deleteBreak :: Int -> GHCi ()
2218 deleteBreak identity = do
2220 let oldLocations = breaks st
2221 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2223 then printForUser (text "Breakpoint" <+> ppr identity <+>
2224 text "does not exist")
2226 mapM (turnOffBreak.snd) this
2227 setGHCiState $ st { breaks = rest }
2229 turnOffBreak :: BreakLocation -> GHCi Bool
2230 turnOffBreak loc = do
2231 (arr, _) <- getModBreak (breakModule loc)
2232 io $ setBreakFlag False arr (breakTick loc)
2234 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2235 getModBreak mod = do
2236 Just mod_info <- GHC.getModuleInfo mod
2237 let modBreaks = GHC.modInfoModBreaks mod_info
2238 let array = GHC.modBreaks_flags modBreaks
2239 let ticks = GHC.modBreaks_locs modBreaks
2240 return (array, ticks)
2242 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2243 setBreakFlag toggle array index
2244 | toggle = GHC.setBreakOn array index
2245 | otherwise = GHC.setBreakOff array index