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
42 -- Other random utilities
45 import BasicTypes hiding (isTopLevel)
46 import Panic hiding (showException)
52 import Maybes ( orElse, expectJust )
56 #ifndef mingw32_HOST_OS
57 import System.Posix hiding (getEnv)
59 import qualified System.Win32
62 import System.Console.Haskeline as Haskeline
63 import qualified System.Console.Haskeline.Encoding as Encoding
64 import Control.Monad.Trans
68 import Exception hiding (catch, block, unblock)
69 import qualified Exception
71 -- import Control.Concurrent
73 import System.FilePath
74 import qualified Data.ByteString.Char8 as BS
78 import System.Environment
79 import System.Exit ( exitWith, ExitCode(..) )
80 import System.Directory
82 import System.IO.Error as IO
85 import Control.Monad as Monad
88 import GHC.Exts ( unsafeCoerce# )
89 import GHC.IOBase ( IOErrorType(InvalidArgument) )
92 import Data.IORef ( IORef, readIORef, writeIORef )
94 -----------------------------------------------------------------------------
96 ghciWelcomeMsg :: String
97 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
98 ": http://www.haskell.org/ghc/ :? for help"
100 cmdName :: Command -> String
103 GLOBAL_VAR(macros_ref, [], [Command])
105 builtin_commands :: [Command]
107 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
108 ("?", keepGoing help, noCompletion),
109 ("add", keepGoingPaths addModule, completeFilename),
110 ("abandon", keepGoing abandonCmd, noCompletion),
111 ("break", keepGoing breakCmd, completeIdentifier),
112 ("back", keepGoing backCmd, noCompletion),
113 ("browse", keepGoing' (browseCmd False), completeModule),
114 ("browse!", keepGoing' (browseCmd True), completeModule),
115 ("cd", keepGoing' changeDirectory, completeFilename),
116 ("check", keepGoing' checkModule, completeHomeModule),
117 ("continue", keepGoing continueCmd, noCompletion),
118 ("cmd", keepGoing cmdCmd, completeExpression),
119 ("ctags", keepGoing createCTagsFileCmd, completeFilename),
120 ("def", keepGoing (defineMacro False), completeExpression),
121 ("def!", keepGoing (defineMacro True), completeExpression),
122 ("delete", keepGoing deleteCmd, noCompletion),
123 ("e", keepGoing editFile, completeFilename),
124 ("edit", keepGoing editFile, completeFilename),
125 ("etags", keepGoing createETagsFileCmd, completeFilename),
126 ("force", keepGoing forceCmd, completeExpression),
127 ("forward", keepGoing forwardCmd, noCompletion),
128 ("help", keepGoing help, noCompletion),
129 ("history", keepGoing historyCmd, noCompletion),
130 ("info", keepGoing' info, completeIdentifier),
131 ("kind", keepGoing' kindOfType, completeIdentifier),
132 ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),
133 ("list", keepGoing' listCmd, noCompletion),
134 ("module", keepGoing setContext, completeModule),
135 ("main", keepGoing runMain, completeFilename),
136 ("print", keepGoing printCmd, completeExpression),
137 ("quit", quit, noCompletion),
138 ("reload", keepGoing' reloadModule, noCompletion),
139 ("run", keepGoing runRun, completeFilename),
140 ("set", keepGoing setCmd, completeSetOptions),
141 ("show", keepGoing showCmd, completeShowOptions),
142 ("sprint", keepGoing sprintCmd, completeExpression),
143 ("step", keepGoing stepCmd, completeIdentifier),
144 ("steplocal", keepGoing stepLocalCmd, completeIdentifier),
145 ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),
146 ("type", keepGoing' typeOfExpr, completeExpression),
147 ("trace", keepGoing traceCmd, completeExpression),
148 ("undef", keepGoing undefineMacro, completeMacro),
149 ("unset", keepGoing unsetOptions, completeSetOptions)
153 -- We initialize readline (in the interactiveUI function) to use
154 -- word_break_chars as the default set of completion word break characters.
155 -- This can be overridden for a particular command (for example, filename
156 -- expansion shouldn't consider '/' to be a word break) by setting the third
157 -- entry in the Command tuple above.
159 -- NOTE: in order for us to override the default correctly, any custom entry
160 -- must be a SUBSET of word_break_chars.
161 word_break_chars :: String
162 word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
163 specials = "(),;[]`{}"
165 in spaces ++ specials ++ symbols
167 flagWordBreakChars :: String
168 flagWordBreakChars = " \t\n"
171 keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)
172 keepGoing a str = keepGoing' (lift . a) str
174 keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool
175 keepGoing' a str = a str >> return False
177 keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
179 = do case toArgs str of
180 Left err -> Encoding.encode err >>= liftIO . BS.hPutStrLn stderr
184 shortHelpText :: String
185 shortHelpText = "use :? for help.\n"
189 " Commands available from the prompt:\n" ++
191 " <statement> evaluate/run <statement>\n" ++
192 " : repeat last command\n" ++
193 " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
194 " :add [*]<module> ... add module(s) to the current target set\n" ++
195 " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
196 " (!: more details; *: all top-level names)\n" ++
197 " :cd <dir> change directory to <dir>\n" ++
198 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
199 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
200 " :def <cmd> <expr> define a command :<cmd>\n" ++
201 " :edit <file> edit file\n" ++
202 " :edit edit last module\n" ++
203 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
204 " :help, :? display this list of commands\n" ++
205 " :info [<name> ...] display information about the given names\n" ++
206 " :kind <type> show the kind of <type>\n" ++
207 " :load [*]<module> ... load module(s) and their dependents\n" ++
208 " :main [<arguments> ...] run the main function with the given arguments\n" ++
209 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
210 " :quit exit GHCi\n" ++
211 " :reload reload the current module set\n" ++
212 " :run function [<arguments> ...] run the function with the given arguments\n" ++
213 " :type <expr> show the type of <expr>\n" ++
214 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
215 " :!<command> run the shell command <command>\n" ++
217 " -- Commands for debugging:\n" ++
219 " :abandon at a breakpoint, abandon current computation\n" ++
220 " :back go back in the history (after :trace)\n" ++
221 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
222 " :break <name> set a breakpoint on the specified function\n" ++
223 " :continue resume after a breakpoint\n" ++
224 " :delete <number> delete the specified breakpoint\n" ++
225 " :delete * delete all breakpoints\n" ++
226 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
227 " :forward go forward in the history (after :back)\n" ++
228 " :history [<n>] after :trace, show the execution history\n" ++
229 " :list show the source code around current breakpoint\n" ++
230 " :list identifier show the source code for <identifier>\n" ++
231 " :list [<module>] <line> show the source code around line number <line>\n" ++
232 " :print [<name> ...] prints a value without forcing its computation\n" ++
233 " :sprint [<name> ...] simplifed version of :print\n" ++
234 " :step single-step after stopping at a breakpoint\n"++
235 " :step <expr> single-step into <expr>\n"++
236 " :steplocal single-step within the current top-level binding\n"++
237 " :stepmodule single-step restricted to the current module\n"++
238 " :trace trace after stopping at a breakpoint\n"++
239 " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++
242 " -- Commands for changing settings:\n" ++
244 " :set <option> ... set options\n" ++
245 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
246 " :set prog <progname> set the value returned by System.getProgName\n" ++
247 " :set prompt <prompt> set the prompt used in GHCi\n" ++
248 " :set editor <cmd> set the command used for :edit\n" ++
249 " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" ++
250 " :unset <option> ... unset options\n" ++
252 " Options for ':set' and ':unset':\n" ++
254 " +r revert top-level expressions after each evaluation\n" ++
255 " +s print timing/memory stats after each evaluation\n" ++
256 " +t print type after evaluation\n" ++
257 " -<flags> most GHC command line flags can also be set here\n" ++
258 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
259 " for GHCi-specific flags, see User's Guide,\n"++
260 " Flag reference, Interactive-mode options\n" ++
262 " -- Commands for displaying information:\n" ++
264 " :show bindings show the current bindings made at the prompt\n" ++
265 " :show breaks show the active breakpoints\n" ++
266 " :show context show the breakpoint context\n" ++
267 " :show modules show the currently loaded modules\n" ++
268 " :show packages show the currently active package flags\n" ++
269 " :show languages show the currently active language flags\n" ++
270 " :show <setting> show value of <setting>, which is one of\n" ++
271 " [args, prog, prompt, editor, stop]\n" ++
274 findEditor :: IO String
279 win <- System.Win32.getWindowsDirectory
280 return (win </> "notepad.exe")
285 interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String]
287 interactiveUI srcs maybe_exprs = do
288 -- HACK! If we happen to get into an infinite loop (eg the user
289 -- types 'let x=x in x' at the prompt), then the thread will block
290 -- on a blackhole, and become unreachable during GC. The GC will
291 -- detect that it is unreachable and send it the NonTermination
292 -- exception. However, since the thread is unreachable, everything
293 -- it refers to might be finalized, including the standard Handles.
294 -- This sounds like a bug, but we don't have a good solution right
296 liftIO $ newStablePtr stdin
297 liftIO $ newStablePtr stdout
298 liftIO $ newStablePtr stderr
300 -- Initialise buffering for the *interpreted* I/O system
303 liftIO $ when (isNothing maybe_exprs) $ do
304 -- Only for GHCi (not runghc and ghc -e):
306 -- Turn buffering off for the compiled program's stdout/stderr
308 -- Turn buffering off for GHCi's stdout
310 hSetBuffering stdout NoBuffering
311 -- We don't want the cmd line to buffer any input that might be
312 -- intended for the program, so unbuffer stdin.
313 hSetBuffering stdin NoBuffering
315 -- initial context is just the Prelude
316 prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing
317 GHC.setContext [] [prel_mod]
319 default_editor <- liftIO $ findEditor
321 startGHCi (runGHCi srcs maybe_exprs)
322 GHCiState{ progname = "<interactive>",
326 editor = default_editor,
327 -- session = session,
332 tickarrays = emptyModuleEnv,
333 last_command = Nothing,
336 ghc_e = isJust maybe_exprs
341 withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
342 withGhcAppData right left = do
343 either_dir <- IO.try (getAppUserDataDirectory "ghc")
345 Right dir -> right dir
348 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
349 runGHCi paths maybe_exprs = do
351 read_dot_files = not opt_IgnoreDotGhci
353 current_dir = return (Just ".ghci")
355 app_user_dir = io $ withGhcAppData
356 (\dir -> return (Just (dir </> "ghci.conf")))
360 either_dir <- io $ IO.try (getEnv "HOME")
362 Right home -> return (Just (home </> ".ghci"))
365 sourceConfigFile :: FilePath -> GHCi ()
366 sourceConfigFile file = do
367 exists <- io $ doesFileExist file
369 dir_ok <- io $ checkPerms (getDirectory file)
370 file_ok <- io $ checkPerms file
371 when (dir_ok && file_ok) $ do
372 either_hdl <- io $ IO.try (openFile file ReadMode)
375 -- NOTE: this assumes that runInputT won't affect the terminal;
376 -- can we assume this will always be the case?
377 -- This would be a good place for runFileInputT.
378 Right hdl -> runInputTWithPrefs defaultPrefs defaultSettings $ do
380 runCommands $ fileLoop hdl
382 getDirectory f = case takeDirectory f of "" -> "."; d -> d
384 when (read_dot_files) $ do
385 cfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
386 cfgs <- io $ mapM canonicalizePath (catMaybes cfgs0)
387 mapM_ sourceConfigFile (nub cfgs)
388 -- nub, because we don't want to read .ghci twice if the
391 -- Perform a :load for files given on the GHCi command line
392 -- When in -e mode, if the load fails then we want to stop
393 -- immediately rather than going on to evaluate the expression.
394 when (not (null paths)) $ do
395 ok <- ghciHandle (\e -> do showException e; return Failed) $
396 -- TODO: this is a hack.
397 runInputTWithPrefs defaultPrefs defaultSettings $ do
398 let (filePaths, phases) = unzip paths
399 filePaths' <- mapM (Encoding.decode . BS.pack) filePaths
400 loadModule (zip filePaths' phases)
401 when (isJust maybe_exprs && failed ok) $
402 io (exitWith (ExitFailure 1))
404 -- if verbosity is greater than 0, or we are connected to a
405 -- terminal, display the prompt in the interactive loop.
406 is_tty <- io (hIsTerminalDevice stdin)
407 dflags <- getDynFlags
408 let show_prompt = verbosity dflags > 0 || is_tty
413 -- enter the interactive loop
414 runGHCiInput $ runCommands $ haskelineLoop show_prompt
416 -- just evaluate the expression we were given
417 enqueueCommands exprs
418 let handle e = do st <- getGHCiState
419 -- Jump through some hoops to get the
420 -- current progname in the exception text:
421 -- <progname>: <exception>
422 io $ withProgName (progname st)
423 -- this used to be topHandlerFastExit, see #2228
425 runInputTWithPrefs defaultPrefs defaultSettings $ do
427 runCommands' handle (return Nothing)
430 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
432 runGHCiInput :: InputT GHCi a -> GHCi a
434 histFile <- io $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
436 let settings = setComplete ghciCompleteWord
437 $ defaultSettings {historyFile = histFile}
438 runInputT settings $ do
442 -- TODO really bad name
443 haskelineLoop :: Bool -> InputT GHCi (Maybe String)
444 haskelineLoop show_prompt = do
445 prompt <- if show_prompt then lift mkPrompt else return ""
446 l <- getInputLine prompt
450 -- NOTE: We only read .ghci files if they are owned by the current user,
451 -- and aren't world writable. Otherwise, we could be accidentally
452 -- running code planted by a malicious third party.
454 -- Furthermore, We only read ./.ghci if . is owned by the current user
455 -- and isn't writable by anyone else. I think this is sufficient: we
456 -- don't need to check .. and ../.. etc. because "." always refers to
457 -- the same directory while a process is running.
459 checkPerms :: String -> IO Bool
460 #ifdef mingw32_HOST_OS
465 handleIO (\_ -> return False) $ do
466 st <- getFileStatus name
468 if fileOwner st /= me then do
469 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
472 let mode = fileMode st
473 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
474 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
476 putStrLn $ "*** WARNING: " ++ name ++
477 " is writable by someone else, IGNORING!"
482 fileLoop :: MonadIO m => Handle -> InputT m (Maybe String)
484 l <- liftIO $ IO.try (BS.hGetLine hdl)
486 Left e | isEOFError e -> return Nothing
487 | InvalidArgument <- etype -> return Nothing
488 | otherwise -> liftIO $ ioError e
489 where etype = ioeGetErrorType e
490 -- treat InvalidArgument in the same way as EOF:
491 -- this can happen if the user closed stdin, or
492 -- perhaps did getContents which closes stdin at
494 Right l -> fmap Just (Encoding.decode l)
496 mkPrompt :: GHCi String
498 (toplevs,exports) <- GHC.getContext
499 resumes <- GHC.getResumeContext
500 -- st <- getGHCiState
506 let ix = GHC.resumeHistoryIx r
508 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
510 let hist = GHC.resumeHistory r !! (ix-1)
511 span <- GHC.getHistorySpan hist
512 return (brackets (ppr (negate ix) <> char ':'
513 <+> ppr span) <> space)
515 dots | _:rs <- resumes, not (null rs) = text "... "
522 -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
523 -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
524 -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
525 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
526 hsep (map (ppr . GHC.moduleName) exports)
528 deflt_prompt = dots <> context_bit <> modules_bit
530 f ('%':'s':xs) = deflt_prompt <> f xs
531 f ('%':'%':xs) = char '%' <> f xs
532 f (x:xs) = char x <> f xs
536 return (showSDoc (f (prompt st)))
539 queryQueue :: GHCi (Maybe String)
544 c:cs -> do setGHCiState st{ cmdqueue = cs }
547 runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
548 runCommands = runCommands' handler
550 runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
551 -> InputT GHCi (Maybe String) -> InputT GHCi ()
552 runCommands' eh getCmd = do
553 b <- handleGhcException (\e -> case e of
554 Interrupted -> return False
555 _other -> liftIO (print e) >> return True)
556 (runOneCommand eh getCmd)
557 if b then return () else runCommands' eh getCmd
559 runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
561 runOneCommand eh getCmd = do
562 mb_cmd <- noSpace (lift queryQueue)
563 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
565 Nothing -> return True
566 Just c -> ghciHandle (lift . eh) $
567 handleSourceError printErrorAndKeepGoing
570 printErrorAndKeepGoing err = do
571 GHC.printExceptionAndWarnings err
574 noSpace q = q >>= maybe (return Nothing)
575 (\c->case removeSpaces c of
577 ":{" -> multiLineCmd q
578 c -> return (Just c) )
580 st <- lift getGHCiState
582 lift $ setGHCiState st{ prompt = "%s| " }
583 mb_cmd <- collectCommand q ""
584 lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p }
586 -- we can't use removeSpaces for the sublines here, so
587 -- multiline commands are somewhat more brittle against
588 -- fileformat errors (such as \r in dos input on unix),
589 -- we get rid of any extra spaces for the ":}" test;
590 -- we also avoid silent failure if ":}" is not found;
591 -- and since there is no (?) valid occurrence of \r (as
592 -- opposed to its String representation, "\r") inside a
593 -- ghci command, we replace any such with ' ' (argh:-(
594 collectCommand q c = q >>=
595 maybe (liftIO (ioError collectError))
596 (\l->if removeSpaces l == ":}"
597 then return (Just $ removeSpaces c)
598 else collectCommand q (c++map normSpace l))
599 where normSpace '\r' = ' '
601 -- QUESTION: is userError the one to use here?
602 collectError = userError "unterminated multiline command :{ .. :}"
603 doCommand (':' : cmd) = specialCommand cmd
604 doCommand stmt = do timeIt $ lift $ runStmt stmt GHC.RunToCompletion
607 enqueueCommands :: [String] -> GHCi ()
608 enqueueCommands cmds = do
610 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
613 runStmt :: String -> SingleStep -> GHCi Bool
615 | null (filter (not.isSpace) stmt) = return False
616 | ["import", mod] <- words stmt = keepGoing' setContext ('+':mod)
618 = do result <- GhciMonad.runStmt stmt step
619 afterRunStmt (const True) result
621 --afterRunStmt :: GHC.RunResult -> GHCi Bool
622 -- False <=> the statement failed to compile
623 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
624 afterRunStmt _ (GHC.RunException e) = throw e
625 afterRunStmt step_here run_result = do
626 resumes <- GHC.getResumeContext
628 GHC.RunOk names -> do
629 show_types <- isOptionSet ShowType
630 when show_types $ printTypeOfNames names
631 GHC.RunBreak _ names mb_info
632 | isNothing mb_info ||
633 step_here (GHC.resumeSpan $ head resumes) -> do
634 mb_id_loc <- toBreakIdAndLocation mb_info
635 let breakCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
637 then printStoppedAtBreakInfo (head resumes) names
638 else enqueueCommands [breakCmd]
639 -- run the command set with ":set stop <cmd>"
641 enqueueCommands [stop st]
643 | otherwise -> resume step_here GHC.SingleStep >>=
644 afterRunStmt step_here >> return ()
648 io installSignalHandlers
649 b <- isOptionSet RevertCAFs
652 return (case run_result of GHC.RunOk _ -> True; _ -> False)
654 toBreakIdAndLocation ::
655 Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
656 toBreakIdAndLocation Nothing = return Nothing
657 toBreakIdAndLocation (Just info) = do
658 let mod = GHC.breakInfo_module info
659 nm = GHC.breakInfo_number info
661 return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
662 breakModule loc == mod,
663 breakTick loc == nm ]
665 printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
666 printStoppedAtBreakInfo resume names = do
667 printForUser $ ptext (sLit "Stopped at") <+>
668 ppr (GHC.resumeSpan resume)
669 -- printTypeOfNames session names
670 let namesSorted = sortBy compareNames names
671 tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
672 docs <- pprTypeAndContents [id | AnId id <- tythings]
673 printForUserPartWay docs
675 printTypeOfNames :: [Name] -> GHCi ()
676 printTypeOfNames names
677 = mapM_ (printTypeOfName ) $ sortBy compareNames names
679 compareNames :: Name -> Name -> Ordering
680 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
681 where compareWith n = (getOccString n, getSrcSpan n)
683 printTypeOfName :: Name -> GHCi ()
685 = do maybe_tything <- GHC.lookupName n
686 case maybe_tything of
688 Just thing -> printTyThing thing
691 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
693 specialCommand :: String -> InputT GHCi Bool
694 specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
695 specialCommand str = do
696 let (cmd,rest) = break isSpace str
697 maybe_cmd <- lift $ lookupCommand cmd
699 GotCommand (_,f,_) -> f (dropWhile isSpace rest)
701 do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
705 do liftIO $ hPutStr stdout ("there is no last command to perform\n"
709 lookupCommand :: String -> GHCi (MaybeCommand)
710 lookupCommand "" = do
712 case last_command st of
713 Just c -> return $ GotCommand c
714 Nothing -> return NoLastCommand
715 lookupCommand str = do
716 mc <- io $ lookupCommand' str
718 setGHCiState st{ last_command = mc }
720 Just c -> GotCommand c
721 Nothing -> BadCommand
723 lookupCommand' :: String -> IO (Maybe Command)
724 lookupCommand' str = do
725 macros <- readIORef macros_ref
726 let cmds = builtin_commands ++ macros
727 -- look for exact match first, then the first prefix match
728 return $ case [ c | c <- cmds, str == cmdName c ] of
730 [] -> case [ c | c@(s,_,_) <- cmds, str `isPrefixOf` s ] of
734 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
735 getCurrentBreakSpan = do
736 resumes <- GHC.getResumeContext
740 let ix = GHC.resumeHistoryIx r
742 then return (Just (GHC.resumeSpan r))
744 let hist = GHC.resumeHistory r !! (ix-1)
745 span <- GHC.getHistorySpan hist
748 getCurrentBreakModule :: GHCi (Maybe Module)
749 getCurrentBreakModule = do
750 resumes <- GHC.getResumeContext
754 let ix = GHC.resumeHistoryIx r
756 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
758 let hist = GHC.resumeHistory r !! (ix-1)
759 return $ Just $ GHC.getHistoryModule hist
761 -----------------------------------------------------------------------------
764 noArgs :: GHCi () -> String -> GHCi ()
766 noArgs _ _ = io $ putStrLn "This command takes no arguments"
768 help :: String -> GHCi ()
769 help _ = io (putStr helpText)
771 info :: String -> InputT GHCi ()
772 info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
773 info s = handleSourceError GHC.printExceptionAndWarnings $ do
774 { let names = words s
775 ; dflags <- getDynFlags
776 ; let pefas = dopt Opt_PrintExplicitForalls dflags
777 ; mapM_ (infoThing pefas) names }
779 infoThing pefas str = do
780 names <- GHC.parseName str
781 mb_stuffs <- mapM GHC.getInfo names
782 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
783 unqual <- GHC.getPrintUnqual
784 outputStrLn $ showSDocForUser unqual $
785 vcat (intersperse (text "") $
786 map (pprInfo pefas) filtered)
788 -- Filter out names whose parent is also there Good
789 -- example is '[]', which is both a type and data
790 -- constructor in the same type
791 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
792 filterOutChildren get_thing xs
793 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
795 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
797 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
798 pprInfo pefas (thing, fixity, insts)
799 = pprTyThingInContextLoc pefas thing
800 $$ show_fixity fixity
801 $$ vcat (map GHC.pprInstance insts)
804 | fix == GHC.defaultFixity = empty
805 | otherwise = ppr fix <+> ppr (GHC.getName thing)
807 runMain :: String -> GHCi ()
808 runMain s = case toArgs s of
809 Left err -> io (hPutStrLn stderr err)
811 do dflags <- getDynFlags
812 case mainFunIs dflags of
813 Nothing -> doWithArgs args "main"
814 Just f -> doWithArgs args f
816 runRun :: String -> GHCi ()
817 runRun s = case toCmdArgs s of
818 Left err -> io (hPutStrLn stderr err)
819 Right (cmd, args) -> doWithArgs args cmd
821 doWithArgs :: [String] -> String -> GHCi ()
822 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
823 show args ++ " (" ++ cmd ++ ")"]
825 addModule :: [FilePath] -> InputT GHCi ()
827 lift revertCAFs -- always revert CAFs on load/add.
828 files <- mapM expandPath files
829 targets <- mapM (\m -> GHC.guessTarget m Nothing) files
830 -- remove old targets with the same id; e.g. for :add *M
831 mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
832 mapM_ GHC.addTarget targets
833 prev_context <- GHC.getContext
834 ok <- trySuccess $ GHC.load LoadAllTargets
835 afterLoad ok False prev_context
837 changeDirectory :: String -> InputT GHCi ()
838 changeDirectory "" = do
839 -- :cd on its own changes to the user's home directory
840 either_dir <- liftIO $ IO.try getHomeDirectory
843 Right dir -> changeDirectory dir
844 changeDirectory dir = do
845 graph <- GHC.getModuleGraph
846 when (not (null graph)) $
847 outputStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
848 prev_context <- GHC.getContext
850 GHC.load LoadAllTargets
851 lift $ setContextAfterLoad prev_context False []
852 GHC.workingDirectoryChanged
853 dir <- expandPath dir
854 liftIO $ setCurrentDirectory dir
856 trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
858 handleSourceError (\e -> do GHC.printExceptionAndWarnings e
862 editFile :: String -> GHCi ()
864 do file <- if null str then chooseEditFile else return str
868 $ ghcError (CmdLineError "editor not set, use :set editor")
869 io $ system (cmd ++ ' ':file)
872 -- The user didn't specify a file so we pick one for them.
873 -- Our strategy is to pick the first module that failed to load,
874 -- or otherwise the first target.
876 -- XXX: Can we figure out what happened if the depndecy analysis fails
877 -- (e.g., because the porgrammeer mistyped the name of a module)?
878 -- XXX: Can we figure out the location of an error to pass to the editor?
879 -- XXX: if we could figure out the list of errors that occured during the
880 -- last load/reaload, then we could start the editor focused on the first
882 chooseEditFile :: GHCi String
884 do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
886 graph <- GHC.getModuleGraph
887 failed_graph <- filterM hasFailed graph
888 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
890 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
893 case pick (order failed_graph) of
894 Just file -> return file
896 do targets <- GHC.getTargets
897 case msum (map fromTarget targets) of
898 Just file -> return file
899 Nothing -> ghcError (CmdLineError "No files to edit.")
901 where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
902 fromTarget _ = Nothing -- when would we get a module target?
904 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
905 defineMacro overwrite s = do
906 let (macro_name, definition) = break isSpace s
907 macros <- io (readIORef macros_ref)
908 let defined = map cmdName macros
911 then io $ putStrLn "no macros defined"
912 else io $ putStr ("the following macros are defined:\n" ++
915 if (not overwrite && macro_name `elem` defined)
916 then ghcError (CmdLineError
917 ("macro '" ++ macro_name ++ "' is already defined"))
920 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
922 -- give the expression a type signature, so we can be sure we're getting
923 -- something of the right type.
924 let new_expr = '(' : definition ++ ") :: String -> IO String"
926 -- compile the expression
927 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
928 hv <- GHC.compileExpr new_expr
929 io (writeIORef macros_ref --
930 (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)]))
932 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
934 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
935 -- make sure we force any exceptions in the result, while we are still
936 -- inside the exception handler for commands:
937 seqList str (return ())
938 enqueueCommands (lines str)
941 undefineMacro :: String -> GHCi ()
942 undefineMacro str = mapM_ undef (words str)
943 where undef macro_name = do
944 cmds <- io (readIORef macros_ref)
945 if (macro_name `notElem` map cmdName cmds)
946 then ghcError (CmdLineError
947 ("macro '" ++ macro_name ++ "' is not defined"))
949 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
951 cmdCmd :: String -> GHCi ()
953 let expr = '(' : str ++ ") :: IO String"
954 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
955 hv <- GHC.compileExpr expr
956 cmds <- io $ (unsafeCoerce# hv :: IO String)
957 enqueueCommands (lines cmds)
960 loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
961 loadModule fs = timeIt (loadModule' fs)
963 loadModule_ :: [FilePath] -> InputT GHCi ()
964 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
966 loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
967 loadModule' files = do
968 prev_context <- GHC.getContext
972 lift discardActiveBreakPoints
974 GHC.load LoadAllTargets
976 let (filenames, phases) = unzip files
977 exp_filenames <- mapM expandPath filenames
978 let files' = zip exp_filenames phases
979 targets <- mapM (uncurry GHC.guessTarget) files'
981 -- NOTE: we used to do the dependency anal first, so that if it
982 -- fails we didn't throw away the current set of modules. This would
983 -- require some re-working of the GHC interface, so we'll leave it
984 -- as a ToDo for now.
986 GHC.setTargets targets
987 doLoad False prev_context LoadAllTargets
989 checkModule :: String -> InputT GHCi ()
991 let modl = GHC.mkModuleName m
992 prev_context <- GHC.getContext
993 ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do
994 r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
995 outputStrLn (showSDoc (
996 case GHC.moduleInfo r of
997 cm | Just scope <- GHC.modInfoTopLevelScope cm ->
999 (local,global) = ASSERT( all isExternalName scope )
1000 partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1002 (text "global names: " <+> ppr global) $$
1003 (text "local names: " <+> ppr local)
1006 afterLoad (successIf ok) False prev_context
1008 reloadModule :: String -> InputT GHCi ()
1010 prev_context <- GHC.getContext
1011 doLoad True prev_context $
1012 if null m then LoadAllTargets
1013 else LoadUpTo (GHC.mkModuleName m)
1016 doLoad :: Bool -> ([Module],[Module]) -> LoadHowMuch -> InputT GHCi SuccessFlag
1017 doLoad retain_context prev_context howmuch = do
1018 -- turn off breakpoints before we load: we can't turn them off later, because
1019 -- the ModBreaks will have gone away.
1020 lift discardActiveBreakPoints
1021 ok <- trySuccess $ GHC.load howmuch
1022 afterLoad ok retain_context prev_context
1025 afterLoad :: SuccessFlag -> Bool -> ([Module],[Module]) -> InputT GHCi ()
1026 afterLoad ok retain_context prev_context = do
1027 lift revertCAFs -- always revert CAFs on load.
1028 lift discardTickArrays
1029 loaded_mod_summaries <- getLoadedModules
1030 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1031 loaded_mod_names = map GHC.moduleName loaded_mods
1032 modulesLoadedMsg ok loaded_mod_names
1034 lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
1037 setContextAfterLoad :: ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi ()
1038 setContextAfterLoad prev keep_ctxt [] = do
1039 prel_mod <- getPrelude
1040 setContextKeepingPackageModules prev keep_ctxt ([], [prel_mod])
1041 setContextAfterLoad prev keep_ctxt ms = do
1042 -- load a target if one is available, otherwise load the topmost module.
1043 targets <- GHC.getTargets
1044 case [ m | Just m <- map (findTarget ms) targets ] of
1046 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1047 load_this (last graph')
1052 = case filter (`matches` t) ms of
1056 summary `matches` Target (TargetModule m) _ _
1057 = GHC.ms_mod_name summary == m
1058 summary `matches` Target (TargetFile f _) _ _
1059 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1063 load_this summary | m <- GHC.ms_mod summary = do
1064 b <- GHC.moduleIsInterpreted m
1065 if b then setContextKeepingPackageModules prev keep_ctxt ([m], [])
1067 prel_mod <- getPrelude
1068 setContextKeepingPackageModules prev keep_ctxt ([],[prel_mod,m])
1070 -- | Keep any package modules (except Prelude) when changing the context.
1071 setContextKeepingPackageModules
1072 :: ([Module],[Module]) -- previous context
1073 -> Bool -- re-execute :module commands
1074 -> ([Module],[Module]) -- new context
1076 setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do
1077 let (_,bs0) = prev_context
1078 prel_mod <- getPrelude
1079 let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1080 let bs1 = if null as then nub (prel_mod : bs) else bs
1081 GHC.setContext as (nub (bs1 ++ pkg_modules))
1085 mapM_ (playCtxtCmd False) (remembered_ctx st)
1088 setGHCiState st{ remembered_ctx = [] }
1090 isHomeModule :: Module -> Bool
1091 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1093 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi ()
1094 modulesLoadedMsg ok mods = do
1095 dflags <- getDynFlags
1096 when (verbosity dflags > 0) $ do
1098 | null mods = text "none."
1099 | otherwise = hsep (
1100 punctuate comma (map ppr mods)) <> text "."
1103 outputStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))
1105 outputStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas))
1108 typeOfExpr :: String -> InputT GHCi ()
1110 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1111 ty <- GHC.exprType str
1112 dflags <- getDynFlags
1113 let pefas = dopt Opt_PrintExplicitForalls dflags
1114 printForUser' $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]
1116 kindOfType :: String -> InputT GHCi ()
1118 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1119 ty <- GHC.typeKind str
1120 printForUser' $ text str <+> dcolon <+> ppr ty
1122 quit :: String -> InputT GHCi Bool
1123 quit _ = return True
1125 shellEscape :: String -> GHCi Bool
1126 shellEscape str = io (system str >> return False)
1128 -----------------------------------------------------------------------------
1129 -- Browsing a module's contents
1131 browseCmd :: Bool -> String -> InputT GHCi ()
1134 ['*':s] | looksLikeModuleName s -> do
1135 m <- lift $ wantInterpretedModule s
1136 browseModule bang m False
1137 [s] | looksLikeModuleName s -> do
1138 m <- lift $ lookupModule s
1139 browseModule bang m True
1141 (as,bs) <- GHC.getContext
1142 -- Guess which module the user wants to browse. Pick
1143 -- modules that are interpreted first. The most
1144 -- recently-added module occurs last, it seems.
1146 (as@(_:_), _) -> browseModule bang (last as) True
1147 ([], bs@(_:_)) -> browseModule bang (last bs) True
1148 ([], []) -> ghcError (CmdLineError ":browse: no current module")
1149 _ -> ghcError (CmdLineError "syntax: :browse <module>")
1151 -- without bang, show items in context of their parents and omit children
1152 -- with bang, show class methods and data constructors separately, and
1153 -- indicate import modules, to aid qualifying unqualified names
1154 -- with sorted, sort items alphabetically
1155 browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
1156 browseModule bang modl exports_only = do
1157 -- :browse! reports qualifiers wrt current context
1158 current_unqual <- GHC.getPrintUnqual
1159 -- Temporarily set the context to the module we're interested in,
1160 -- just so we can get an appropriate PrintUnqualified
1161 (as,bs) <- GHC.getContext
1162 prel_mod <- lift getPrelude
1163 if exports_only then GHC.setContext [] [prel_mod,modl]
1164 else GHC.setContext [modl] []
1165 target_unqual <- GHC.getPrintUnqual
1166 GHC.setContext as bs
1168 let unqual = if bang then current_unqual else target_unqual
1170 mb_mod_info <- GHC.getModuleInfo modl
1172 Nothing -> ghcError (CmdLineError ("unknown module: " ++
1173 GHC.moduleNameString (GHC.moduleName modl)))
1175 dflags <- getDynFlags
1177 | exports_only = GHC.modInfoExports mod_info
1178 | otherwise = GHC.modInfoTopLevelScope mod_info
1181 -- sort alphabetically name, but putting
1182 -- locally-defined identifiers first.
1183 -- We would like to improve this; see #1799.
1184 sorted_names = loc_sort local ++ occ_sort external
1186 (local,external) = ASSERT( all isExternalName names )
1187 partition ((==modl) . nameModule) names
1188 occ_sort = sortBy (compare `on` nameOccName)
1189 -- try to sort by src location. If the first name in
1190 -- our list has a good source location, then they all should.
1192 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1193 = sortBy (compare `on` nameSrcSpan) names
1197 mb_things <- mapM GHC.lookupName sorted_names
1198 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1200 rdr_env <- GHC.getGRE
1202 let pefas = dopt Opt_PrintExplicitForalls dflags
1203 things | bang = catMaybes mb_things
1204 | otherwise = filtered_things
1205 pretty | bang = pprTyThing
1206 | otherwise = pprTyThingInContext
1208 labels [] = text "-- not currently imported"
1209 labels l = text $ intercalate "\n" $ map qualifier l
1210 qualifier = maybe "-- defined locally"
1211 (("-- imported via "++) . intercalate ", "
1212 . map GHC.moduleNameString)
1213 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1214 modNames = map (importInfo . GHC.getName) things
1216 -- annotate groups of imports with their import modules
1217 -- the default ordering is somewhat arbitrary, so we group
1218 -- by header and sort groups; the names themselves should
1219 -- really come in order of source appearance.. (trac #1799)
1220 annotate mts = concatMap (\(m,ts)->labels m:ts)
1221 $ sortBy cmpQualifiers $ group mts
1222 where cmpQualifiers =
1223 compare `on` (map (fmap (map moduleNameFS)) . fst)
1225 group mts@((m,_):_) = (m,map snd g) : group ng
1226 where (g,ng) = partition ((==m).fst) mts
1228 let prettyThings = map (pretty pefas) things
1229 prettyThings' | bang = annotate $ zip modNames prettyThings
1230 | otherwise = prettyThings
1231 outputStrLn $ showSDocForUser unqual (vcat prettyThings')
1232 -- ToDo: modInfoInstances currently throws an exception for
1233 -- package modules. When it works, we can do this:
1234 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1236 -----------------------------------------------------------------------------
1237 -- Setting the module context
1239 setContext :: String -> GHCi ()
1241 | all sensible strs = do
1242 playCtxtCmd True (cmd, as, bs)
1244 setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] }
1245 | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1247 (cmd, strs, as, bs) =
1249 '+':stuff -> rest AddModules stuff
1250 '-':stuff -> rest RemModules stuff
1251 stuff -> rest SetContext stuff
1253 rest cmd stuff = (cmd, strs, as, bs)
1254 where strs = words stuff
1255 (as,bs) = partitionWith starred strs
1257 sensible ('*':m) = looksLikeModuleName m
1258 sensible m = looksLikeModuleName m
1260 starred ('*':m) = Left m
1263 playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi ()
1264 playCtxtCmd fail (cmd, as, bs)
1266 (as',bs') <- do_checks fail
1267 (prev_as,prev_bs) <- GHC.getContext
1271 prel_mod <- getPrelude
1272 let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs'
1276 let as_to_add = as' \\ (prev_as ++ prev_bs)
1277 bs_to_add = bs' \\ (prev_as ++ prev_bs)
1278 return (prev_as ++ as_to_add, prev_bs ++ bs_to_add)
1280 let new_as = prev_as \\ (as' ++ bs')
1281 new_bs = prev_bs \\ (as' ++ bs')
1282 return (new_as, new_bs)
1283 GHC.setContext new_as new_bs
1286 as' <- mapM wantInterpretedModule as
1287 bs' <- mapM lookupModule bs
1289 do_checks False = do
1290 as' <- mapM (trymaybe . wantInterpretedModule) as
1291 bs' <- mapM (trymaybe . lookupModule) bs
1292 return (catMaybes as', catMaybes bs')
1297 Left _ -> return Nothing
1298 Right a -> return (Just a)
1300 ----------------------------------------------------------------------------
1303 -- set options in the interpreter. Syntax is exactly the same as the
1304 -- ghc command line, except that certain options aren't available (-C,
1307 -- This is pretty fragile: most options won't work as expected. ToDo:
1308 -- figure out which ones & disallow them.
1310 setCmd :: String -> GHCi ()
1312 = do st <- getGHCiState
1313 let opts = options st
1314 io $ putStrLn (showSDoc (
1315 text "options currently set: " <>
1318 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1320 dflags <- getDynFlags
1321 io $ putStrLn (showSDoc (
1322 vcat (text "GHCi-specific dynamic flag settings:"
1323 :map (flagSetting dflags) ghciFlags)
1325 io $ putStrLn (showSDoc (
1326 vcat (text "other dynamic, non-language, flag settings:"
1327 :map (flagSetting dflags) nonLanguageDynFlags)
1329 where flagSetting dflags (str, f, _)
1330 | dopt f dflags = text " " <> text "-f" <> text str
1331 | otherwise = text " " <> text "-fno-" <> text str
1332 (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags)
1334 nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions)
1336 flags = [Opt_PrintExplicitForalls
1337 ,Opt_PrintBindResult
1338 ,Opt_BreakOnException
1340 ,Opt_PrintEvldWithShow
1343 = case getCmd str of
1344 Right ("args", rest) ->
1346 Left err -> io (hPutStrLn stderr err)
1347 Right args -> setArgs args
1348 Right ("prog", rest) ->
1350 Right [prog] -> setProg prog
1351 _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")
1352 Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1353 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1354 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1355 _ -> case toArgs str of
1356 Left err -> io (hPutStrLn stderr err)
1357 Right wds -> setOptions wds
1359 setArgs, setOptions :: [String] -> GHCi ()
1360 setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
1364 setGHCiState st{ args = args }
1368 setGHCiState st{ progname = prog }
1372 setGHCiState st{ editor = cmd }
1374 setStop str@(c:_) | isDigit c
1375 = do let (nm_str,rest) = break (not.isDigit) str
1378 let old_breaks = breaks st
1379 if all ((/= nm) . fst) old_breaks
1380 then printForUser (text "Breakpoint" <+> ppr nm <+>
1381 text "does not exist")
1383 let new_breaks = map fn old_breaks
1384 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1385 | otherwise = (i,loc)
1386 setGHCiState st{ breaks = new_breaks }
1389 setGHCiState st{ stop = cmd }
1391 setPrompt value = do
1394 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1396 '\"' : _ -> case reads value of
1397 [(value', xs)] | all isSpace xs ->
1398 setGHCiState (st { prompt = value' })
1400 io $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
1401 _ -> setGHCiState (st { prompt = value })
1404 do -- first, deal with the GHCi opts (+s, +t, etc.)
1405 let (plus_opts, minus_opts) = partitionWith isPlus wds
1406 mapM_ setOpt plus_opts
1407 -- then, dynamic flags
1408 newDynFlags minus_opts
1410 newDynFlags :: [String] -> GHCi ()
1411 newDynFlags minus_opts = do
1412 dflags <- getDynFlags
1413 let pkg_flags = packageFlags dflags
1414 (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
1415 handleFlagWarnings dflags' warns
1417 if (not (null leftovers))
1418 then ghcError $ errorsToGhcException leftovers
1421 new_pkgs <- setDynFlags dflags'
1423 -- if the package flags changed, we should reset the context
1424 -- and link the new packages.
1425 dflags <- getDynFlags
1426 when (packageFlags dflags /= pkg_flags) $ do
1427 io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
1429 GHC.load LoadAllTargets
1430 io (linkPackages dflags new_pkgs)
1431 -- package flags changed, we can't re-use any of the old context
1432 setContextAfterLoad ([],[]) False []
1436 unsetOptions :: String -> GHCi ()
1438 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1439 let opts = words str
1440 (minus_opts, rest1) = partition isMinus opts
1441 (plus_opts, rest2) = partitionWith isPlus rest1
1443 if (not (null rest2))
1444 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1447 mapM_ unsetOpt plus_opts
1449 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1450 no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
1452 no_flags <- mapM no_flag minus_opts
1453 newDynFlags no_flags
1455 isMinus :: String -> Bool
1456 isMinus ('-':_) = True
1459 isPlus :: String -> Either String String
1460 isPlus ('+':opt) = Left opt
1461 isPlus other = Right other
1463 setOpt, unsetOpt :: String -> GHCi ()
1466 = case strToGHCiOpt str of
1467 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1468 Just o -> setOption o
1471 = case strToGHCiOpt str of
1472 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1473 Just o -> unsetOption o
1475 strToGHCiOpt :: String -> (Maybe GHCiOption)
1476 strToGHCiOpt "s" = Just ShowTiming
1477 strToGHCiOpt "t" = Just ShowType
1478 strToGHCiOpt "r" = Just RevertCAFs
1479 strToGHCiOpt _ = Nothing
1481 optToStr :: GHCiOption -> String
1482 optToStr ShowTiming = "s"
1483 optToStr ShowType = "t"
1484 optToStr RevertCAFs = "r"
1486 -- ---------------------------------------------------------------------------
1489 showCmd :: String -> GHCi ()
1493 ["args"] -> io $ putStrLn (show (args st))
1494 ["prog"] -> io $ putStrLn (show (progname st))
1495 ["prompt"] -> io $ putStrLn (show (prompt st))
1496 ["editor"] -> io $ putStrLn (show (editor st))
1497 ["stop"] -> io $ putStrLn (show (stop st))
1498 ["modules" ] -> showModules
1499 ["bindings"] -> showBindings
1500 ["linker"] -> io showLinkerState
1501 ["breaks"] -> showBkptTable
1502 ["context"] -> showContext
1503 ["packages"] -> showPackages
1504 ["languages"] -> showLanguages
1505 _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
1506 " | breaks | context | packages | languages ]"))
1508 showModules :: GHCi ()
1510 loaded_mods <- getLoadedModules
1511 -- we want *loaded* modules only, see #1734
1512 let show_one ms = do m <- GHC.showModule ms; io (putStrLn m)
1513 mapM_ show_one loaded_mods
1515 getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
1516 getLoadedModules = do
1517 graph <- GHC.getModuleGraph
1518 filterM (GHC.isLoaded . GHC.ms_mod_name) graph
1520 showBindings :: GHCi ()
1522 bindings <- GHC.getBindings
1523 docs <- pprTypeAndContents
1524 [ id | AnId id <- sortBy compareTyThings bindings]
1525 printForUserPartWay docs
1527 compareTyThings :: TyThing -> TyThing -> Ordering
1528 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1530 printTyThing :: TyThing -> GHCi ()
1531 printTyThing tyth = do dflags <- getDynFlags
1532 let pefas = dopt Opt_PrintExplicitForalls dflags
1533 printForUser (pprTyThing pefas tyth)
1535 showBkptTable :: GHCi ()
1538 printForUser $ prettyLocations (breaks st)
1540 showContext :: GHCi ()
1542 resumes <- GHC.getResumeContext
1543 printForUser $ vcat (map pp_resume (reverse resumes))
1546 ptext (sLit "--> ") <> text (GHC.resumeStmt resume)
1547 $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume))
1549 showPackages :: GHCi ()
1551 pkg_flags <- fmap packageFlags getDynFlags
1552 io $ putStrLn $ showSDoc $ vcat $
1553 text ("active package flags:"++if null pkg_flags then " none" else "")
1554 : map showFlag pkg_flags
1555 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1556 io $ putStrLn $ showSDoc $ vcat $
1557 text "packages currently loaded:"
1558 : map (nest 2 . text . packageIdString)
1559 (sortBy (compare `on` packageIdFS) pkg_ids)
1560 where showFlag (ExposePackage p) = text $ " -package " ++ p
1561 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1562 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1564 showLanguages :: GHCi ()
1566 dflags <- getDynFlags
1567 io $ putStrLn $ showSDoc $ vcat $
1568 text "active language flags:" :
1569 [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags]
1571 -- -----------------------------------------------------------------------------
1574 completeCmd, completeMacro, completeIdentifier, completeModule,
1575 completeHomeModule, completeSetOptions, completeShowOptions,
1576 completeHomeModuleOrFile, completeExpression
1577 :: CompletionFunc GHCi
1579 ghciCompleteWord :: CompletionFunc GHCi
1580 ghciCompleteWord line@(left,_) = case firstWord of
1581 ':':cmd | null rest -> completeCmd line
1583 completion <- lookupCompletion cmd
1585 "import" -> completeModule line
1586 _ -> completeExpression line
1588 (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
1589 lookupCompletion ('!':_) = return completeFilename
1590 lookupCompletion c = do
1591 maybe_cmd <- liftIO $ lookupCommand' c
1593 Just (_,_,f) -> return f
1594 Nothing -> return completeFilename
1596 completeCmd = wrapCompleter " " $ \w -> do
1597 cmds <- liftIO $ readIORef macros_ref
1598 return (filter (w `isPrefixOf`) (map (':':)
1599 (map cmdName (builtin_commands ++ cmds))))
1601 completeMacro = wrapIdentCompleter $ \w -> do
1602 cmds <- liftIO $ readIORef macros_ref
1603 return (filter (w `isPrefixOf`) (map cmdName cmds))
1605 completeIdentifier = wrapIdentCompleter $ \w -> do
1606 rdrs <- GHC.getRdrNamesInScope
1607 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1609 completeModule = wrapIdentCompleter $ \w -> do
1610 dflags <- GHC.getSessionDynFlags
1611 let pkg_mods = allExposedModules dflags
1612 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
1613 return $ filter (w `isPrefixOf`)
1614 $ map (showSDoc.ppr) $ loaded_mods ++ pkg_mods
1616 completeHomeModule = wrapIdentCompleter listHomeModules
1618 listHomeModules :: String -> GHCi [String]
1619 listHomeModules w = do
1620 g <- GHC.getModuleGraph
1621 let home_mods = map GHC.ms_mod_name g
1622 return $ sort $ filter (w `isPrefixOf`)
1623 $ map (showSDoc.ppr) home_mods
1625 completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
1626 return (filter (w `isPrefixOf`) options)
1627 where options = "args":"prog":"prompt":"editor":"stop":flagList
1628 flagList = map head $ group $ sort allFlags
1630 completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
1631 return (filter (w `isPrefixOf`) options)
1632 where options = ["args", "prog", "prompt", "editor", "stop",
1633 "modules", "bindings", "linker", "breaks",
1634 "context", "packages", "languages"]
1636 completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
1637 $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
1640 unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
1641 unionComplete f1 f2 line = do
1646 wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
1647 wrapCompleter breakChars fun = completeWord Nothing breakChars
1648 $ fmap (map simpleCompletion) . fmap sort . fun
1650 wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
1651 wrapIdentCompleter = wrapCompleter word_break_chars
1653 allExposedModules :: DynFlags -> [ModuleName]
1654 allExposedModules dflags
1655 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1657 pkg_db = pkgIdMap (pkgState dflags)
1659 completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
1662 -- ---------------------------------------------------------------------------
1663 -- User code exception handling
1665 -- This is the exception handler for exceptions generated by the
1666 -- user's code and exceptions coming from children sessions;
1667 -- it normally just prints out the exception. The
1668 -- handler must be recursive, in case showing the exception causes
1669 -- more exceptions to be raised.
1671 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1672 -- raising another exception. We therefore don't put the recursive
1673 -- handler arond the flushing operation, so if stderr is closed
1674 -- GHCi will just die gracefully rather than going into an infinite loop.
1675 handler :: SomeException -> GHCi Bool
1677 handler exception = do
1679 io installSignalHandlers
1680 ghciHandle handler (showException exception >> return False)
1682 showException :: SomeException -> GHCi ()
1684 io $ case fromException se of
1685 Just Interrupted -> putStrLn "Interrupted."
1686 -- omit the location for CmdLineError:
1687 Just (CmdLineError s) -> putStrLn s
1689 Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
1690 Just other_ghc_ex -> print other_ghc_ex
1691 Nothing -> putStrLn ("*** Exception: " ++ show se)
1693 -----------------------------------------------------------------------------
1694 -- recursive exception handlers
1696 -- Don't forget to unblock async exceptions in the handler, or if we're
1697 -- in an exception loop (eg. let a = error a in a) the ^C exception
1698 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1700 ghciHandle :: MonadException m => (SomeException -> m a) -> m a -> m a
1701 ghciHandle h m = Haskeline.catch m $ \e -> unblock (h e)
1703 ghciTry :: GHCi a -> GHCi (Either SomeException a)
1704 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
1706 -- ----------------------------------------------------------------------------
1709 -- TODO: won't work if home dir is encoded.
1710 -- (changeDirectory may not work either in that case.)
1711 expandPath :: MonadIO m => String -> InputT m String
1712 expandPath path = do
1713 exp_path <- liftIO $ expandPathIO path
1714 enc <- fmap BS.unpack $ Encoding.encode exp_path
1717 expandPathIO :: String -> IO String
1719 case dropWhile isSpace path of
1721 tilde <- getHomeDirectory -- will fail if HOME not defined
1722 return (tilde ++ '/':d)
1726 wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
1727 wantInterpretedModule str = do
1728 modl <- lookupModule str
1729 dflags <- getDynFlags
1730 when (GHC.modulePackageId modl /= thisPackage dflags) $
1731 ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
1732 is_interpreted <- GHC.moduleIsInterpreted modl
1733 when (not is_interpreted) $
1734 ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
1737 wantNameFromInterpretedModule :: GHC.GhcMonad m
1738 => (Name -> SDoc -> m ())
1742 wantNameFromInterpretedModule noCanDo str and_then =
1743 handleSourceError (GHC.printExceptionAndWarnings) $ do
1744 names <- GHC.parseName str
1748 let modl = ASSERT( isExternalName n ) GHC.nameModule n
1749 if not (GHC.isExternalName n)
1750 then noCanDo n $ ppr n <>
1751 text " is not defined in an interpreted module"
1753 is_interpreted <- GHC.moduleIsInterpreted modl
1754 if not is_interpreted
1755 then noCanDo n $ text "module " <> ppr modl <>
1756 text " is not interpreted"
1759 -- -----------------------------------------------------------------------------
1760 -- commands for debugger
1762 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1763 sprintCmd = pprintCommand False False
1764 printCmd = pprintCommand True False
1765 forceCmd = pprintCommand False True
1767 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1768 pprintCommand bind force str = do
1769 pprintClosureCommand bind force str
1771 stepCmd :: String -> GHCi ()
1772 stepCmd [] = doContinue (const True) GHC.SingleStep
1773 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1775 stepLocalCmd :: String -> GHCi ()
1776 stepLocalCmd [] = do
1777 mb_span <- getCurrentBreakSpan
1779 Nothing -> stepCmd []
1781 Just mod <- getCurrentBreakModule
1782 current_toplevel_decl <- enclosingTickSpan mod loc
1783 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1785 stepLocalCmd expression = stepCmd expression
1787 stepModuleCmd :: String -> GHCi ()
1788 stepModuleCmd [] = do
1789 mb_span <- getCurrentBreakSpan
1791 Nothing -> stepCmd []
1793 Just span <- getCurrentBreakSpan
1794 let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span
1795 doContinue f GHC.SingleStep
1797 stepModuleCmd expression = stepCmd expression
1799 -- | Returns the span of the largest tick containing the srcspan given
1800 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1801 enclosingTickSpan mod src = do
1802 ticks <- getTickArray mod
1803 let line = srcSpanStartLine src
1804 ASSERT (inRange (bounds ticks) line) do
1805 let enclosing_spans = [ span | (_,span) <- ticks ! line
1806 , srcSpanEnd span >= srcSpanEnd src]
1807 return . head . sortBy leftmost_largest $ enclosing_spans
1809 traceCmd :: String -> GHCi ()
1810 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1811 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1813 continueCmd :: String -> GHCi ()
1814 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1816 -- doContinue :: SingleStep -> GHCi ()
1817 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1818 doContinue pred step = do
1819 runResult <- resume pred step
1820 afterRunStmt pred runResult
1823 abandonCmd :: String -> GHCi ()
1824 abandonCmd = noArgs $ do
1825 b <- GHC.abandon -- the prompt will change to indicate the new context
1826 when (not b) $ io $ putStrLn "There is no computation running."
1829 deleteCmd :: String -> GHCi ()
1830 deleteCmd argLine = do
1831 deleteSwitch $ words argLine
1833 deleteSwitch :: [String] -> GHCi ()
1835 io $ putStrLn "The delete command requires at least one argument."
1836 -- delete all break points
1837 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1838 deleteSwitch idents = do
1839 mapM_ deleteOneBreak idents
1841 deleteOneBreak :: String -> GHCi ()
1843 | all isDigit str = deleteBreak (read str)
1844 | otherwise = return ()
1846 historyCmd :: String -> GHCi ()
1848 | null arg = history 20
1849 | all isDigit arg = history (read arg)
1850 | otherwise = io $ putStrLn "Syntax: :history [num]"
1853 resumes <- GHC.getResumeContext
1855 [] -> io $ putStrLn "Not stopped at a breakpoint"
1857 let hist = GHC.resumeHistory r
1858 (took,rest) = splitAt num hist
1860 [] -> io $ putStrLn $
1861 "Empty history. Perhaps you forgot to use :trace?"
1863 spans <- mapM GHC.getHistorySpan took
1864 let nums = map (printf "-%-3d:") [(1::Int)..]
1865 names = map GHC.historyEnclosingDecl took
1866 printForUser (vcat(zipWith3
1867 (\x y z -> x <+> y <+> z)
1869 (map (bold . ppr) names)
1870 (map (parens . ppr) spans)))
1871 io $ putStrLn $ if null rest then "<end of history>" else "..."
1873 bold :: SDoc -> SDoc
1874 bold c | do_bold = text start_bold <> c <> text end_bold
1877 backCmd :: String -> GHCi ()
1878 backCmd = noArgs $ do
1879 (names, _, span) <- GHC.back
1880 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span
1881 printTypeOfNames names
1882 -- run the command set with ":set stop <cmd>"
1884 enqueueCommands [stop st]
1886 forwardCmd :: String -> GHCi ()
1887 forwardCmd = noArgs $ do
1888 (names, ix, span) <- GHC.forward
1889 printForUser $ (if (ix == 0)
1890 then ptext (sLit "Stopped at")
1891 else ptext (sLit "Logged breakpoint at")) <+> ppr span
1892 printTypeOfNames names
1893 -- run the command set with ":set stop <cmd>"
1895 enqueueCommands [stop st]
1897 -- handle the "break" command
1898 breakCmd :: String -> GHCi ()
1899 breakCmd argLine = do
1900 breakSwitch $ words argLine
1902 breakSwitch :: [String] -> GHCi ()
1904 io $ putStrLn "The break command requires at least one argument."
1905 breakSwitch (arg1:rest)
1906 | looksLikeModuleName arg1 && not (null rest) = do
1907 mod <- wantInterpretedModule arg1
1908 breakByModule mod rest
1909 | all isDigit arg1 = do
1910 (toplevel, _) <- GHC.getContext
1912 (mod : _) -> breakByModuleLine mod (read arg1) rest
1914 io $ putStrLn "Cannot find default module for breakpoint."
1915 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1916 | otherwise = do -- try parsing it as an identifier
1917 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1918 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1919 if GHC.isGoodSrcLoc loc
1920 then ASSERT( isExternalName name )
1921 findBreakAndSet (GHC.nameModule name) $
1922 findBreakByCoord (Just (GHC.srcLocFile loc))
1923 (GHC.srcLocLine loc,
1925 else noCanDo name $ text "can't find its location: " <> ppr loc
1927 noCanDo n why = printForUser $
1928 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1930 breakByModule :: Module -> [String] -> GHCi ()
1931 breakByModule mod (arg1:rest)
1932 | all isDigit arg1 = do -- looks like a line number
1933 breakByModuleLine mod (read arg1) rest
1937 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1938 breakByModuleLine mod line args
1939 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1940 | [col] <- args, all isDigit col =
1941 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1942 | otherwise = breakSyntax
1945 breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1947 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1948 findBreakAndSet mod lookupTickTree = do
1949 tickArray <- getTickArray mod
1950 (breakArray, _) <- getModBreak mod
1951 case lookupTickTree tickArray of
1952 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1953 Just (tick, span) -> do
1954 success <- io $ setBreakFlag True breakArray tick
1958 recordBreak $ BreakLocation
1965 text "Breakpoint " <> ppr nm <>
1967 then text " was already set at " <> ppr span
1968 else text " activated at " <> ppr span
1970 printForUser $ text "Breakpoint could not be activated at"
1973 -- When a line number is specified, the current policy for choosing
1974 -- the best breakpoint is this:
1975 -- - the leftmost complete subexpression on the specified line, or
1976 -- - the leftmost subexpression starting on the specified line, or
1977 -- - the rightmost subexpression enclosing the specified line
1979 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1980 findBreakByLine line arr
1981 | not (inRange (bounds arr) line) = Nothing
1983 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
1984 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
1985 listToMaybe (sortBy (rightmost `on` snd) ticks)
1989 starts_here = [ tick | tick@(_,span) <- ticks,
1990 GHC.srcSpanStartLine span == line ]
1992 (complete,incomplete) = partition ends_here starts_here
1993 where ends_here (_,span) = GHC.srcSpanEndLine span == line
1995 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1996 -> Maybe (BreakIndex,SrcSpan)
1997 findBreakByCoord mb_file (line, col) arr
1998 | not (inRange (bounds arr) line) = Nothing
2000 listToMaybe (sortBy (rightmost `on` snd) contains ++
2001 sortBy (leftmost_smallest `on` snd) after_here)
2005 -- the ticks that span this coordinate
2006 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2007 is_correct_file span ]
2009 is_correct_file span
2010 | Just f <- mb_file = GHC.srcSpanFile span == f
2013 after_here = [ tick | tick@(_,span) <- ticks,
2014 GHC.srcSpanStartLine span == line,
2015 GHC.srcSpanStartCol span >= col ]
2017 -- For now, use ANSI bold on terminals that we know support it.
2018 -- Otherwise, we add a line of carets under the active expression instead.
2019 -- In particular, on Windows and when running the testsuite (which sets
2020 -- TERM to vt100 for other reasons) we get carets.
2021 -- We really ought to use a proper termcap/terminfo library.
2023 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2024 where mTerm = System.Environment.getEnv "TERM"
2025 `catchIO` \_ -> return "TERM not set"
2027 start_bold :: String
2028 start_bold = "\ESC[1m"
2030 end_bold = "\ESC[0m"
2032 listCmd :: String -> InputT GHCi ()
2034 mb_span <- lift getCurrentBreakSpan
2037 printForUser' $ text "Not stopped at a breakpoint; nothing to list"
2039 | GHC.isGoodSrcSpan span -> listAround span True
2041 do resumes <- GHC.getResumeContext
2043 [] -> panic "No resumes"
2045 do let traceIt = case GHC.resumeHistory r of
2046 [] -> text "rerunning with :trace,"
2048 doWhat = traceIt <+> text ":back then :list"
2049 printForUser' (text "Unable to list source for" <+>
2051 $$ text "Try" <+> doWhat)
2052 listCmd str = list2 (words str)
2054 list2 :: [String] -> InputT GHCi ()
2055 list2 [arg] | all isDigit arg = do
2056 (toplevel, _) <- GHC.getContext
2058 [] -> outputStrLn "No module to list"
2059 (mod : _) -> listModuleLine mod (read arg)
2060 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2061 mod <- wantInterpretedModule arg1
2062 listModuleLine mod (read arg2)
2064 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2065 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2066 if GHC.isGoodSrcLoc loc
2068 tickArray <- ASSERT( isExternalName name )
2069 lift $ getTickArray (GHC.nameModule name)
2070 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2071 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2074 Nothing -> listAround (GHC.srcLocSpan loc) False
2075 Just (_,span) -> listAround span False
2077 noCanDo name $ text "can't find its location: " <>
2080 noCanDo n why = printForUser' $
2081 text "cannot list source code for " <> ppr n <> text ": " <> why
2083 outputStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2085 listModuleLine :: Module -> Int -> InputT GHCi ()
2086 listModuleLine modl line = do
2087 graph <- GHC.getModuleGraph
2088 let this = filter ((== modl) . GHC.ms_mod) graph
2090 [] -> panic "listModuleLine"
2092 let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
2093 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2094 listAround (GHC.srcLocSpan loc) False
2096 -- | list a section of a source file around a particular SrcSpan.
2097 -- If the highlight flag is True, also highlight the span using
2098 -- start_bold\/end_bold.
2100 -- GHC files are UTF-8, so we can implement this by:
2101 -- 1) read the file in as a BS and syntax highlight it as before
2102 -- 2) convert the BS to String using utf-string, and write it out.
2103 -- It would be better if we could convert directly between UTF-8 and the
2104 -- console encoding, of course.
2105 listAround :: MonadIO m => SrcSpan -> Bool -> InputT m ()
2106 listAround span do_highlight = do
2107 contents <- liftIO $ BS.readFile (unpackFS file)
2109 lines = BS.split '\n' contents
2110 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2111 drop (line1 - 1 - pad_before) $ lines
2112 fst_line = max 1 (line1 - pad_before)
2113 line_nos = [ fst_line .. ]
2115 highlighted | do_highlight = zipWith highlight line_nos these_lines
2116 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2118 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2119 prefixed = zipWith ($) highlighted bs_line_nos
2121 let output = BS.intercalate (BS.pack "\n") prefixed
2122 utf8Decoded <- liftIO $ BS.useAsCStringLen output
2123 $ \(p,n) -> utf8DecodeString (castPtr p) n
2124 outputStrLn utf8Decoded
2126 file = GHC.srcSpanFile span
2127 line1 = GHC.srcSpanStartLine span
2128 col1 = GHC.srcSpanStartCol span
2129 line2 = GHC.srcSpanEndLine span
2130 col2 = GHC.srcSpanEndCol span
2132 pad_before | line1 == 1 = 0
2136 highlight | do_bold = highlight_bold
2137 | otherwise = highlight_carets
2139 highlight_bold no line prefix
2140 | no == line1 && no == line2
2141 = let (a,r) = BS.splitAt col1 line
2142 (b,c) = BS.splitAt (col2-col1) r
2144 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2146 = let (a,b) = BS.splitAt col1 line in
2147 BS.concat [prefix, a, BS.pack start_bold, b]
2149 = let (a,b) = BS.splitAt col2 line in
2150 BS.concat [prefix, a, BS.pack end_bold, b]
2151 | otherwise = BS.concat [prefix, line]
2153 highlight_carets no line prefix
2154 | no == line1 && no == line2
2155 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2156 BS.replicate (col2-col1) '^']
2158 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2161 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2163 | otherwise = BS.concat [prefix, line]
2165 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2166 nl = BS.singleton '\n'
2168 -- --------------------------------------------------------------------------
2171 getTickArray :: Module -> GHCi TickArray
2172 getTickArray modl = do
2174 let arrmap = tickarrays st
2175 case lookupModuleEnv arrmap modl of
2176 Just arr -> return arr
2178 (_breakArray, ticks) <- getModBreak modl
2179 let arr = mkTickArray (assocs ticks)
2180 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2183 discardTickArrays :: GHCi ()
2184 discardTickArrays = do
2186 setGHCiState st{tickarrays = emptyModuleEnv}
2188 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2190 = accumArray (flip (:)) [] (1, max_line)
2191 [ (line, (nm,span)) | (nm,span) <- ticks,
2192 line <- srcSpanLines span ]
2194 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2195 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2196 GHC.srcSpanEndLine span ]
2198 lookupModule :: GHC.GhcMonad m => String -> m Module
2199 lookupModule modName
2200 = GHC.lookupModule (GHC.mkModuleName modName) Nothing
2202 -- don't reset the counter back to zero?
2203 discardActiveBreakPoints :: GHCi ()
2204 discardActiveBreakPoints = do
2206 mapM (turnOffBreak.snd) (breaks st)
2207 setGHCiState $ st { breaks = [] }
2209 deleteBreak :: Int -> GHCi ()
2210 deleteBreak identity = do
2212 let oldLocations = breaks st
2213 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2215 then printForUser (text "Breakpoint" <+> ppr identity <+>
2216 text "does not exist")
2218 mapM (turnOffBreak.snd) this
2219 setGHCiState $ st { breaks = rest }
2221 turnOffBreak :: BreakLocation -> GHCi Bool
2222 turnOffBreak loc = do
2223 (arr, _) <- getModBreak (breakModule loc)
2224 io $ setBreakFlag False arr (breakTick loc)
2226 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2227 getModBreak mod = do
2228 Just mod_info <- GHC.getModuleInfo mod
2229 let modBreaks = GHC.modInfoModBreaks mod_info
2230 let array = GHC.modBreaks_flags modBreaks
2231 let ticks = GHC.modBreaks_locs modBreaks
2232 return (array, ticks)
2234 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2235 setBreakFlag toggle array index
2236 | toggle = GHC.setBreakOn array index
2237 | otherwise = GHC.setBreakOff array index