1 {-# OPTIONS -fno-cse #-}
2 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
4 {-# OPTIONS -#include "Linker.h" #-}
5 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
6 -----------------------------------------------------------------------------
8 -- GHC Interactive User Interface
10 -- (c) The GHC Team 2005-2006
12 -----------------------------------------------------------------------------
14 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
16 #include "HsVersions.h"
18 import qualified GhciMonad
19 import GhciMonad hiding (runStmt)
24 import qualified GHC hiding (resume, runStmt)
25 import GHC ( LoadHowMuch(..), Target(..), TargetId(..),
26 Module, ModuleName, TyThing(..), Phase,
27 BreakIndex, SrcSpan, Resume, SingleStep,
28 Ghc, handleSourceError )
36 import HscTypes ( implicitTyThings, handleFlagWarnings )
37 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
38 import Outputable hiding (printForUser, printForUserPartWay)
39 import Module -- for ModuleEnv
44 -- Other random utilities
47 import BasicTypes hiding (isTopLevel)
48 import Panic hiding (showException)
54 import Maybes ( orElse, expectJust )
58 #ifndef mingw32_HOST_OS
59 import System.Posix hiding (getEnv)
61 import qualified System.Win32
64 import System.Console.Haskeline as Haskeline
65 import qualified System.Console.Haskeline.Encoding as Encoding
66 import Control.Monad.Trans
70 import Exception hiding (catch, block, unblock)
71 import qualified Exception
73 -- import Control.Concurrent
75 import System.FilePath
76 import qualified Data.ByteString.Char8 as BS
80 import System.Environment
81 import System.Exit ( exitWith, ExitCode(..) )
82 import System.Directory
84 import System.IO.Error as IO
87 import Control.Monad as Monad
90 import GHC.Exts ( unsafeCoerce# )
91 import GHC.IOBase ( IOErrorType(InvalidArgument) )
94 import Data.IORef ( IORef, readIORef, writeIORef )
96 -----------------------------------------------------------------------------
98 ghciWelcomeMsg :: String
99 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
100 ": http://www.haskell.org/ghc/ :? for help"
102 cmdName :: Command -> String
105 GLOBAL_VAR(macros_ref, [], [Command])
107 builtin_commands :: [Command]
109 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
110 ("?", keepGoing help, noCompletion),
111 ("add", keepGoingPaths addModule, completeFilename),
112 ("abandon", keepGoing abandonCmd, noCompletion),
113 ("break", keepGoing breakCmd, completeIdentifier),
114 ("back", keepGoing backCmd, noCompletion),
115 ("browse", keepGoing' (browseCmd False), completeModule),
116 ("browse!", keepGoing' (browseCmd True), completeModule),
117 ("cd", keepGoing' changeDirectory, completeFilename),
118 ("check", keepGoing' checkModule, completeHomeModule),
119 ("continue", keepGoing continueCmd, noCompletion),
120 ("cmd", keepGoing cmdCmd, completeExpression),
121 ("ctags", keepGoing createCTagsFileCmd, completeFilename),
122 ("def", keepGoing (defineMacro False), completeExpression),
123 ("def!", keepGoing (defineMacro True), completeExpression),
124 ("delete", keepGoing deleteCmd, noCompletion),
125 ("e", keepGoing editFile, completeFilename),
126 ("edit", keepGoing editFile, completeFilename),
127 ("etags", keepGoing createETagsFileCmd, completeFilename),
128 ("force", keepGoing forceCmd, completeExpression),
129 ("forward", keepGoing forwardCmd, noCompletion),
130 ("help", keepGoing help, noCompletion),
131 ("history", keepGoing historyCmd, noCompletion),
132 ("info", keepGoing' info, completeIdentifier),
133 ("kind", keepGoing' kindOfType, completeIdentifier),
134 ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),
135 ("list", keepGoing' listCmd, noCompletion),
136 ("module", keepGoing setContext, completeModule),
137 ("main", keepGoing runMain, completeFilename),
138 ("print", keepGoing printCmd, completeExpression),
139 ("quit", quit, noCompletion),
140 ("reload", keepGoing' reloadModule, noCompletion),
141 ("run", keepGoing runRun, completeFilename),
142 ("set", keepGoing setCmd, completeSetOptions),
143 ("show", keepGoing showCmd, completeShowOptions),
144 ("sprint", keepGoing sprintCmd, completeExpression),
145 ("step", keepGoing stepCmd, completeIdentifier),
146 ("steplocal", keepGoing stepLocalCmd, completeIdentifier),
147 ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),
148 ("type", keepGoing' typeOfExpr, completeExpression),
149 ("trace", keepGoing traceCmd, completeExpression),
150 ("undef", keepGoing undefineMacro, completeMacro),
151 ("unset", keepGoing unsetOptions, completeSetOptions)
155 -- We initialize readline (in the interactiveUI function) to use
156 -- word_break_chars as the default set of completion word break characters.
157 -- This can be overridden for a particular command (for example, filename
158 -- expansion shouldn't consider '/' to be a word break) by setting the third
159 -- entry in the Command tuple above.
161 -- NOTE: in order for us to override the default correctly, any custom entry
162 -- must be a SUBSET of word_break_chars.
163 word_break_chars :: String
164 word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
165 specials = "(),;[]`{}"
167 in spaces ++ specials ++ symbols
169 flagWordBreakChars :: String
170 flagWordBreakChars = " \t\n"
173 keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)
174 keepGoing a str = keepGoing' (lift . a) str
176 keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool
177 keepGoing' a str = a str >> return False
179 keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
181 = do case toArgs str of
182 Left err -> Encoding.encode err >>= liftIO . BS.hPutStrLn stderr
186 shortHelpText :: String
187 shortHelpText = "use :? for help.\n"
191 " Commands available from the prompt:\n" ++
193 " <statement> evaluate/run <statement>\n" ++
194 " : repeat last command\n" ++
195 " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
196 " :add [*]<module> ... add module(s) to the current target set\n" ++
197 " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
198 " (!: more details; *: all top-level names)\n" ++
199 " :cd <dir> change directory to <dir>\n" ++
200 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
201 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
202 " :def <cmd> <expr> define a command :<cmd>\n" ++
203 " :edit <file> edit file\n" ++
204 " :edit edit last module\n" ++
205 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
206 " :help, :? display this list of commands\n" ++
207 " :info [<name> ...] display information about the given names\n" ++
208 " :kind <type> show the kind of <type>\n" ++
209 " :load [*]<module> ... load module(s) and their dependents\n" ++
210 " :main [<arguments> ...] run the main function with the given arguments\n" ++
211 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
212 " :quit exit GHCi\n" ++
213 " :reload reload the current module set\n" ++
214 " :run function [<arguments> ...] run the function with the given arguments\n" ++
215 " :type <expr> show the type of <expr>\n" ++
216 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
217 " :!<command> run the shell command <command>\n" ++
219 " -- Commands for debugging:\n" ++
221 " :abandon at a breakpoint, abandon current computation\n" ++
222 " :back go back in the history (after :trace)\n" ++
223 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
224 " :break <name> set a breakpoint on the specified function\n" ++
225 " :continue resume after a breakpoint\n" ++
226 " :delete <number> delete the specified breakpoint\n" ++
227 " :delete * delete all breakpoints\n" ++
228 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
229 " :forward go forward in the history (after :back)\n" ++
230 " :history [<n>] after :trace, show the execution history\n" ++
231 " :list show the source code around current breakpoint\n" ++
232 " :list identifier show the source code for <identifier>\n" ++
233 " :list [<module>] <line> show the source code around line number <line>\n" ++
234 " :print [<name> ...] prints a value without forcing its computation\n" ++
235 " :sprint [<name> ...] simplifed version of :print\n" ++
236 " :step single-step after stopping at a breakpoint\n"++
237 " :step <expr> single-step into <expr>\n"++
238 " :steplocal single-step within the current top-level binding\n"++
239 " :stepmodule single-step restricted to the current module\n"++
240 " :trace trace after stopping at a breakpoint\n"++
241 " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++
244 " -- Commands for changing settings:\n" ++
246 " :set <option> ... set options\n" ++
247 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
248 " :set prog <progname> set the value returned by System.getProgName\n" ++
249 " :set prompt <prompt> set the prompt used in GHCi\n" ++
250 " :set editor <cmd> set the command used for :edit\n" ++
251 " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" ++
252 " :unset <option> ... unset options\n" ++
254 " Options for ':set' and ':unset':\n" ++
256 " +r revert top-level expressions after each evaluation\n" ++
257 " +s print timing/memory stats after each evaluation\n" ++
258 " +t print type after evaluation\n" ++
259 " -<flags> most GHC command line flags can also be set here\n" ++
260 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
261 " for GHCi-specific flags, see User's Guide,\n"++
262 " Flag reference, Interactive-mode options\n" ++
264 " -- Commands for displaying information:\n" ++
266 " :show bindings show the current bindings made at the prompt\n" ++
267 " :show breaks show the active breakpoints\n" ++
268 " :show context show the breakpoint context\n" ++
269 " :show modules show the currently loaded modules\n" ++
270 " :show packages show the currently active package flags\n" ++
271 " :show languages show the currently active language flags\n" ++
272 " :show <setting> show value of <setting>, which is one of\n" ++
273 " [args, prog, prompt, editor, stop]\n" ++
276 findEditor :: IO String
281 win <- System.Win32.getWindowsDirectory
282 return (win </> "notepad.exe")
287 interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String]
289 interactiveUI srcs maybe_exprs = do
290 -- although GHCi compiles with -prof, it is not usable: the byte-code
291 -- compiler and interpreter don't work with profiling. So we check for
292 -- this up front and emit a helpful error message (#2197)
293 m <- liftIO $ lookupSymbol "PushCostCentre"
295 ghcError (InstallationError "GHCi cannot be used when compiled with -prof")
297 -- HACK! If we happen to get into an infinite loop (eg the user
298 -- types 'let x=x in x' at the prompt), then the thread will block
299 -- on a blackhole, and become unreachable during GC. The GC will
300 -- detect that it is unreachable and send it the NonTermination
301 -- exception. However, since the thread is unreachable, everything
302 -- it refers to might be finalized, including the standard Handles.
303 -- This sounds like a bug, but we don't have a good solution right
305 liftIO $ newStablePtr stdin
306 liftIO $ newStablePtr stdout
307 liftIO $ newStablePtr stderr
309 -- Initialise buffering for the *interpreted* I/O system
312 liftIO $ when (isNothing maybe_exprs) $ do
313 -- Only for GHCi (not runghc and ghc -e):
315 -- Turn buffering off for the compiled program's stdout/stderr
317 -- Turn buffering off for GHCi's stdout
319 hSetBuffering stdout NoBuffering
320 -- We don't want the cmd line to buffer any input that might be
321 -- intended for the program, so unbuffer stdin.
322 hSetBuffering stdin NoBuffering
324 -- initial context is just the Prelude
325 prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing
326 GHC.setContext [] [prel_mod]
328 default_editor <- liftIO $ findEditor
330 startGHCi (runGHCi srcs maybe_exprs)
331 GHCiState{ progname = "<interactive>",
335 editor = default_editor,
336 -- session = session,
341 tickarrays = emptyModuleEnv,
342 last_command = Nothing,
345 ghc_e = isJust maybe_exprs
350 withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
351 withGhcAppData right left = do
352 either_dir <- IO.try (getAppUserDataDirectory "ghc")
354 Right dir -> right dir
357 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
358 runGHCi paths maybe_exprs = do
360 read_dot_files = not opt_IgnoreDotGhci
362 current_dir = return (Just ".ghci")
364 app_user_dir = io $ withGhcAppData
365 (\dir -> return (Just (dir </> "ghci.conf")))
369 either_dir <- io $ IO.try (getEnv "HOME")
371 Right home -> return (Just (home </> ".ghci"))
374 sourceConfigFile :: FilePath -> GHCi ()
375 sourceConfigFile file = do
376 exists <- io $ doesFileExist file
378 dir_ok <- io $ checkPerms (getDirectory file)
379 file_ok <- io $ checkPerms file
380 when (dir_ok && file_ok) $ do
381 either_hdl <- io $ IO.try (openFile file ReadMode)
384 -- NOTE: this assumes that runInputT won't affect the terminal;
385 -- can we assume this will always be the case?
386 -- This would be a good place for runFileInputT.
387 Right hdl -> runInputTWithPrefs defaultPrefs defaultSettings $ do
389 runCommands $ fileLoop hdl
391 getDirectory f = case takeDirectory f of "" -> "."; d -> d
393 when (read_dot_files) $ do
394 cfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
395 cfgs <- io $ mapM canonicalizePath (catMaybes cfgs0)
396 mapM_ sourceConfigFile (nub cfgs)
397 -- nub, because we don't want to read .ghci twice if the
400 -- Perform a :load for files given on the GHCi command line
401 -- When in -e mode, if the load fails then we want to stop
402 -- immediately rather than going on to evaluate the expression.
403 when (not (null paths)) $ do
404 ok <- ghciHandle (\e -> do showException e; return Failed) $
405 -- TODO: this is a hack.
406 runInputTWithPrefs defaultPrefs defaultSettings $ do
407 let (filePaths, phases) = unzip paths
408 filePaths' <- mapM (Encoding.decode . BS.pack) filePaths
409 loadModule (zip filePaths' phases)
410 when (isJust maybe_exprs && failed ok) $
411 io (exitWith (ExitFailure 1))
413 -- if verbosity is greater than 0, or we are connected to a
414 -- terminal, display the prompt in the interactive loop.
415 is_tty <- io (hIsTerminalDevice stdin)
416 dflags <- getDynFlags
417 let show_prompt = verbosity dflags > 0 || is_tty
422 -- enter the interactive loop
423 runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
425 -- just evaluate the expression we were given
426 enqueueCommands exprs
427 let handle e = do st <- getGHCiState
428 -- Jump through some hoops to get the
429 -- current progname in the exception text:
430 -- <progname>: <exception>
431 io $ withProgName (progname st)
432 -- this used to be topHandlerFastExit, see #2228
434 runInputTWithPrefs defaultPrefs defaultSettings $ do
436 runCommands' handle (return Nothing)
439 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
441 runGHCiInput :: InputT GHCi a -> GHCi a
443 histFile <- io $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
445 let settings = setComplete ghciCompleteWord
446 $ defaultSettings {historyFile = histFile}
447 runInputT settings $ do
451 nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
452 nextInputLine show_prompt is_tty
454 prompt <- if show_prompt then lift mkPrompt else return ""
457 when show_prompt $ lift mkPrompt >>= liftIO . putStr
460 -- NOTE: We only read .ghci files if they are owned by the current user,
461 -- and aren't world writable. Otherwise, we could be accidentally
462 -- running code planted by a malicious third party.
464 -- Furthermore, We only read ./.ghci if . is owned by the current user
465 -- and isn't writable by anyone else. I think this is sufficient: we
466 -- don't need to check .. and ../.. etc. because "." always refers to
467 -- the same directory while a process is running.
469 checkPerms :: String -> IO Bool
470 #ifdef mingw32_HOST_OS
475 handleIO (\_ -> return False) $ do
476 st <- getFileStatus name
478 if fileOwner st /= me then do
479 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
482 let mode = fileMode st
483 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
484 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
486 putStrLn $ "*** WARNING: " ++ name ++
487 " is writable by someone else, IGNORING!"
492 fileLoop :: MonadIO m => Handle -> InputT m (Maybe String)
494 l <- liftIO $ IO.try $ hGetLine hdl
496 Left e | isEOFError e -> return Nothing
497 | InvalidArgument <- etype -> return Nothing
498 | otherwise -> liftIO $ ioError e
499 where etype = ioeGetErrorType e
500 -- treat InvalidArgument in the same way as EOF:
501 -- this can happen if the user closed stdin, or
502 -- perhaps did getContents which closes stdin at
504 Right l -> fmap Just (Encoding.decode (BS.pack l))
506 mkPrompt :: GHCi String
508 (toplevs,exports) <- GHC.getContext
509 resumes <- GHC.getResumeContext
510 -- st <- getGHCiState
516 let ix = GHC.resumeHistoryIx r
518 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
520 let hist = GHC.resumeHistory r !! (ix-1)
521 span <- GHC.getHistorySpan hist
522 return (brackets (ppr (negate ix) <> char ':'
523 <+> ppr span) <> space)
525 dots | _:rs <- resumes, not (null rs) = text "... "
532 -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
533 -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
534 -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
535 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
536 hsep (map (ppr . GHC.moduleName) exports)
538 deflt_prompt = dots <> context_bit <> modules_bit
540 f ('%':'s':xs) = deflt_prompt <> f xs
541 f ('%':'%':xs) = char '%' <> f xs
542 f (x:xs) = char x <> f xs
546 return (showSDoc (f (prompt st)))
549 queryQueue :: GHCi (Maybe String)
554 c:cs -> do setGHCiState st{ cmdqueue = cs }
557 runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
558 runCommands = runCommands' handler
560 runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
561 -> InputT GHCi (Maybe String) -> InputT GHCi ()
562 runCommands' eh getCmd = do
563 b <- handleGhcException (\e -> case e of
564 Interrupted -> return False
565 _other -> liftIO (print e) >> return True)
566 (runOneCommand eh getCmd)
567 if b then return () else runCommands' eh getCmd
569 runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
571 runOneCommand eh getCmd = do
572 mb_cmd <- noSpace (lift queryQueue)
573 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
575 Nothing -> return True
576 Just c -> ghciHandle (lift . eh) $
577 handleSourceError printErrorAndKeepGoing
580 printErrorAndKeepGoing err = do
581 GHC.printExceptionAndWarnings err
584 noSpace q = q >>= maybe (return Nothing)
585 (\c->case removeSpaces c of
587 ":{" -> multiLineCmd q
588 c -> return (Just c) )
590 st <- lift getGHCiState
592 lift $ setGHCiState st{ prompt = "%s| " }
593 mb_cmd <- collectCommand q ""
594 lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p }
596 -- we can't use removeSpaces for the sublines here, so
597 -- multiline commands are somewhat more brittle against
598 -- fileformat errors (such as \r in dos input on unix),
599 -- we get rid of any extra spaces for the ":}" test;
600 -- we also avoid silent failure if ":}" is not found;
601 -- and since there is no (?) valid occurrence of \r (as
602 -- opposed to its String representation, "\r") inside a
603 -- ghci command, we replace any such with ' ' (argh:-(
604 collectCommand q c = q >>=
605 maybe (liftIO (ioError collectError))
606 (\l->if removeSpaces l == ":}"
607 then return (Just $ removeSpaces c)
608 else collectCommand q (c++map normSpace l))
609 where normSpace '\r' = ' '
611 -- QUESTION: is userError the one to use here?
612 collectError = userError "unterminated multiline command :{ .. :}"
613 doCommand (':' : cmd) = specialCommand cmd
614 doCommand stmt = do timeIt $ lift $ runStmt stmt GHC.RunToCompletion
617 enqueueCommands :: [String] -> GHCi ()
618 enqueueCommands cmds = do
620 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
623 runStmt :: String -> SingleStep -> GHCi Bool
625 | null (filter (not.isSpace) stmt) = return False
626 | ["import", mod] <- words stmt = keepGoing' setContext ('+':mod)
628 = do result <- GhciMonad.runStmt stmt step
629 afterRunStmt (const True) result
631 --afterRunStmt :: GHC.RunResult -> GHCi Bool
632 -- False <=> the statement failed to compile
633 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
634 afterRunStmt _ (GHC.RunException e) = throw e
635 afterRunStmt step_here run_result = do
636 resumes <- GHC.getResumeContext
638 GHC.RunOk names -> do
639 show_types <- isOptionSet ShowType
640 when show_types $ printTypeOfNames names
641 GHC.RunBreak _ names mb_info
642 | isNothing mb_info ||
643 step_here (GHC.resumeSpan $ head resumes) -> do
644 mb_id_loc <- toBreakIdAndLocation mb_info
645 let breakCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
647 then printStoppedAtBreakInfo (head resumes) names
648 else enqueueCommands [breakCmd]
649 -- run the command set with ":set stop <cmd>"
651 enqueueCommands [stop st]
653 | otherwise -> resume step_here GHC.SingleStep >>=
654 afterRunStmt step_here >> return ()
658 io installSignalHandlers
659 b <- isOptionSet RevertCAFs
662 return (case run_result of GHC.RunOk _ -> True; _ -> False)
664 toBreakIdAndLocation ::
665 Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
666 toBreakIdAndLocation Nothing = return Nothing
667 toBreakIdAndLocation (Just info) = do
668 let mod = GHC.breakInfo_module info
669 nm = GHC.breakInfo_number info
671 return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
672 breakModule loc == mod,
673 breakTick loc == nm ]
675 printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
676 printStoppedAtBreakInfo resume names = do
677 printForUser $ ptext (sLit "Stopped at") <+>
678 ppr (GHC.resumeSpan resume)
679 -- printTypeOfNames session names
680 let namesSorted = sortBy compareNames names
681 tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
682 docs <- pprTypeAndContents [id | AnId id <- tythings]
683 printForUserPartWay docs
685 printTypeOfNames :: [Name] -> GHCi ()
686 printTypeOfNames names
687 = mapM_ (printTypeOfName ) $ sortBy compareNames names
689 compareNames :: Name -> Name -> Ordering
690 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
691 where compareWith n = (getOccString n, getSrcSpan n)
693 printTypeOfName :: Name -> GHCi ()
695 = do maybe_tything <- GHC.lookupName n
696 case maybe_tything of
698 Just thing -> printTyThing thing
701 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
703 specialCommand :: String -> InputT GHCi Bool
704 specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
705 specialCommand str = do
706 let (cmd,rest) = break isSpace str
707 maybe_cmd <- lift $ lookupCommand cmd
709 GotCommand (_,f,_) -> f (dropWhile isSpace rest)
711 do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
715 do liftIO $ hPutStr stdout ("there is no last command to perform\n"
719 lookupCommand :: String -> GHCi (MaybeCommand)
720 lookupCommand "" = do
722 case last_command st of
723 Just c -> return $ GotCommand c
724 Nothing -> return NoLastCommand
725 lookupCommand str = do
726 mc <- io $ lookupCommand' str
728 setGHCiState st{ last_command = mc }
730 Just c -> GotCommand c
731 Nothing -> BadCommand
733 lookupCommand' :: String -> IO (Maybe Command)
734 lookupCommand' str = do
735 macros <- readIORef macros_ref
736 let cmds = builtin_commands ++ macros
737 -- look for exact match first, then the first prefix match
738 return $ case [ c | c <- cmds, str == cmdName c ] of
740 [] -> case [ c | c@(s,_,_) <- cmds, str `isPrefixOf` s ] of
744 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
745 getCurrentBreakSpan = do
746 resumes <- GHC.getResumeContext
750 let ix = GHC.resumeHistoryIx r
752 then return (Just (GHC.resumeSpan r))
754 let hist = GHC.resumeHistory r !! (ix-1)
755 span <- GHC.getHistorySpan hist
758 getCurrentBreakModule :: GHCi (Maybe Module)
759 getCurrentBreakModule = do
760 resumes <- GHC.getResumeContext
764 let ix = GHC.resumeHistoryIx r
766 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
768 let hist = GHC.resumeHistory r !! (ix-1)
769 return $ Just $ GHC.getHistoryModule hist
771 -----------------------------------------------------------------------------
774 noArgs :: GHCi () -> String -> GHCi ()
776 noArgs _ _ = io $ putStrLn "This command takes no arguments"
778 help :: String -> GHCi ()
779 help _ = io (putStr helpText)
781 info :: String -> InputT GHCi ()
782 info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
783 info s = handleSourceError GHC.printExceptionAndWarnings $ do
784 { let names = words s
785 ; dflags <- getDynFlags
786 ; let pefas = dopt Opt_PrintExplicitForalls dflags
787 ; mapM_ (infoThing pefas) names }
789 infoThing pefas str = do
790 names <- GHC.parseName str
791 mb_stuffs <- mapM GHC.getInfo names
792 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
793 unqual <- GHC.getPrintUnqual
794 outputStrLn $ showSDocForUser unqual $
795 vcat (intersperse (text "") $
796 map (pprInfo pefas) filtered)
798 -- Filter out names whose parent is also there Good
799 -- example is '[]', which is both a type and data
800 -- constructor in the same type
801 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
802 filterOutChildren get_thing xs
803 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
805 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
807 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
808 pprInfo pefas (thing, fixity, insts)
809 = pprTyThingInContextLoc pefas thing
810 $$ show_fixity fixity
811 $$ vcat (map GHC.pprInstance insts)
814 | fix == GHC.defaultFixity = empty
815 | otherwise = ppr fix <+> ppr (GHC.getName thing)
817 runMain :: String -> GHCi ()
818 runMain s = case toArgs s of
819 Left err -> io (hPutStrLn stderr err)
821 do dflags <- getDynFlags
822 case mainFunIs dflags of
823 Nothing -> doWithArgs args "main"
824 Just f -> doWithArgs args f
826 runRun :: String -> GHCi ()
827 runRun s = case toCmdArgs s of
828 Left err -> io (hPutStrLn stderr err)
829 Right (cmd, args) -> doWithArgs args cmd
831 doWithArgs :: [String] -> String -> GHCi ()
832 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
833 show args ++ " (" ++ cmd ++ ")"]
835 addModule :: [FilePath] -> InputT GHCi ()
837 lift revertCAFs -- always revert CAFs on load/add.
838 files <- mapM expandPath files
839 targets <- mapM (\m -> GHC.guessTarget m Nothing) files
840 -- remove old targets with the same id; e.g. for :add *M
841 mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
842 mapM_ GHC.addTarget targets
843 prev_context <- GHC.getContext
844 ok <- trySuccess $ GHC.load LoadAllTargets
845 afterLoad ok False prev_context
847 changeDirectory :: String -> InputT GHCi ()
848 changeDirectory "" = do
849 -- :cd on its own changes to the user's home directory
850 either_dir <- liftIO $ IO.try getHomeDirectory
853 Right dir -> changeDirectory dir
854 changeDirectory dir = do
855 graph <- GHC.getModuleGraph
856 when (not (null graph)) $
857 outputStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
858 prev_context <- GHC.getContext
860 GHC.load LoadAllTargets
861 lift $ setContextAfterLoad prev_context False []
862 GHC.workingDirectoryChanged
863 dir <- expandPath dir
864 liftIO $ setCurrentDirectory dir
866 trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
868 handleSourceError (\e -> do GHC.printExceptionAndWarnings e
872 editFile :: String -> GHCi ()
874 do file <- if null str then chooseEditFile else return str
878 $ ghcError (CmdLineError "editor not set, use :set editor")
879 io $ system (cmd ++ ' ':file)
882 -- The user didn't specify a file so we pick one for them.
883 -- Our strategy is to pick the first module that failed to load,
884 -- or otherwise the first target.
886 -- XXX: Can we figure out what happened if the depndecy analysis fails
887 -- (e.g., because the porgrammeer mistyped the name of a module)?
888 -- XXX: Can we figure out the location of an error to pass to the editor?
889 -- XXX: if we could figure out the list of errors that occured during the
890 -- last load/reaload, then we could start the editor focused on the first
892 chooseEditFile :: GHCi String
894 do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
896 graph <- GHC.getModuleGraph
897 failed_graph <- filterM hasFailed graph
898 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
900 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
903 case pick (order failed_graph) of
904 Just file -> return file
906 do targets <- GHC.getTargets
907 case msum (map fromTarget targets) of
908 Just file -> return file
909 Nothing -> ghcError (CmdLineError "No files to edit.")
911 where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
912 fromTarget _ = Nothing -- when would we get a module target?
914 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
915 defineMacro overwrite s = do
916 let (macro_name, definition) = break isSpace s
917 macros <- io (readIORef macros_ref)
918 let defined = map cmdName macros
921 then io $ putStrLn "no macros defined"
922 else io $ putStr ("the following macros are defined:\n" ++
925 if (not overwrite && macro_name `elem` defined)
926 then ghcError (CmdLineError
927 ("macro '" ++ macro_name ++ "' is already defined"))
930 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
932 -- give the expression a type signature, so we can be sure we're getting
933 -- something of the right type.
934 let new_expr = '(' : definition ++ ") :: String -> IO String"
936 -- compile the expression
937 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
938 hv <- GHC.compileExpr new_expr
939 io (writeIORef macros_ref --
940 (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)]))
942 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
944 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
945 -- make sure we force any exceptions in the result, while we are still
946 -- inside the exception handler for commands:
947 seqList str (return ())
948 enqueueCommands (lines str)
951 undefineMacro :: String -> GHCi ()
952 undefineMacro str = mapM_ undef (words str)
953 where undef macro_name = do
954 cmds <- io (readIORef macros_ref)
955 if (macro_name `notElem` map cmdName cmds)
956 then ghcError (CmdLineError
957 ("macro '" ++ macro_name ++ "' is not defined"))
959 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
961 cmdCmd :: String -> GHCi ()
963 let expr = '(' : str ++ ") :: IO String"
964 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
965 hv <- GHC.compileExpr expr
966 cmds <- io $ (unsafeCoerce# hv :: IO String)
967 enqueueCommands (lines cmds)
970 loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
971 loadModule fs = timeIt (loadModule' fs)
973 loadModule_ :: [FilePath] -> InputT GHCi ()
974 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
976 loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
977 loadModule' files = do
978 prev_context <- GHC.getContext
982 lift discardActiveBreakPoints
984 GHC.load LoadAllTargets
986 let (filenames, phases) = unzip files
987 exp_filenames <- mapM expandPath filenames
988 let files' = zip exp_filenames phases
989 targets <- mapM (uncurry GHC.guessTarget) files'
991 -- NOTE: we used to do the dependency anal first, so that if it
992 -- fails we didn't throw away the current set of modules. This would
993 -- require some re-working of the GHC interface, so we'll leave it
994 -- as a ToDo for now.
996 GHC.setTargets targets
997 doLoad False prev_context LoadAllTargets
999 checkModule :: String -> InputT GHCi ()
1001 let modl = GHC.mkModuleName m
1002 prev_context <- GHC.getContext
1003 ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do
1004 r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
1005 outputStrLn (showSDoc (
1006 case GHC.moduleInfo r of
1007 cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1009 (local,global) = ASSERT( all isExternalName scope )
1010 partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1012 (text "global names: " <+> ppr global) $$
1013 (text "local names: " <+> ppr local)
1016 afterLoad (successIf ok) False prev_context
1018 reloadModule :: String -> InputT GHCi ()
1020 prev_context <- GHC.getContext
1021 doLoad True prev_context $
1022 if null m then LoadAllTargets
1023 else LoadUpTo (GHC.mkModuleName m)
1026 doLoad :: Bool -> ([Module],[Module]) -> LoadHowMuch -> InputT GHCi SuccessFlag
1027 doLoad retain_context prev_context howmuch = do
1028 -- turn off breakpoints before we load: we can't turn them off later, because
1029 -- the ModBreaks will have gone away.
1030 lift discardActiveBreakPoints
1031 ok <- trySuccess $ GHC.load howmuch
1032 afterLoad ok retain_context prev_context
1035 afterLoad :: SuccessFlag -> Bool -> ([Module],[Module]) -> InputT GHCi ()
1036 afterLoad ok retain_context prev_context = do
1037 lift revertCAFs -- always revert CAFs on load.
1038 lift discardTickArrays
1039 loaded_mod_summaries <- getLoadedModules
1040 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1041 loaded_mod_names = map GHC.moduleName loaded_mods
1042 modulesLoadedMsg ok loaded_mod_names
1044 lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
1047 setContextAfterLoad :: ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi ()
1048 setContextAfterLoad prev keep_ctxt [] = do
1049 prel_mod <- getPrelude
1050 setContextKeepingPackageModules prev keep_ctxt ([], [prel_mod])
1051 setContextAfterLoad prev keep_ctxt ms = do
1052 -- load a target if one is available, otherwise load the topmost module.
1053 targets <- GHC.getTargets
1054 case [ m | Just m <- map (findTarget ms) targets ] of
1056 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1057 load_this (last graph')
1062 = case filter (`matches` t) ms of
1066 summary `matches` Target (TargetModule m) _ _
1067 = GHC.ms_mod_name summary == m
1068 summary `matches` Target (TargetFile f _) _ _
1069 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1073 load_this summary | m <- GHC.ms_mod summary = do
1074 b <- GHC.moduleIsInterpreted m
1075 if b then setContextKeepingPackageModules prev keep_ctxt ([m], [])
1077 prel_mod <- getPrelude
1078 setContextKeepingPackageModules prev keep_ctxt ([],[prel_mod,m])
1080 -- | Keep any package modules (except Prelude) when changing the context.
1081 setContextKeepingPackageModules
1082 :: ([Module],[Module]) -- previous context
1083 -> Bool -- re-execute :module commands
1084 -> ([Module],[Module]) -- new context
1086 setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do
1087 let (_,bs0) = prev_context
1088 prel_mod <- getPrelude
1089 let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1090 let bs1 = if null as then nub (prel_mod : bs) else bs
1091 GHC.setContext as (nub (bs1 ++ pkg_modules))
1095 mapM_ (playCtxtCmd False) (remembered_ctx st)
1098 setGHCiState st{ remembered_ctx = [] }
1100 isHomeModule :: Module -> Bool
1101 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1103 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi ()
1104 modulesLoadedMsg ok mods = do
1105 dflags <- getDynFlags
1106 when (verbosity dflags > 0) $ do
1108 | null mods = text "none."
1109 | otherwise = hsep (
1110 punctuate comma (map ppr mods)) <> text "."
1113 outputStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))
1115 outputStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas))
1118 typeOfExpr :: String -> InputT GHCi ()
1120 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1121 ty <- GHC.exprType str
1122 dflags <- getDynFlags
1123 let pefas = dopt Opt_PrintExplicitForalls dflags
1124 printForUser' $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]
1126 kindOfType :: String -> InputT GHCi ()
1128 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1129 ty <- GHC.typeKind str
1130 printForUser' $ text str <+> dcolon <+> ppr ty
1132 quit :: String -> InputT GHCi Bool
1133 quit _ = return True
1135 shellEscape :: String -> GHCi Bool
1136 shellEscape str = io (system str >> return False)
1138 -----------------------------------------------------------------------------
1139 -- Browsing a module's contents
1141 browseCmd :: Bool -> String -> InputT GHCi ()
1144 ['*':s] | looksLikeModuleName s -> do
1145 m <- lift $ wantInterpretedModule s
1146 browseModule bang m False
1147 [s] | looksLikeModuleName s -> do
1148 m <- lift $ lookupModule s
1149 browseModule bang m True
1151 (as,bs) <- GHC.getContext
1152 -- Guess which module the user wants to browse. Pick
1153 -- modules that are interpreted first. The most
1154 -- recently-added module occurs last, it seems.
1156 (as@(_:_), _) -> browseModule bang (last as) True
1157 ([], bs@(_:_)) -> browseModule bang (last bs) True
1158 ([], []) -> ghcError (CmdLineError ":browse: no current module")
1159 _ -> ghcError (CmdLineError "syntax: :browse <module>")
1161 -- without bang, show items in context of their parents and omit children
1162 -- with bang, show class methods and data constructors separately, and
1163 -- indicate import modules, to aid qualifying unqualified names
1164 -- with sorted, sort items alphabetically
1165 browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
1166 browseModule bang modl exports_only = do
1167 -- :browse! reports qualifiers wrt current context
1168 current_unqual <- GHC.getPrintUnqual
1169 -- Temporarily set the context to the module we're interested in,
1170 -- just so we can get an appropriate PrintUnqualified
1171 (as,bs) <- GHC.getContext
1172 prel_mod <- lift getPrelude
1173 if exports_only then GHC.setContext [] [prel_mod,modl]
1174 else GHC.setContext [modl] []
1175 target_unqual <- GHC.getPrintUnqual
1176 GHC.setContext as bs
1178 let unqual = if bang then current_unqual else target_unqual
1180 mb_mod_info <- GHC.getModuleInfo modl
1182 Nothing -> ghcError (CmdLineError ("unknown module: " ++
1183 GHC.moduleNameString (GHC.moduleName modl)))
1185 dflags <- getDynFlags
1187 | exports_only = GHC.modInfoExports mod_info
1188 | otherwise = GHC.modInfoTopLevelScope mod_info
1191 -- sort alphabetically name, but putting
1192 -- locally-defined identifiers first.
1193 -- We would like to improve this; see #1799.
1194 sorted_names = loc_sort local ++ occ_sort external
1196 (local,external) = ASSERT( all isExternalName names )
1197 partition ((==modl) . nameModule) names
1198 occ_sort = sortBy (compare `on` nameOccName)
1199 -- try to sort by src location. If the first name in
1200 -- our list has a good source location, then they all should.
1202 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1203 = sortBy (compare `on` nameSrcSpan) names
1207 mb_things <- mapM GHC.lookupName sorted_names
1208 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1210 rdr_env <- GHC.getGRE
1212 let pefas = dopt Opt_PrintExplicitForalls dflags
1213 things | bang = catMaybes mb_things
1214 | otherwise = filtered_things
1215 pretty | bang = pprTyThing
1216 | otherwise = pprTyThingInContext
1218 labels [] = text "-- not currently imported"
1219 labels l = text $ intercalate "\n" $ map qualifier l
1220 qualifier = maybe "-- defined locally"
1221 (("-- imported via "++) . intercalate ", "
1222 . map GHC.moduleNameString)
1223 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1224 modNames = map (importInfo . GHC.getName) things
1226 -- annotate groups of imports with their import modules
1227 -- the default ordering is somewhat arbitrary, so we group
1228 -- by header and sort groups; the names themselves should
1229 -- really come in order of source appearance.. (trac #1799)
1230 annotate mts = concatMap (\(m,ts)->labels m:ts)
1231 $ sortBy cmpQualifiers $ group mts
1232 where cmpQualifiers =
1233 compare `on` (map (fmap (map moduleNameFS)) . fst)
1235 group mts@((m,_):_) = (m,map snd g) : group ng
1236 where (g,ng) = partition ((==m).fst) mts
1238 let prettyThings = map (pretty pefas) things
1239 prettyThings' | bang = annotate $ zip modNames prettyThings
1240 | otherwise = prettyThings
1241 outputStrLn $ showSDocForUser unqual (vcat prettyThings')
1242 -- ToDo: modInfoInstances currently throws an exception for
1243 -- package modules. When it works, we can do this:
1244 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1246 -----------------------------------------------------------------------------
1247 -- Setting the module context
1249 setContext :: String -> GHCi ()
1251 | all sensible strs = do
1252 playCtxtCmd True (cmd, as, bs)
1254 setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] }
1255 | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1257 (cmd, strs, as, bs) =
1259 '+':stuff -> rest AddModules stuff
1260 '-':stuff -> rest RemModules stuff
1261 stuff -> rest SetContext stuff
1263 rest cmd stuff = (cmd, strs, as, bs)
1264 where strs = words stuff
1265 (as,bs) = partitionWith starred strs
1267 sensible ('*':m) = looksLikeModuleName m
1268 sensible m = looksLikeModuleName m
1270 starred ('*':m) = Left m
1273 playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi ()
1274 playCtxtCmd fail (cmd, as, bs)
1276 (as',bs') <- do_checks fail
1277 (prev_as,prev_bs) <- GHC.getContext
1281 prel_mod <- getPrelude
1282 let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs'
1286 let as_to_add = as' \\ (prev_as ++ prev_bs)
1287 bs_to_add = bs' \\ (prev_as ++ prev_bs)
1288 return (prev_as ++ as_to_add, prev_bs ++ bs_to_add)
1290 let new_as = prev_as \\ (as' ++ bs')
1291 new_bs = prev_bs \\ (as' ++ bs')
1292 return (new_as, new_bs)
1293 GHC.setContext new_as new_bs
1296 as' <- mapM wantInterpretedModule as
1297 bs' <- mapM lookupModule bs
1299 do_checks False = do
1300 as' <- mapM (trymaybe . wantInterpretedModule) as
1301 bs' <- mapM (trymaybe . lookupModule) bs
1302 return (catMaybes as', catMaybes bs')
1307 Left _ -> return Nothing
1308 Right a -> return (Just a)
1310 ----------------------------------------------------------------------------
1313 -- set options in the interpreter. Syntax is exactly the same as the
1314 -- ghc command line, except that certain options aren't available (-C,
1317 -- This is pretty fragile: most options won't work as expected. ToDo:
1318 -- figure out which ones & disallow them.
1320 setCmd :: String -> GHCi ()
1322 = do st <- getGHCiState
1323 let opts = options st
1324 io $ putStrLn (showSDoc (
1325 text "options currently set: " <>
1328 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1330 dflags <- getDynFlags
1331 io $ putStrLn (showSDoc (
1332 vcat (text "GHCi-specific dynamic flag settings:"
1333 :map (flagSetting dflags) ghciFlags)
1335 io $ putStrLn (showSDoc (
1336 vcat (text "other dynamic, non-language, flag settings:"
1337 :map (flagSetting dflags) nonLanguageDynFlags)
1339 where flagSetting dflags (str, f, _)
1340 | dopt f dflags = text " " <> text "-f" <> text str
1341 | otherwise = text " " <> text "-fno-" <> text str
1342 (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags)
1344 nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions)
1346 flags = [Opt_PrintExplicitForalls
1347 ,Opt_PrintBindResult
1348 ,Opt_BreakOnException
1350 ,Opt_PrintEvldWithShow
1353 = case getCmd str of
1354 Right ("args", rest) ->
1356 Left err -> io (hPutStrLn stderr err)
1357 Right args -> setArgs args
1358 Right ("prog", rest) ->
1360 Right [prog] -> setProg prog
1361 _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")
1362 Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1363 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1364 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1365 _ -> case toArgs str of
1366 Left err -> io (hPutStrLn stderr err)
1367 Right wds -> setOptions wds
1369 setArgs, setOptions :: [String] -> GHCi ()
1370 setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
1374 setGHCiState st{ args = args }
1378 setGHCiState st{ progname = prog }
1382 setGHCiState st{ editor = cmd }
1384 setStop str@(c:_) | isDigit c
1385 = do let (nm_str,rest) = break (not.isDigit) str
1388 let old_breaks = breaks st
1389 if all ((/= nm) . fst) old_breaks
1390 then printForUser (text "Breakpoint" <+> ppr nm <+>
1391 text "does not exist")
1393 let new_breaks = map fn old_breaks
1394 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1395 | otherwise = (i,loc)
1396 setGHCiState st{ breaks = new_breaks }
1399 setGHCiState st{ stop = cmd }
1401 setPrompt value = do
1404 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1406 '\"' : _ -> case reads value of
1407 [(value', xs)] | all isSpace xs ->
1408 setGHCiState (st { prompt = value' })
1410 io $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
1411 _ -> setGHCiState (st { prompt = value })
1414 do -- first, deal with the GHCi opts (+s, +t, etc.)
1415 let (plus_opts, minus_opts) = partitionWith isPlus wds
1416 mapM_ setOpt plus_opts
1417 -- then, dynamic flags
1418 newDynFlags minus_opts
1420 newDynFlags :: [String] -> GHCi ()
1421 newDynFlags minus_opts = do
1422 dflags <- getDynFlags
1423 let pkg_flags = packageFlags dflags
1424 (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
1425 handleFlagWarnings dflags' warns
1427 if (not (null leftovers))
1428 then ghcError $ errorsToGhcException leftovers
1431 new_pkgs <- setDynFlags dflags'
1433 -- if the package flags changed, we should reset the context
1434 -- and link the new packages.
1435 dflags <- getDynFlags
1436 when (packageFlags dflags /= pkg_flags) $ do
1437 io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
1439 GHC.load LoadAllTargets
1440 io (linkPackages dflags new_pkgs)
1441 -- package flags changed, we can't re-use any of the old context
1442 setContextAfterLoad ([],[]) False []
1446 unsetOptions :: String -> GHCi ()
1448 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1449 let opts = words str
1450 (minus_opts, rest1) = partition isMinus opts
1451 (plus_opts, rest2) = partitionWith isPlus rest1
1453 if (not (null rest2))
1454 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1457 mapM_ unsetOpt plus_opts
1459 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1460 no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
1462 no_flags <- mapM no_flag minus_opts
1463 newDynFlags no_flags
1465 isMinus :: String -> Bool
1466 isMinus ('-':_) = True
1469 isPlus :: String -> Either String String
1470 isPlus ('+':opt) = Left opt
1471 isPlus other = Right other
1473 setOpt, unsetOpt :: String -> GHCi ()
1476 = case strToGHCiOpt str of
1477 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1478 Just o -> setOption o
1481 = case strToGHCiOpt str of
1482 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1483 Just o -> unsetOption o
1485 strToGHCiOpt :: String -> (Maybe GHCiOption)
1486 strToGHCiOpt "s" = Just ShowTiming
1487 strToGHCiOpt "t" = Just ShowType
1488 strToGHCiOpt "r" = Just RevertCAFs
1489 strToGHCiOpt _ = Nothing
1491 optToStr :: GHCiOption -> String
1492 optToStr ShowTiming = "s"
1493 optToStr ShowType = "t"
1494 optToStr RevertCAFs = "r"
1496 -- ---------------------------------------------------------------------------
1499 showCmd :: String -> GHCi ()
1503 ["args"] -> io $ putStrLn (show (args st))
1504 ["prog"] -> io $ putStrLn (show (progname st))
1505 ["prompt"] -> io $ putStrLn (show (prompt st))
1506 ["editor"] -> io $ putStrLn (show (editor st))
1507 ["stop"] -> io $ putStrLn (show (stop st))
1508 ["modules" ] -> showModules
1509 ["bindings"] -> showBindings
1510 ["linker"] -> io showLinkerState
1511 ["breaks"] -> showBkptTable
1512 ["context"] -> showContext
1513 ["packages"] -> showPackages
1514 ["languages"] -> showLanguages
1515 _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
1516 " | breaks | context | packages | languages ]"))
1518 showModules :: GHCi ()
1520 loaded_mods <- getLoadedModules
1521 -- we want *loaded* modules only, see #1734
1522 let show_one ms = do m <- GHC.showModule ms; io (putStrLn m)
1523 mapM_ show_one loaded_mods
1525 getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
1526 getLoadedModules = do
1527 graph <- GHC.getModuleGraph
1528 filterM (GHC.isLoaded . GHC.ms_mod_name) graph
1530 showBindings :: GHCi ()
1532 bindings <- GHC.getBindings
1533 docs <- pprTypeAndContents
1534 [ id | AnId id <- sortBy compareTyThings bindings]
1535 printForUserPartWay docs
1537 compareTyThings :: TyThing -> TyThing -> Ordering
1538 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1540 printTyThing :: TyThing -> GHCi ()
1541 printTyThing tyth = do dflags <- getDynFlags
1542 let pefas = dopt Opt_PrintExplicitForalls dflags
1543 printForUser (pprTyThing pefas tyth)
1545 showBkptTable :: GHCi ()
1548 printForUser $ prettyLocations (breaks st)
1550 showContext :: GHCi ()
1552 resumes <- GHC.getResumeContext
1553 printForUser $ vcat (map pp_resume (reverse resumes))
1556 ptext (sLit "--> ") <> text (GHC.resumeStmt resume)
1557 $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume))
1559 showPackages :: GHCi ()
1561 pkg_flags <- fmap packageFlags getDynFlags
1562 io $ putStrLn $ showSDoc $ vcat $
1563 text ("active package flags:"++if null pkg_flags then " none" else "")
1564 : map showFlag pkg_flags
1565 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1566 io $ putStrLn $ showSDoc $ vcat $
1567 text "packages currently loaded:"
1568 : map (nest 2 . text . packageIdString)
1569 (sortBy (compare `on` packageIdFS) pkg_ids)
1570 where showFlag (ExposePackage p) = text $ " -package " ++ p
1571 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1572 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1574 showLanguages :: GHCi ()
1576 dflags <- getDynFlags
1577 io $ putStrLn $ showSDoc $ vcat $
1578 text "active language flags:" :
1579 [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags]
1581 -- -----------------------------------------------------------------------------
1584 completeCmd, completeMacro, completeIdentifier, completeModule,
1585 completeHomeModule, completeSetOptions, completeShowOptions,
1586 completeHomeModuleOrFile, completeExpression
1587 :: CompletionFunc GHCi
1589 ghciCompleteWord :: CompletionFunc GHCi
1590 ghciCompleteWord line@(left,_) = case firstWord of
1591 ':':cmd | null rest -> completeCmd line
1593 completion <- lookupCompletion cmd
1595 "import" -> completeModule line
1596 _ -> completeExpression line
1598 (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
1599 lookupCompletion ('!':_) = return completeFilename
1600 lookupCompletion c = do
1601 maybe_cmd <- liftIO $ lookupCommand' c
1603 Just (_,_,f) -> return f
1604 Nothing -> return completeFilename
1606 completeCmd = wrapCompleter " " $ \w -> do
1607 cmds <- liftIO $ readIORef macros_ref
1608 return (filter (w `isPrefixOf`) (map (':':)
1609 (map cmdName (builtin_commands ++ cmds))))
1611 completeMacro = wrapIdentCompleter $ \w -> do
1612 cmds <- liftIO $ readIORef macros_ref
1613 return (filter (w `isPrefixOf`) (map cmdName cmds))
1615 completeIdentifier = wrapIdentCompleter $ \w -> do
1616 rdrs <- GHC.getRdrNamesInScope
1617 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1619 completeModule = wrapIdentCompleter $ \w -> do
1620 dflags <- GHC.getSessionDynFlags
1621 let pkg_mods = allExposedModules dflags
1622 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
1623 return $ filter (w `isPrefixOf`)
1624 $ map (showSDoc.ppr) $ loaded_mods ++ pkg_mods
1626 completeHomeModule = wrapIdentCompleter listHomeModules
1628 listHomeModules :: String -> GHCi [String]
1629 listHomeModules w = do
1630 g <- GHC.getModuleGraph
1631 let home_mods = map GHC.ms_mod_name g
1632 return $ sort $ filter (w `isPrefixOf`)
1633 $ map (showSDoc.ppr) home_mods
1635 completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
1636 return (filter (w `isPrefixOf`) options)
1637 where options = "args":"prog":"prompt":"editor":"stop":flagList
1638 flagList = map head $ group $ sort allFlags
1640 completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
1641 return (filter (w `isPrefixOf`) options)
1642 where options = ["args", "prog", "prompt", "editor", "stop",
1643 "modules", "bindings", "linker", "breaks",
1644 "context", "packages", "languages"]
1646 completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
1647 $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
1650 unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
1651 unionComplete f1 f2 line = do
1656 wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
1657 wrapCompleter breakChars fun = completeWord Nothing breakChars
1658 $ fmap (map simpleCompletion) . fmap sort . fun
1660 wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
1661 wrapIdentCompleter = wrapCompleter word_break_chars
1663 allExposedModules :: DynFlags -> [ModuleName]
1664 allExposedModules dflags
1665 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1667 pkg_db = pkgIdMap (pkgState dflags)
1669 completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
1672 -- ---------------------------------------------------------------------------
1673 -- User code exception handling
1675 -- This is the exception handler for exceptions generated by the
1676 -- user's code and exceptions coming from children sessions;
1677 -- it normally just prints out the exception. The
1678 -- handler must be recursive, in case showing the exception causes
1679 -- more exceptions to be raised.
1681 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1682 -- raising another exception. We therefore don't put the recursive
1683 -- handler arond the flushing operation, so if stderr is closed
1684 -- GHCi will just die gracefully rather than going into an infinite loop.
1685 handler :: SomeException -> GHCi Bool
1687 handler exception = do
1689 io installSignalHandlers
1690 ghciHandle handler (showException exception >> return False)
1692 showException :: SomeException -> GHCi ()
1694 io $ case fromException se of
1695 Just Interrupted -> putStrLn "Interrupted."
1696 -- omit the location for CmdLineError:
1697 Just (CmdLineError s) -> putStrLn s
1699 Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
1700 Just other_ghc_ex -> print other_ghc_ex
1701 Nothing -> putStrLn ("*** Exception: " ++ show se)
1703 -----------------------------------------------------------------------------
1704 -- recursive exception handlers
1706 -- Don't forget to unblock async exceptions in the handler, or if we're
1707 -- in an exception loop (eg. let a = error a in a) the ^C exception
1708 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1710 ghciHandle :: MonadException m => (SomeException -> m a) -> m a -> m a
1711 ghciHandle h m = Haskeline.catch m $ \e -> unblock (h e)
1713 ghciTry :: GHCi a -> GHCi (Either SomeException a)
1714 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
1716 -- ----------------------------------------------------------------------------
1719 -- TODO: won't work if home dir is encoded.
1720 -- (changeDirectory may not work either in that case.)
1721 expandPath :: MonadIO m => String -> InputT m String
1722 expandPath path = do
1723 exp_path <- liftIO $ expandPathIO path
1724 enc <- fmap BS.unpack $ Encoding.encode exp_path
1727 expandPathIO :: String -> IO String
1729 case dropWhile isSpace path of
1731 tilde <- getHomeDirectory -- will fail if HOME not defined
1732 return (tilde ++ '/':d)
1736 wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
1737 wantInterpretedModule str = do
1738 modl <- lookupModule str
1739 dflags <- getDynFlags
1740 when (GHC.modulePackageId modl /= thisPackage dflags) $
1741 ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
1742 is_interpreted <- GHC.moduleIsInterpreted modl
1743 when (not is_interpreted) $
1744 ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
1747 wantNameFromInterpretedModule :: GHC.GhcMonad m
1748 => (Name -> SDoc -> m ())
1752 wantNameFromInterpretedModule noCanDo str and_then =
1753 handleSourceError (GHC.printExceptionAndWarnings) $ do
1754 names <- GHC.parseName str
1758 let modl = ASSERT( isExternalName n ) GHC.nameModule n
1759 if not (GHC.isExternalName n)
1760 then noCanDo n $ ppr n <>
1761 text " is not defined in an interpreted module"
1763 is_interpreted <- GHC.moduleIsInterpreted modl
1764 if not is_interpreted
1765 then noCanDo n $ text "module " <> ppr modl <>
1766 text " is not interpreted"
1769 -- -----------------------------------------------------------------------------
1770 -- commands for debugger
1772 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1773 sprintCmd = pprintCommand False False
1774 printCmd = pprintCommand True False
1775 forceCmd = pprintCommand False True
1777 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1778 pprintCommand bind force str = do
1779 pprintClosureCommand bind force str
1781 stepCmd :: String -> GHCi ()
1782 stepCmd [] = doContinue (const True) GHC.SingleStep
1783 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1785 stepLocalCmd :: String -> GHCi ()
1786 stepLocalCmd [] = do
1787 mb_span <- getCurrentBreakSpan
1789 Nothing -> stepCmd []
1791 Just mod <- getCurrentBreakModule
1792 current_toplevel_decl <- enclosingTickSpan mod loc
1793 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1795 stepLocalCmd expression = stepCmd expression
1797 stepModuleCmd :: String -> GHCi ()
1798 stepModuleCmd [] = do
1799 mb_span <- getCurrentBreakSpan
1801 Nothing -> stepCmd []
1803 Just span <- getCurrentBreakSpan
1804 let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span
1805 doContinue f GHC.SingleStep
1807 stepModuleCmd expression = stepCmd expression
1809 -- | Returns the span of the largest tick containing the srcspan given
1810 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1811 enclosingTickSpan mod src = do
1812 ticks <- getTickArray mod
1813 let line = srcSpanStartLine src
1814 ASSERT (inRange (bounds ticks) line) do
1815 let enclosing_spans = [ span | (_,span) <- ticks ! line
1816 , srcSpanEnd span >= srcSpanEnd src]
1817 return . head . sortBy leftmost_largest $ enclosing_spans
1819 traceCmd :: String -> GHCi ()
1820 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1821 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1823 continueCmd :: String -> GHCi ()
1824 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1826 -- doContinue :: SingleStep -> GHCi ()
1827 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1828 doContinue pred step = do
1829 runResult <- resume pred step
1830 afterRunStmt pred runResult
1833 abandonCmd :: String -> GHCi ()
1834 abandonCmd = noArgs $ do
1835 b <- GHC.abandon -- the prompt will change to indicate the new context
1836 when (not b) $ io $ putStrLn "There is no computation running."
1839 deleteCmd :: String -> GHCi ()
1840 deleteCmd argLine = do
1841 deleteSwitch $ words argLine
1843 deleteSwitch :: [String] -> GHCi ()
1845 io $ putStrLn "The delete command requires at least one argument."
1846 -- delete all break points
1847 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1848 deleteSwitch idents = do
1849 mapM_ deleteOneBreak idents
1851 deleteOneBreak :: String -> GHCi ()
1853 | all isDigit str = deleteBreak (read str)
1854 | otherwise = return ()
1856 historyCmd :: String -> GHCi ()
1858 | null arg = history 20
1859 | all isDigit arg = history (read arg)
1860 | otherwise = io $ putStrLn "Syntax: :history [num]"
1863 resumes <- GHC.getResumeContext
1865 [] -> io $ putStrLn "Not stopped at a breakpoint"
1867 let hist = GHC.resumeHistory r
1868 (took,rest) = splitAt num hist
1870 [] -> io $ putStrLn $
1871 "Empty history. Perhaps you forgot to use :trace?"
1873 spans <- mapM GHC.getHistorySpan took
1874 let nums = map (printf "-%-3d:") [(1::Int)..]
1875 names = map GHC.historyEnclosingDecl took
1876 printForUser (vcat(zipWith3
1877 (\x y z -> x <+> y <+> z)
1879 (map (bold . ppr) names)
1880 (map (parens . ppr) spans)))
1881 io $ putStrLn $ if null rest then "<end of history>" else "..."
1883 bold :: SDoc -> SDoc
1884 bold c | do_bold = text start_bold <> c <> text end_bold
1887 backCmd :: String -> GHCi ()
1888 backCmd = noArgs $ do
1889 (names, _, span) <- GHC.back
1890 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span
1891 printTypeOfNames names
1892 -- run the command set with ":set stop <cmd>"
1894 enqueueCommands [stop st]
1896 forwardCmd :: String -> GHCi ()
1897 forwardCmd = noArgs $ do
1898 (names, ix, span) <- GHC.forward
1899 printForUser $ (if (ix == 0)
1900 then ptext (sLit "Stopped at")
1901 else ptext (sLit "Logged breakpoint at")) <+> ppr span
1902 printTypeOfNames names
1903 -- run the command set with ":set stop <cmd>"
1905 enqueueCommands [stop st]
1907 -- handle the "break" command
1908 breakCmd :: String -> GHCi ()
1909 breakCmd argLine = do
1910 breakSwitch $ words argLine
1912 breakSwitch :: [String] -> GHCi ()
1914 io $ putStrLn "The break command requires at least one argument."
1915 breakSwitch (arg1:rest)
1916 | looksLikeModuleName arg1 && not (null rest) = do
1917 mod <- wantInterpretedModule arg1
1918 breakByModule mod rest
1919 | all isDigit arg1 = do
1920 (toplevel, _) <- GHC.getContext
1922 (mod : _) -> breakByModuleLine mod (read arg1) rest
1924 io $ putStrLn "Cannot find default module for breakpoint."
1925 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1926 | otherwise = do -- try parsing it as an identifier
1927 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1928 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1929 if GHC.isGoodSrcLoc loc
1930 then ASSERT( isExternalName name )
1931 findBreakAndSet (GHC.nameModule name) $
1932 findBreakByCoord (Just (GHC.srcLocFile loc))
1933 (GHC.srcLocLine loc,
1935 else noCanDo name $ text "can't find its location: " <> ppr loc
1937 noCanDo n why = printForUser $
1938 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1940 breakByModule :: Module -> [String] -> GHCi ()
1941 breakByModule mod (arg1:rest)
1942 | all isDigit arg1 = do -- looks like a line number
1943 breakByModuleLine mod (read arg1) rest
1947 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1948 breakByModuleLine mod line args
1949 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1950 | [col] <- args, all isDigit col =
1951 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1952 | otherwise = breakSyntax
1955 breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1957 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1958 findBreakAndSet mod lookupTickTree = do
1959 tickArray <- getTickArray mod
1960 (breakArray, _) <- getModBreak mod
1961 case lookupTickTree tickArray of
1962 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1963 Just (tick, span) -> do
1964 success <- io $ setBreakFlag True breakArray tick
1968 recordBreak $ BreakLocation
1975 text "Breakpoint " <> ppr nm <>
1977 then text " was already set at " <> ppr span
1978 else text " activated at " <> ppr span
1980 printForUser $ text "Breakpoint could not be activated at"
1983 -- When a line number is specified, the current policy for choosing
1984 -- the best breakpoint is this:
1985 -- - the leftmost complete subexpression on the specified line, or
1986 -- - the leftmost subexpression starting on the specified line, or
1987 -- - the rightmost subexpression enclosing the specified line
1989 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1990 findBreakByLine line arr
1991 | not (inRange (bounds arr) line) = Nothing
1993 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
1994 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
1995 listToMaybe (sortBy (rightmost `on` snd) ticks)
1999 starts_here = [ tick | tick@(_,span) <- ticks,
2000 GHC.srcSpanStartLine span == line ]
2002 (complete,incomplete) = partition ends_here starts_here
2003 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2005 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2006 -> Maybe (BreakIndex,SrcSpan)
2007 findBreakByCoord mb_file (line, col) arr
2008 | not (inRange (bounds arr) line) = Nothing
2010 listToMaybe (sortBy (rightmost `on` snd) contains ++
2011 sortBy (leftmost_smallest `on` snd) after_here)
2015 -- the ticks that span this coordinate
2016 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2017 is_correct_file span ]
2019 is_correct_file span
2020 | Just f <- mb_file = GHC.srcSpanFile span == f
2023 after_here = [ tick | tick@(_,span) <- ticks,
2024 GHC.srcSpanStartLine span == line,
2025 GHC.srcSpanStartCol span >= col ]
2027 -- For now, use ANSI bold on terminals that we know support it.
2028 -- Otherwise, we add a line of carets under the active expression instead.
2029 -- In particular, on Windows and when running the testsuite (which sets
2030 -- TERM to vt100 for other reasons) we get carets.
2031 -- We really ought to use a proper termcap/terminfo library.
2033 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2034 where mTerm = System.Environment.getEnv "TERM"
2035 `catchIO` \_ -> return "TERM not set"
2037 start_bold :: String
2038 start_bold = "\ESC[1m"
2040 end_bold = "\ESC[0m"
2042 listCmd :: String -> InputT GHCi ()
2044 mb_span <- lift getCurrentBreakSpan
2047 printForUser' $ text "Not stopped at a breakpoint; nothing to list"
2049 | GHC.isGoodSrcSpan span -> listAround span True
2051 do resumes <- GHC.getResumeContext
2053 [] -> panic "No resumes"
2055 do let traceIt = case GHC.resumeHistory r of
2056 [] -> text "rerunning with :trace,"
2058 doWhat = traceIt <+> text ":back then :list"
2059 printForUser' (text "Unable to list source for" <+>
2061 $$ text "Try" <+> doWhat)
2062 listCmd str = list2 (words str)
2064 list2 :: [String] -> InputT GHCi ()
2065 list2 [arg] | all isDigit arg = do
2066 (toplevel, _) <- GHC.getContext
2068 [] -> outputStrLn "No module to list"
2069 (mod : _) -> listModuleLine mod (read arg)
2070 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2071 mod <- wantInterpretedModule arg1
2072 listModuleLine mod (read arg2)
2074 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2075 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2076 if GHC.isGoodSrcLoc loc
2078 tickArray <- ASSERT( isExternalName name )
2079 lift $ getTickArray (GHC.nameModule name)
2080 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2081 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2084 Nothing -> listAround (GHC.srcLocSpan loc) False
2085 Just (_,span) -> listAround span False
2087 noCanDo name $ text "can't find its location: " <>
2090 noCanDo n why = printForUser' $
2091 text "cannot list source code for " <> ppr n <> text ": " <> why
2093 outputStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2095 listModuleLine :: Module -> Int -> InputT GHCi ()
2096 listModuleLine modl line = do
2097 graph <- GHC.getModuleGraph
2098 let this = filter ((== modl) . GHC.ms_mod) graph
2100 [] -> panic "listModuleLine"
2102 let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
2103 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2104 listAround (GHC.srcLocSpan loc) False
2106 -- | list a section of a source file around a particular SrcSpan.
2107 -- If the highlight flag is True, also highlight the span using
2108 -- start_bold\/end_bold.
2110 -- GHC files are UTF-8, so we can implement this by:
2111 -- 1) read the file in as a BS and syntax highlight it as before
2112 -- 2) convert the BS to String using utf-string, and write it out.
2113 -- It would be better if we could convert directly between UTF-8 and the
2114 -- console encoding, of course.
2115 listAround :: MonadIO m => SrcSpan -> Bool -> InputT m ()
2116 listAround span do_highlight = do
2117 contents <- liftIO $ BS.readFile (unpackFS file)
2119 lines = BS.split '\n' contents
2120 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2121 drop (line1 - 1 - pad_before) $ lines
2122 fst_line = max 1 (line1 - pad_before)
2123 line_nos = [ fst_line .. ]
2125 highlighted | do_highlight = zipWith highlight line_nos these_lines
2126 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2128 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2129 prefixed = zipWith ($) highlighted bs_line_nos
2131 let output = BS.intercalate (BS.pack "\n") prefixed
2132 utf8Decoded <- liftIO $ BS.useAsCStringLen output
2133 $ \(p,n) -> utf8DecodeString (castPtr p) n
2134 outputStrLn utf8Decoded
2136 file = GHC.srcSpanFile span
2137 line1 = GHC.srcSpanStartLine span
2138 col1 = GHC.srcSpanStartCol span
2139 line2 = GHC.srcSpanEndLine span
2140 col2 = GHC.srcSpanEndCol span
2142 pad_before | line1 == 1 = 0
2146 highlight | do_bold = highlight_bold
2147 | otherwise = highlight_carets
2149 highlight_bold no line prefix
2150 | no == line1 && no == line2
2151 = let (a,r) = BS.splitAt col1 line
2152 (b,c) = BS.splitAt (col2-col1) r
2154 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2156 = let (a,b) = BS.splitAt col1 line in
2157 BS.concat [prefix, a, BS.pack start_bold, b]
2159 = let (a,b) = BS.splitAt col2 line in
2160 BS.concat [prefix, a, BS.pack end_bold, b]
2161 | otherwise = BS.concat [prefix, line]
2163 highlight_carets no line prefix
2164 | no == line1 && no == line2
2165 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2166 BS.replicate (col2-col1) '^']
2168 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2171 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2173 | otherwise = BS.concat [prefix, line]
2175 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2176 nl = BS.singleton '\n'
2178 -- --------------------------------------------------------------------------
2181 getTickArray :: Module -> GHCi TickArray
2182 getTickArray modl = do
2184 let arrmap = tickarrays st
2185 case lookupModuleEnv arrmap modl of
2186 Just arr -> return arr
2188 (_breakArray, ticks) <- getModBreak modl
2189 let arr = mkTickArray (assocs ticks)
2190 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2193 discardTickArrays :: GHCi ()
2194 discardTickArrays = do
2196 setGHCiState st{tickarrays = emptyModuleEnv}
2198 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2200 = accumArray (flip (:)) [] (1, max_line)
2201 [ (line, (nm,span)) | (nm,span) <- ticks,
2202 line <- srcSpanLines span ]
2204 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2205 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2206 GHC.srcSpanEndLine span ]
2208 lookupModule :: GHC.GhcMonad m => String -> m Module
2209 lookupModule modName
2210 = GHC.lookupModule (GHC.mkModuleName modName) Nothing
2212 -- don't reset the counter back to zero?
2213 discardActiveBreakPoints :: GHCi ()
2214 discardActiveBreakPoints = do
2216 mapM (turnOffBreak.snd) (breaks st)
2217 setGHCiState $ st { breaks = [] }
2219 deleteBreak :: Int -> GHCi ()
2220 deleteBreak identity = do
2222 let oldLocations = breaks st
2223 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2225 then printForUser (text "Breakpoint" <+> ppr identity <+>
2226 text "does not exist")
2228 mapM (turnOffBreak.snd) this
2229 setGHCiState $ st { breaks = rest }
2231 turnOffBreak :: BreakLocation -> GHCi Bool
2232 turnOffBreak loc = do
2233 (arr, _) <- getModBreak (breakModule loc)
2234 io $ setBreakFlag False arr (breakTick loc)
2236 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2237 getModBreak mod = do
2238 Just mod_info <- GHC.getModuleInfo mod
2239 let modBreaks = GHC.modInfoModBreaks mod_info
2240 let array = GHC.modBreaks_flags modBreaks
2241 let ticks = GHC.modBreaks_locs modBreaks
2242 return (array, ticks)
2244 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2245 setBreakFlag toggle array index
2246 | toggle = GHC.setBreakOn array index
2247 | otherwise = GHC.setBreakOff array index