ghc: allow --show-options and --interactive together
[ghc.git] / ghc / InteractiveUI.hs
1 {-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, TupleSections #-}
2 {-# OPTIONS -fno-cse #-}
3 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
4
5 -----------------------------------------------------------------------------
6 --
7 -- GHC Interactive User Interface
8 --
9 -- (c) The GHC Team 2005-2006
10 --
11 -----------------------------------------------------------------------------
12
13 module InteractiveUI (
14 interactiveUI,
15 GhciSettings(..),
16 defaultGhciSettings,
17 ghciCommands,
18 ghciWelcomeMsg
19 ) where
20
21 #include "HsVersions.h"
22
23 -- GHCi
24 import qualified GhciMonad ( args, runStmt )
25 import GhciMonad hiding ( args, runStmt )
26 import GhciTags
27 import Debugger
28
29 -- The GHC interface
30 import DynFlags
31 import ErrUtils
32 import GhcMonad ( modifySession )
33 import qualified GHC
34 import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..),
35 TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,
36 handleSourceError )
37 import HsImpExp
38 import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,
39 setInteractivePrintName )
40 import Module
41 import Name
42 import Packages ( trusted, getPackageDetails, listVisibleModuleNames, pprFlag )
43 import PprTyThing
44 import RdrName ( getGRE_NameQualifier_maybes )
45 import SrcLoc
46 import qualified Lexer
47
48 import StringBuffer
49 import Outputable hiding ( printForUser, printForUserPartWay, bold )
50
51 -- Other random utilities
52 import BasicTypes hiding ( isTopLevel )
53 import Config
54 import Digraph
55 import Encoding
56 import FastString
57 import Linker
58 import Maybes ( orElse, expectJust )
59 import NameSet
60 import Panic hiding ( showException )
61 import Util
62
63 -- Haskell Libraries
64 import System.Console.Haskeline as Haskeline
65
66 import Control.Monad as Monad
67
68 import Control.Applicative hiding (empty)
69 import Control.Monad.Trans.Class
70 import Control.Monad.IO.Class
71
72 import Data.Array
73 import qualified Data.ByteString.Char8 as BS
74 import Data.Char
75 import Data.Function
76 import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )
77 import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,
78 partition, sort, sortBy )
79 import Data.Maybe
80
81 import Exception hiding (catch)
82
83 import Foreign.C
84 #if __GLASGOW_HASKELL__ >= 709
85 import Foreign
86 #else
87 import Foreign.Safe
88 #endif
89
90 import System.Directory
91 import System.Environment
92 import System.Exit ( exitWith, ExitCode(..) )
93 import System.FilePath
94 import System.IO
95 import System.IO.Error
96 import System.IO.Unsafe ( unsafePerformIO )
97 import System.Process
98 import Text.Printf
99 import Text.Read ( readMaybe )
100
101 #ifndef mingw32_HOST_OS
102 import System.Posix hiding ( getEnv )
103 #else
104 import qualified System.Win32
105 #endif
106
107 import GHC.Exts ( unsafeCoerce# )
108 import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
109 import GHC.IO.Handle ( hFlushAll )
110 import GHC.TopHandler ( topHandler )
111
112 -----------------------------------------------------------------------------
113
114 data GhciSettings = GhciSettings {
115 availableCommands :: [Command],
116 shortHelpText :: String,
117 fullHelpText :: String,
118 defPrompt :: String,
119 defPrompt2 :: String
120 }
121
122 defaultGhciSettings :: GhciSettings
123 defaultGhciSettings =
124 GhciSettings {
125 availableCommands = ghciCommands,
126 shortHelpText = defShortHelpText,
127 fullHelpText = defFullHelpText,
128 defPrompt = default_prompt,
129 defPrompt2 = default_prompt2
130 }
131
132 ghciWelcomeMsg :: String
133 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
134 ": http://www.haskell.org/ghc/ :? for help"
135
136 cmdName :: Command -> String
137 cmdName (n,_,_) = n
138
139 GLOBAL_VAR(macros_ref, [], [Command])
140
141 ghciCommands :: [Command]
142 ghciCommands = [
143 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
144 ("?", keepGoing help, noCompletion),
145 ("add", keepGoingPaths addModule, completeFilename),
146 ("abandon", keepGoing abandonCmd, noCompletion),
147 ("break", keepGoing breakCmd, completeIdentifier),
148 ("back", keepGoing backCmd, noCompletion),
149 ("browse", keepGoing' (browseCmd False), completeModule),
150 ("browse!", keepGoing' (browseCmd True), completeModule),
151 ("cd", keepGoing' changeDirectory, completeFilename),
152 ("check", keepGoing' checkModule, completeHomeModule),
153 ("continue", keepGoing continueCmd, noCompletion),
154 ("complete", keepGoing completeCmd, noCompletion),
155 ("cmd", keepGoing cmdCmd, completeExpression),
156 ("ctags", keepGoing createCTagsWithLineNumbersCmd, completeFilename),
157 ("ctags!", keepGoing createCTagsWithRegExesCmd, completeFilename),
158 ("def", keepGoing (defineMacro False), completeExpression),
159 ("def!", keepGoing (defineMacro True), completeExpression),
160 ("delete", keepGoing deleteCmd, noCompletion),
161 ("edit", keepGoing' editFile, completeFilename),
162 ("etags", keepGoing createETagsFileCmd, completeFilename),
163 ("force", keepGoing forceCmd, completeExpression),
164 ("forward", keepGoing forwardCmd, noCompletion),
165 ("help", keepGoing help, noCompletion),
166 ("history", keepGoing historyCmd, noCompletion),
167 ("info", keepGoing' (info False), completeIdentifier),
168 ("info!", keepGoing' (info True), completeIdentifier),
169 ("issafe", keepGoing' isSafeCmd, completeModule),
170 ("kind", keepGoing' (kindOfType False), completeIdentifier),
171 ("kind!", keepGoing' (kindOfType True), completeIdentifier),
172 ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),
173 ("list", keepGoing' listCmd, noCompletion),
174 ("module", keepGoing moduleCmd, completeSetModule),
175 ("main", keepGoing runMain, completeFilename),
176 ("print", keepGoing printCmd, completeExpression),
177 ("quit", quit, noCompletion),
178 ("reload", keepGoing' reloadModule, noCompletion),
179 ("run", keepGoing runRun, completeFilename),
180 ("script", keepGoing' scriptCmd, completeFilename),
181 ("set", keepGoing setCmd, completeSetOptions),
182 ("seti", keepGoing setiCmd, completeSeti),
183 ("show", keepGoing showCmd, completeShowOptions),
184 ("showi", keepGoing showiCmd, completeShowiOptions),
185 ("sprint", keepGoing sprintCmd, completeExpression),
186 ("step", keepGoing stepCmd, completeIdentifier),
187 ("steplocal", keepGoing stepLocalCmd, completeIdentifier),
188 ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),
189 ("type", keepGoing' typeOfExpr, completeExpression),
190 ("trace", keepGoing traceCmd, completeExpression),
191 ("undef", keepGoing undefineMacro, completeMacro),
192 ("unset", keepGoing unsetOptions, completeSetOptions)
193 ]
194
195
196 -- We initialize readline (in the interactiveUI function) to use
197 -- word_break_chars as the default set of completion word break characters.
198 -- This can be overridden for a particular command (for example, filename
199 -- expansion shouldn't consider '/' to be a word break) by setting the third
200 -- entry in the Command tuple above.
201 --
202 -- NOTE: in order for us to override the default correctly, any custom entry
203 -- must be a SUBSET of word_break_chars.
204 word_break_chars :: String
205 word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
206 specials = "(),;[]`{}"
207 spaces = " \t\n"
208 in spaces ++ specials ++ symbols
209
210 flagWordBreakChars :: String
211 flagWordBreakChars = " \t\n"
212
213
214 keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)
215 keepGoing a str = keepGoing' (lift . a) str
216
217 keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool
218 keepGoing' a str = a str >> return False
219
220 keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
221 keepGoingPaths a str
222 = do case toArgs str of
223 Left err -> liftIO $ hPutStrLn stderr err
224 Right args -> a args
225 return False
226
227 defShortHelpText :: String
228 defShortHelpText = "use :? for help.\n"
229
230 defFullHelpText :: String
231 defFullHelpText =
232 " Commands available from the prompt:\n" ++
233 "\n" ++
234 " <statement> evaluate/run <statement>\n" ++
235 " : repeat last command\n" ++
236 " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
237 " :add [*]<module> ... add module(s) to the current target set\n" ++
238 " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
239 " (!: more details; *: all top-level names)\n" ++
240 " :cd <dir> change directory to <dir>\n" ++
241 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
242 " :complete <dom> [<rng>] <s> list completions for partial input string\n" ++
243 " :ctags[!] [<file>] create tags file for Vi (default: \"tags\")\n" ++
244 " (!: use regex instead of line number)\n" ++
245 " :def <cmd> <expr> define command :<cmd> (later defined command has\n" ++
246 " precedence, ::<cmd> is always a builtin command)\n" ++
247 " :edit <file> edit file\n" ++
248 " :edit edit last module\n" ++
249 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
250 " :help, :? display this list of commands\n" ++
251 " :info[!] [<name> ...] display information about the given names\n" ++
252 " (!: do not filter instances)\n" ++
253 " :issafe [<mod>] display safe haskell information of module <mod>\n" ++
254 " :kind[!] <type> show the kind of <type>\n" ++
255 " (!: also print the normalised type)\n" ++
256 " :load [*]<module> ... load module(s) and their dependents\n" ++
257 " :main [<arguments> ...] run the main function with the given arguments\n" ++
258 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
259 " :quit exit GHCi\n" ++
260 " :reload reload the current module set\n" ++
261 " :run function [<arguments> ...] run the function with the given arguments\n" ++
262 " :script <filename> run the script <filename>\n" ++
263 " :type <expr> show the type of <expr>\n" ++
264 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
265 " :!<command> run the shell command <command>\n" ++
266 "\n" ++
267 " -- Commands for debugging:\n" ++
268 "\n" ++
269 " :abandon at a breakpoint, abandon current computation\n" ++
270 " :back go back in the history (after :trace)\n" ++
271 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
272 " :break <name> set a breakpoint on the specified function\n" ++
273 " :continue resume after a breakpoint\n" ++
274 " :delete <number> delete the specified breakpoint\n" ++
275 " :delete * delete all breakpoints\n" ++
276 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
277 " :forward go forward in the history (after :back)\n" ++
278 " :history [<n>] after :trace, show the execution history\n" ++
279 " :list show the source code around current breakpoint\n" ++
280 " :list <identifier> show the source code for <identifier>\n" ++
281 " :list [<module>] <line> show the source code around line number <line>\n" ++
282 " :print [<name> ...] show a value without forcing its computation\n" ++
283 " :sprint [<name> ...] simplified version of :print\n" ++
284 " :step single-step after stopping at a breakpoint\n"++
285 " :step <expr> single-step into <expr>\n"++
286 " :steplocal single-step within the current top-level binding\n"++
287 " :stepmodule single-step restricted to the current module\n"++
288 " :trace trace after stopping at a breakpoint\n"++
289 " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++
290
291 "\n" ++
292 " -- Commands for changing settings:\n" ++
293 "\n" ++
294 " :set <option> ... set options\n" ++
295 " :seti <option> ... set options for interactive evaluation only\n" ++
296 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
297 " :set prog <progname> set the value returned by System.getProgName\n" ++
298 " :set prompt <prompt> set the prompt used in GHCi\n" ++
299 " :set prompt2 <prompt> set the continuation prompt used in GHCi\n" ++
300 " :set editor <cmd> set the command used for :edit\n" ++
301 " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" ++
302 " :unset <option> ... unset options\n" ++
303 "\n" ++
304 " Options for ':set' and ':unset':\n" ++
305 "\n" ++
306 " +m allow multiline commands\n" ++
307 " +r revert top-level expressions after each evaluation\n" ++
308 " +s print timing/memory stats after each evaluation\n" ++
309 " +t print type after evaluation\n" ++
310 " -<flags> most GHC command line flags can also be set here\n" ++
311 " (eg. -v2, -XFlexibleInstances, etc.)\n" ++
312 " for GHCi-specific flags, see User's Guide,\n"++
313 " Flag reference, Interactive-mode options\n" ++
314 "\n" ++
315 " -- Commands for displaying information:\n" ++
316 "\n" ++
317 " :show bindings show the current bindings made at the prompt\n" ++
318 " :show breaks show the active breakpoints\n" ++
319 " :show context show the breakpoint context\n" ++
320 " :show imports show the current imports\n" ++
321 " :show linker show current linker state\n" ++
322 " :show modules show the currently loaded modules\n" ++
323 " :show packages show the currently active package flags\n" ++
324 " :show paths show the currently active search paths\n" ++
325 " :show language show the currently active language flags\n" ++
326 " :show <setting> show value of <setting>, which is one of\n" ++
327 " [args, prog, prompt, editor, stop]\n" ++
328 " :showi language show language flags for interactive evaluation\n" ++
329 "\n"
330
331 findEditor :: IO String
332 findEditor = do
333 getEnv "EDITOR"
334 `catchIO` \_ -> do
335 #if mingw32_HOST_OS
336 win <- System.Win32.getWindowsDirectory
337 return (win </> "notepad.exe")
338 #else
339 return ""
340 #endif
341
342 foreign import ccall unsafe "rts_isProfiled" isProfiled :: IO CInt
343
344 default_progname, default_prompt, default_prompt2, default_stop :: String
345 default_progname = "<interactive>"
346 default_prompt = "%s> "
347 default_prompt2 = "%s| "
348 default_stop = ""
349
350 default_args :: [String]
351 default_args = []
352
353 interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]
354 -> Ghc ()
355 interactiveUI config srcs maybe_exprs = do
356 -- although GHCi compiles with -prof, it is not usable: the byte-code
357 -- compiler and interpreter don't work with profiling. So we check for
358 -- this up front and emit a helpful error message (#2197)
359 i <- liftIO $ isProfiled
360 when (i /= 0) $
361 throwGhcException (InstallationError "GHCi cannot be used when compiled with -prof")
362
363 -- HACK! If we happen to get into an infinite loop (eg the user
364 -- types 'let x=x in x' at the prompt), then the thread will block
365 -- on a blackhole, and become unreachable during GC. The GC will
366 -- detect that it is unreachable and send it the NonTermination
367 -- exception. However, since the thread is unreachable, everything
368 -- it refers to might be finalized, including the standard Handles.
369 -- This sounds like a bug, but we don't have a good solution right
370 -- now.
371 _ <- liftIO $ newStablePtr stdin
372 _ <- liftIO $ newStablePtr stdout
373 _ <- liftIO $ newStablePtr stderr
374
375 -- Initialise buffering for the *interpreted* I/O system
376 initInterpBuffering
377
378 -- The initial set of DynFlags used for interactive evaluation is the same
379 -- as the global DynFlags, plus -XExtendedDefaultRules and
380 -- -XNoMonomorphismRestriction.
381 dflags <- getDynFlags
382 let dflags' = (`xopt_set` Opt_ExtendedDefaultRules)
383 . (`xopt_unset` Opt_MonomorphismRestriction)
384 $ dflags
385 GHC.setInteractiveDynFlags dflags'
386
387 lastErrLocationsRef <- liftIO $ newIORef []
388 progDynFlags <- GHC.getProgramDynFlags
389 _ <- GHC.setProgramDynFlags $
390 progDynFlags { log_action = ghciLogAction lastErrLocationsRef }
391
392 liftIO $ when (isNothing maybe_exprs) $ do
393 -- Only for GHCi (not runghc and ghc -e):
394
395 -- Turn buffering off for the compiled program's stdout/stderr
396 turnOffBuffering
397 -- Turn buffering off for GHCi's stdout
398 hFlush stdout
399 hSetBuffering stdout NoBuffering
400 -- We don't want the cmd line to buffer any input that might be
401 -- intended for the program, so unbuffer stdin.
402 hSetBuffering stdin NoBuffering
403 hSetBuffering stderr NoBuffering
404 #if defined(mingw32_HOST_OS)
405 -- On Unix, stdin will use the locale encoding. The IO library
406 -- doesn't do this on Windows (yet), so for now we use UTF-8,
407 -- for consistency with GHC 6.10 and to make the tests work.
408 hSetEncoding stdin utf8
409 #endif
410
411 default_editor <- liftIO $ findEditor
412 startGHCi (runGHCi srcs maybe_exprs)
413 GHCiState{ progname = default_progname,
414 GhciMonad.args = default_args,
415 prompt = defPrompt config,
416 prompt2 = defPrompt2 config,
417 stop = default_stop,
418 editor = default_editor,
419 options = [],
420 line_number = 1,
421 break_ctr = 0,
422 breaks = [],
423 tickarrays = emptyModuleEnv,
424 ghci_commands = availableCommands config,
425 last_command = Nothing,
426 cmdqueue = [],
427 remembered_ctx = [],
428 transient_ctx = [],
429 ghc_e = isJust maybe_exprs,
430 short_help = shortHelpText config,
431 long_help = fullHelpText config,
432 lastErrorLocations = lastErrLocationsRef
433 }
434
435 return ()
436
437 resetLastErrorLocations :: GHCi ()
438 resetLastErrorLocations = do
439 st <- getGHCiState
440 liftIO $ writeIORef (lastErrorLocations st) []
441
442 ghciLogAction :: IORef [(FastString, Int)] -> LogAction
443 ghciLogAction lastErrLocations dflags severity srcSpan style msg = do
444 defaultLogAction dflags severity srcSpan style msg
445 case severity of
446 SevError -> case srcSpan of
447 RealSrcSpan rsp -> modifyIORef lastErrLocations
448 (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])
449 _ -> return ()
450 _ -> return ()
451
452 withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
453 withGhcAppData right left = do
454 either_dir <- tryIO (getAppUserDataDirectory "ghc")
455 case either_dir of
456 Right dir ->
457 do createDirectoryIfMissing False dir `catchIO` \_ -> return ()
458 right dir
459 _ -> left
460
461 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
462 runGHCi paths maybe_exprs = do
463 dflags <- getDynFlags
464 let
465 read_dot_files = not (gopt Opt_IgnoreDotGhci dflags)
466
467 current_dir = return (Just ".ghci")
468
469 app_user_dir = liftIO $ withGhcAppData
470 (\dir -> return (Just (dir </> "ghci.conf")))
471 (return Nothing)
472
473 home_dir = do
474 either_dir <- liftIO $ tryIO (getEnv "HOME")
475 case either_dir of
476 Right home -> return (Just (home </> ".ghci"))
477 _ -> return Nothing
478
479 canonicalizePath' :: FilePath -> IO (Maybe FilePath)
480 canonicalizePath' fp = liftM Just (canonicalizePath fp)
481 `catchIO` \_ -> return Nothing
482
483 sourceConfigFile :: (FilePath, Bool) -> GHCi ()
484 sourceConfigFile (file, check_perms) = do
485 exists <- liftIO $ doesFileExist file
486 when exists $ do
487 perms_ok <-
488 if not check_perms
489 then return True
490 else do
491 dir_ok <- liftIO $ checkPerms (getDirectory file)
492 file_ok <- liftIO $ checkPerms file
493 return (dir_ok && file_ok)
494 when perms_ok $ do
495 either_hdl <- liftIO $ tryIO (openFile file ReadMode)
496 case either_hdl of
497 Left _e -> return ()
498 -- NOTE: this assumes that runInputT won't affect the terminal;
499 -- can we assume this will always be the case?
500 -- This would be a good place for runFileInputT.
501 Right hdl ->
502 do runInputTWithPrefs defaultPrefs defaultSettings $
503 runCommands $ fileLoop hdl
504 liftIO (hClose hdl `catchIO` \_ -> return ())
505 where
506 getDirectory f = case takeDirectory f of "" -> "."; d -> d
507 --
508
509 setGHCContextFromGHCiState
510
511 when (read_dot_files) $ do
512 mcfgs0 <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]
513 let mcfgs1 = zip mcfgs0 (repeat True)
514 ++ zip (ghciScripts dflags) (repeat False)
515 -- False says "don't check permissions". We don't
516 -- require that a script explicitly added by
517 -- -ghci-script is owned by the current user. (#6017)
518 mcfgs <- liftIO $ mapM (\(f, b) -> (,b) <$> canonicalizePath' f) mcfgs1
519 mapM_ sourceConfigFile $ nub $ [ (f,b) | (Just f, b) <- mcfgs ]
520 -- nub, because we don't want to read .ghci twice if the
521 -- CWD is $HOME.
522
523 -- Perform a :load for files given on the GHCi command line
524 -- When in -e mode, if the load fails then we want to stop
525 -- immediately rather than going on to evaluate the expression.
526 when (not (null paths)) $ do
527 ok <- ghciHandle (\e -> do showException e; return Failed) $
528 -- TODO: this is a hack.
529 runInputTWithPrefs defaultPrefs defaultSettings $
530 loadModule paths
531 when (isJust maybe_exprs && failed ok) $
532 liftIO (exitWith (ExitFailure 1))
533
534 installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)
535
536 -- if verbosity is greater than 0, or we are connected to a
537 -- terminal, display the prompt in the interactive loop.
538 is_tty <- liftIO (hIsTerminalDevice stdin)
539 let show_prompt = verbosity dflags > 0 || is_tty
540
541 -- reset line number
542 getGHCiState >>= \st -> setGHCiState st{line_number=1}
543
544 case maybe_exprs of
545 Nothing ->
546 do
547 -- enter the interactive loop
548 runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
549 Just exprs -> do
550 -- just evaluate the expression we were given
551 enqueueCommands exprs
552 let hdle e = do st <- getGHCiState
553 -- flush the interpreter's stdout/stderr on exit (#3890)
554 flushInterpBuffers
555 -- Jump through some hoops to get the
556 -- current progname in the exception text:
557 -- <progname>: <exception>
558 liftIO $ withProgName (progname st)
559 $ topHandler e
560 -- this used to be topHandlerFastExit, see #2228
561 runInputTWithPrefs defaultPrefs defaultSettings $ do
562 -- make `ghc -e` exit nonzero on invalid input, see Trac #7962
563 runCommands' hdle (Just $ hdle (toException $ ExitFailure 1) >> return ()) (return Nothing)
564
565 -- and finally, exit
566 liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
567
568 runGHCiInput :: InputT GHCi a -> GHCi a
569 runGHCiInput f = do
570 dflags <- getDynFlags
571 histFile <- if gopt Opt_GhciHistory dflags
572 then liftIO $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
573 (return Nothing)
574 else return Nothing
575 runInputT
576 (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})
577 f
578
579 -- | How to get the next input line from the user
580 nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
581 nextInputLine show_prompt is_tty
582 | is_tty = do
583 prmpt <- if show_prompt then lift mkPrompt else return ""
584 r <- getInputLine prmpt
585 incrementLineNo
586 return r
587 | otherwise = do
588 when show_prompt $ lift mkPrompt >>= liftIO . putStr
589 fileLoop stdin
590
591 -- NOTE: We only read .ghci files if they are owned by the current user,
592 -- and aren't world writable (files owned by root are ok, see #9324).
593 -- Otherwise, we could be accidentally running code planted by
594 -- a malicious third party.
595
596 -- Furthermore, We only read ./.ghci if . is owned by the current user
597 -- and isn't writable by anyone else. I think this is sufficient: we
598 -- don't need to check .. and ../.. etc. because "." always refers to
599 -- the same directory while a process is running.
600
601 checkPerms :: String -> IO Bool
602 #ifdef mingw32_HOST_OS
603 checkPerms _ = return True
604 #else
605 checkPerms name =
606 handleIO (\_ -> return False) $ do
607 st <- getFileStatus name
608 me <- getRealUserID
609 let mode = System.Posix.fileMode st
610 ok = (fileOwner st == me || fileOwner st == 0) &&
611 groupWriteMode /= mode `intersectFileModes` groupWriteMode &&
612 otherWriteMode /= mode `intersectFileModes` otherWriteMode
613 unless ok $
614 putStrLn $ "*** WARNING: " ++ name ++
615 " is writable by someone else, IGNORING!"
616 return ok
617 #endif
618
619 incrementLineNo :: InputT GHCi ()
620 incrementLineNo = do
621 st <- lift $ getGHCiState
622 let ln = 1+(line_number st)
623 lift $ setGHCiState st{line_number=ln}
624
625 fileLoop :: Handle -> InputT GHCi (Maybe String)
626 fileLoop hdl = do
627 l <- liftIO $ tryIO $ hGetLine hdl
628 case l of
629 Left e | isEOFError e -> return Nothing
630 | -- as we share stdin with the program, the program
631 -- might have already closed it, so we might get a
632 -- handle-closed exception. We therefore catch that
633 -- too.
634 isIllegalOperation e -> return Nothing
635 | InvalidArgument <- etype -> return Nothing
636 | otherwise -> liftIO $ ioError e
637 where etype = ioeGetErrorType e
638 -- treat InvalidArgument in the same way as EOF:
639 -- this can happen if the user closed stdin, or
640 -- perhaps did getContents which closes stdin at
641 -- EOF.
642 Right l' -> do
643 incrementLineNo
644 return (Just l')
645
646 mkPrompt :: GHCi String
647 mkPrompt = do
648 st <- getGHCiState
649 imports <- GHC.getContext
650 resumes <- GHC.getResumeContext
651
652 context_bit <-
653 case resumes of
654 [] -> return empty
655 r:_ -> do
656 let ix = GHC.resumeHistoryIx r
657 if ix == 0
658 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
659 else do
660 let hist = GHC.resumeHistory r !! (ix-1)
661 pan <- GHC.getHistorySpan hist
662 return (brackets (ppr (negate ix) <> char ':'
663 <+> ppr pan) <> space)
664 let
665 dots | _:rs <- resumes, not (null rs) = text "... "
666 | otherwise = empty
667
668 rev_imports = reverse imports -- rightmost are the most recent
669 modules_bit =
670 hsep [ char '*' <> ppr m | IIModule m <- rev_imports ] <+>
671 hsep (map ppr [ myIdeclName d | IIDecl d <- rev_imports ])
672
673 -- use the 'as' name if there is one
674 myIdeclName d | Just m <- ideclAs d = m
675 | otherwise = unLoc (ideclName d)
676
677 deflt_prompt = dots <> context_bit <> modules_bit
678
679 f ('%':'l':xs) = ppr (1 + line_number st) <> f xs
680 f ('%':'s':xs) = deflt_prompt <> f xs
681 f ('%':'%':xs) = char '%' <> f xs
682 f (x:xs) = char x <> f xs
683 f [] = empty
684
685 dflags <- getDynFlags
686 return (showSDoc dflags (f (prompt st)))
687
688
689 queryQueue :: GHCi (Maybe String)
690 queryQueue = do
691 st <- getGHCiState
692 case cmdqueue st of
693 [] -> return Nothing
694 c:cs -> do setGHCiState st{ cmdqueue = cs }
695 return (Just c)
696
697 -- Reconfigurable pretty-printing Ticket #5461
698 installInteractivePrint :: Maybe String -> Bool -> GHCi ()
699 installInteractivePrint Nothing _ = return ()
700 installInteractivePrint (Just ipFun) exprmode = do
701 ok <- trySuccess $ do
702 (name:_) <- GHC.parseName ipFun
703 modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name
704 in he{hsc_IC = new_ic})
705 return Succeeded
706
707 when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1))
708
709 -- | The main read-eval-print loop
710 runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
711 runCommands = runCommands' handler Nothing
712
713 runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler
714 -> Maybe (GHCi ()) -- ^ Source error handler
715 -> InputT GHCi (Maybe String) -> InputT GHCi ()
716 runCommands' eh sourceErrorHandler gCmd = do
717 b <- ghandle (\e -> case fromException e of
718 Just UserInterrupt -> return $ Just False
719 _ -> case fromException e of
720 Just ghce ->
721 do liftIO (print (ghce :: GhcException))
722 return Nothing
723 _other ->
724 liftIO (Exception.throwIO e))
725 (runOneCommand eh gCmd)
726 case b of
727 Nothing -> return ()
728 Just success -> do
729 when (not success) $ maybe (return ()) lift sourceErrorHandler
730 runCommands' eh sourceErrorHandler gCmd
731
732 -- | Evaluate a single line of user input (either :<command> or Haskell code)
733 runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
734 -> InputT GHCi (Maybe Bool)
735 runOneCommand eh gCmd = do
736 -- run a previously queued command if there is one, otherwise get new
737 -- input from user
738 mb_cmd0 <- noSpace (lift queryQueue)
739 mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0
740 case mb_cmd1 of
741 Nothing -> return Nothing
742 Just c -> ghciHandle (\e -> lift $ eh e >>= return . Just) $
743 handleSourceError printErrorAndKeepGoing
744 (doCommand c)
745 -- source error's are handled by runStmt
746 -- is the handler necessary here?
747 where
748 printErrorAndKeepGoing err = do
749 GHC.printException err
750 return $ Just True
751
752 noSpace q = q >>= maybe (return Nothing)
753 (\c -> case removeSpaces c of
754 "" -> noSpace q
755 ":{" -> multiLineCmd q
756 _ -> return (Just c) )
757 multiLineCmd q = do
758 st <- lift getGHCiState
759 let p = prompt st
760 lift $ setGHCiState st{ prompt = prompt2 st }
761 mb_cmd <- collectCommand q "" `GHC.gfinally` lift (getGHCiState >>= \st' -> setGHCiState st' { prompt = p })
762 return mb_cmd
763 -- we can't use removeSpaces for the sublines here, so
764 -- multiline commands are somewhat more brittle against
765 -- fileformat errors (such as \r in dos input on unix),
766 -- we get rid of any extra spaces for the ":}" test;
767 -- we also avoid silent failure if ":}" is not found;
768 -- and since there is no (?) valid occurrence of \r (as
769 -- opposed to its String representation, "\r") inside a
770 -- ghci command, we replace any such with ' ' (argh:-(
771 collectCommand q c = q >>=
772 maybe (liftIO (ioError collectError))
773 (\l->if removeSpaces l == ":}"
774 then return (Just c)
775 else collectCommand q (c ++ "\n" ++ map normSpace l))
776 where normSpace '\r' = ' '
777 normSpace x = x
778 -- SDM (2007-11-07): is userError the one to use here?
779 collectError = userError "unterminated multiline command :{ .. :}"
780
781 -- | Handle a line of input
782 doCommand :: String -> InputT GHCi (Maybe Bool)
783
784 -- command
785 doCommand stmt | (':' : cmd) <- removeSpaces stmt = do
786 result <- specialCommand cmd
787 case result of
788 True -> return Nothing
789 _ -> return $ Just True
790
791 -- haskell
792 doCommand stmt = do
793 -- if 'stmt' was entered via ':{' it will contain '\n's
794 let stmt_nl_cnt = length [ () | '\n' <- stmt ]
795 ml <- lift $ isOptionSet Multiline
796 if ml && stmt_nl_cnt == 0 -- don't trigger automatic multi-line mode for ':{'-multiline input
797 then do
798 fst_line_num <- lift (line_number <$> getGHCiState)
799 mb_stmt <- checkInputForLayout stmt gCmd
800 case mb_stmt of
801 Nothing -> return $ Just True
802 Just ml_stmt -> do
803 -- temporarily compensate line-number for multi-line input
804 result <- timeIt $ lift $ runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion
805 return $ Just result
806 else do -- single line input and :{-multiline input
807 last_line_num <- lift (line_number <$> getGHCiState)
808 -- reconstruct first line num from last line num and stmt
809 let fst_line_num | stmt_nl_cnt > 0 = last_line_num - (stmt_nl_cnt2 + 1)
810 | otherwise = last_line_num -- single line input
811 stmt_nl_cnt2 = length [ () | '\n' <- stmt' ]
812 stmt' = dropLeadingWhiteLines stmt -- runStmt doesn't like leading empty lines
813 -- temporarily compensate line-number for multi-line input
814 result <- timeIt $ lift $ runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion
815 return $ Just result
816
817 -- runStmt wrapper for temporarily overridden line-number
818 runStmtWithLineNum :: Int -> String -> SingleStep -> GHCi Bool
819 runStmtWithLineNum lnum stmt step = do
820 st0 <- getGHCiState
821 setGHCiState st0 { line_number = lnum }
822 result <- runStmt stmt step
823 -- restore original line_number
824 getGHCiState >>= \st -> setGHCiState st { line_number = line_number st0 }
825 return result
826
827 -- note: this is subtly different from 'unlines . dropWhile (all isSpace) . lines'
828 dropLeadingWhiteLines s | (l0,'\n':r) <- break (=='\n') s
829 , all isSpace l0 = dropLeadingWhiteLines r
830 | otherwise = s
831
832
833 -- #4316
834 -- lex the input. If there is an unclosed layout context, request input
835 checkInputForLayout :: String -> InputT GHCi (Maybe String)
836 -> InputT GHCi (Maybe String)
837 checkInputForLayout stmt getStmt = do
838 dflags' <- lift $ getDynFlags
839 let dflags = xopt_set dflags' Opt_AlternativeLayoutRule
840 st0 <- lift $ getGHCiState
841 let buf' = stringToStringBuffer stmt
842 loc = mkRealSrcLoc (fsLit (progname st0)) (line_number st0) 1
843 pstate = Lexer.mkPState dflags buf' loc
844 case Lexer.unP goToEnd pstate of
845 (Lexer.POk _ False) -> return $ Just stmt
846 _other -> do
847 st1 <- lift getGHCiState
848 let p = prompt st1
849 lift $ setGHCiState st1{ prompt = prompt2 st1 }
850 mb_stmt <- ghciHandle (\ex -> case fromException ex of
851 Just UserInterrupt -> return Nothing
852 _ -> case fromException ex of
853 Just ghce ->
854 do liftIO (print (ghce :: GhcException))
855 return Nothing
856 _other -> liftIO (Exception.throwIO ex))
857 getStmt
858 lift $ getGHCiState >>= \st' -> setGHCiState st'{ prompt = p }
859 -- the recursive call does not recycle parser state
860 -- as we use a new string buffer
861 case mb_stmt of
862 Nothing -> return Nothing
863 Just str -> if str == ""
864 then return $ Just stmt
865 else do
866 checkInputForLayout (stmt++"\n"++str) getStmt
867 where goToEnd = do
868 eof <- Lexer.nextIsEOF
869 if eof
870 then Lexer.activeContext
871 else Lexer.lexer False return >> goToEnd
872
873 enqueueCommands :: [String] -> GHCi ()
874 enqueueCommands cmds = do
875 st <- getGHCiState
876 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
877
878 -- | If we one of these strings prefixes a command, then we treat it as a decl
879 -- rather than a stmt.
880 declPrefixes :: [String]
881 declPrefixes = ["class ","data ","newtype ","type ","instance ", "deriving ",
882 "foreign ", "default ", "default("]
883
884 -- | Entry point to execute some haskell code from user
885 runStmt :: String -> SingleStep -> GHCi Bool
886 runStmt stmt step
887 -- empty
888 | null (filter (not.isSpace) stmt)
889 = return False
890
891 -- import
892 | "import " `isPrefixOf` stmt
893 = do addImportToContext stmt; return False
894
895 -- data, class, newtype...
896 | any (flip isPrefixOf stmt) declPrefixes
897 = do _ <- liftIO $ tryIO $ hFlushAll stdin
898 result <- GhciMonad.runDecls stmt
899 afterRunStmt (const True) (GHC.RunOk result)
900
901 | otherwise
902 = do -- In the new IO library, read handles buffer data even if the Handle
903 -- is set to NoBuffering. This causes problems for GHCi where there
904 -- are really two stdin Handles. So we flush any bufferred data in
905 -- GHCi's stdin Handle here (only relevant if stdin is attached to
906 -- a file, otherwise the read buffer can't be flushed).
907 _ <- liftIO $ tryIO $ hFlushAll stdin
908 m_result <- GhciMonad.runStmt stmt step
909 case m_result of
910 Nothing -> return False
911 Just result -> afterRunStmt (const True) result
912
913 -- | Clean up the GHCi environment after a statement has run
914 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
915 afterRunStmt _ (GHC.RunException e) = liftIO $ Exception.throwIO e
916 afterRunStmt step_here run_result = do
917 resumes <- GHC.getResumeContext
918 case run_result of
919 GHC.RunOk names -> do
920 show_types <- isOptionSet ShowType
921 when show_types $ printTypeOfNames names
922 GHC.RunBreak _ names mb_info
923 | isNothing mb_info ||
924 step_here (GHC.resumeSpan $ head resumes) -> do
925 mb_id_loc <- toBreakIdAndLocation mb_info
926 let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
927 if (null bCmd)
928 then printStoppedAtBreakInfo (head resumes) names
929 else enqueueCommands [bCmd]
930 -- run the command set with ":set stop <cmd>"
931 st <- getGHCiState
932 enqueueCommands [stop st]
933 return ()
934 | otherwise -> resume step_here GHC.SingleStep >>=
935 afterRunStmt step_here >> return ()
936 _ -> return ()
937
938 flushInterpBuffers
939 liftIO installSignalHandlers
940 b <- isOptionSet RevertCAFs
941 when b revertCAFs
942
943 return (case run_result of GHC.RunOk _ -> True; _ -> False)
944
945 toBreakIdAndLocation ::
946 Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
947 toBreakIdAndLocation Nothing = return Nothing
948 toBreakIdAndLocation (Just inf) = do
949 let md = GHC.breakInfo_module inf
950 nm = GHC.breakInfo_number inf
951 st <- getGHCiState
952 return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
953 breakModule loc == md,
954 breakTick loc == nm ]
955
956 printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
957 printStoppedAtBreakInfo res names = do
958 printForUser $ ptext (sLit "Stopped at") <+>
959 ppr (GHC.resumeSpan res)
960 -- printTypeOfNames session names
961 let namesSorted = sortBy compareNames names
962 tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
963 docs <- mapM pprTypeAndContents [i | AnId i <- tythings]
964 printForUserPartWay $ vcat docs
965
966 printTypeOfNames :: [Name] -> GHCi ()
967 printTypeOfNames names
968 = mapM_ (printTypeOfName ) $ sortBy compareNames names
969
970 compareNames :: Name -> Name -> Ordering
971 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
972 where compareWith n = (getOccString n, getSrcSpan n)
973
974 printTypeOfName :: Name -> GHCi ()
975 printTypeOfName n
976 = do maybe_tything <- GHC.lookupName n
977 case maybe_tything of
978 Nothing -> return ()
979 Just thing -> printTyThing thing
980
981
982 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
983
984 -- | Entry point for execution a ':<command>' input from user
985 specialCommand :: String -> InputT GHCi Bool
986 specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
987 specialCommand str = do
988 let (cmd,rest) = break isSpace str
989 maybe_cmd <- lift $ lookupCommand cmd
990 htxt <- lift $ short_help `fmap` getGHCiState
991 case maybe_cmd of
992 GotCommand (_,f,_) -> f (dropWhile isSpace rest)
993 BadCommand ->
994 do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
995 ++ htxt)
996 return False
997 NoLastCommand ->
998 do liftIO $ hPutStr stdout ("there is no last command to perform\n"
999 ++ htxt)
1000 return False
1001
1002 shellEscape :: String -> GHCi Bool
1003 shellEscape str = liftIO (system str >> return False)
1004
1005 lookupCommand :: String -> GHCi (MaybeCommand)
1006 lookupCommand "" = do
1007 st <- getGHCiState
1008 case last_command st of
1009 Just c -> return $ GotCommand c
1010 Nothing -> return NoLastCommand
1011 lookupCommand str = do
1012 mc <- lookupCommand' str
1013 st <- getGHCiState
1014 setGHCiState st{ last_command = mc }
1015 return $ case mc of
1016 Just c -> GotCommand c
1017 Nothing -> BadCommand
1018
1019 lookupCommand' :: String -> GHCi (Maybe Command)
1020 lookupCommand' ":" = return Nothing
1021 lookupCommand' str' = do
1022 macros <- liftIO $ readIORef macros_ref
1023 ghci_cmds <- ghci_commands `fmap` getGHCiState
1024 let (str, xcmds) = case str' of
1025 ':' : rest -> (rest, []) -- "::" selects a builtin command
1026 _ -> (str', macros) -- otherwise include macros in lookup
1027
1028 lookupExact s = find $ (s ==) . cmdName
1029 lookupPrefix s = find $ (s `isPrefixOf`) . cmdName
1030
1031 builtinPfxMatch = lookupPrefix str ghci_cmds
1032
1033 -- first, look for exact match (while preferring macros); then, look
1034 -- for first prefix match (preferring builtins), *unless* a macro
1035 -- overrides the builtin; see #8305 for motivation
1036 return $ lookupExact str xcmds <|>
1037 lookupExact str ghci_cmds <|>
1038 (builtinPfxMatch >>= \c -> lookupExact (cmdName c) xcmds) <|>
1039 builtinPfxMatch <|>
1040 lookupPrefix str xcmds
1041
1042 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
1043 getCurrentBreakSpan = do
1044 resumes <- GHC.getResumeContext
1045 case resumes of
1046 [] -> return Nothing
1047 (r:_) -> do
1048 let ix = GHC.resumeHistoryIx r
1049 if ix == 0
1050 then return (Just (GHC.resumeSpan r))
1051 else do
1052 let hist = GHC.resumeHistory r !! (ix-1)
1053 pan <- GHC.getHistorySpan hist
1054 return (Just pan)
1055
1056 getCurrentBreakModule :: GHCi (Maybe Module)
1057 getCurrentBreakModule = do
1058 resumes <- GHC.getResumeContext
1059 case resumes of
1060 [] -> return Nothing
1061 (r:_) -> do
1062 let ix = GHC.resumeHistoryIx r
1063 if ix == 0
1064 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
1065 else do
1066 let hist = GHC.resumeHistory r !! (ix-1)
1067 return $ Just $ GHC.getHistoryModule hist
1068
1069 -----------------------------------------------------------------------------
1070 --
1071 -- Commands
1072 --
1073 -----------------------------------------------------------------------------
1074
1075 noArgs :: GHCi () -> String -> GHCi ()
1076 noArgs m "" = m
1077 noArgs _ _ = liftIO $ putStrLn "This command takes no arguments"
1078
1079 withSandboxOnly :: String -> GHCi () -> GHCi ()
1080 withSandboxOnly cmd this = do
1081 dflags <- getDynFlags
1082 if not (gopt Opt_GhciSandbox dflags)
1083 then printForUser (text cmd <+>
1084 ptext (sLit "is not supported with -fno-ghci-sandbox"))
1085 else this
1086
1087 -----------------------------------------------------------------------------
1088 -- :help
1089
1090 help :: String -> GHCi ()
1091 help _ = do
1092 txt <- long_help `fmap` getGHCiState
1093 liftIO $ putStr txt
1094
1095 -----------------------------------------------------------------------------
1096 -- :info
1097
1098 info :: Bool -> String -> InputT GHCi ()
1099 info _ "" = throwGhcException (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
1100 info allInfo s = handleSourceError GHC.printException $ do
1101 unqual <- GHC.getPrintUnqual
1102 dflags <- getDynFlags
1103 sdocs <- mapM (infoThing allInfo) (words s)
1104 mapM_ (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs
1105
1106 infoThing :: GHC.GhcMonad m => Bool -> String -> m SDoc
1107 infoThing allInfo str = do
1108 names <- GHC.parseName str
1109 mb_stuffs <- mapM (GHC.getInfo allInfo) names
1110 let filtered = filterOutChildren (\(t,_f,_ci,_fi) -> t) (catMaybes mb_stuffs)
1111 return $ vcat (intersperse (text "") $ map pprInfo filtered)
1112
1113 -- Filter out names whose parent is also there Good
1114 -- example is '[]', which is both a type and data
1115 -- constructor in the same type
1116 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
1117 filterOutChildren get_thing xs
1118 = filterOut has_parent xs
1119 where
1120 all_names = mkNameSet (map (getName . get_thing) xs)
1121 has_parent x = case tyThingParent_maybe (get_thing x) of
1122 Just p -> getName p `elemNameSet` all_names
1123 Nothing -> False
1124
1125 pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc
1126 pprInfo (thing, fixity, cls_insts, fam_insts)
1127 = pprTyThingInContextLoc thing
1128 $$ show_fixity
1129 $$ vcat (map GHC.pprInstance cls_insts)
1130 $$ vcat (map GHC.pprFamInst fam_insts)
1131 where
1132 show_fixity
1133 | fixity == GHC.defaultFixity = empty
1134 | otherwise = ppr fixity <+> pprInfixName (GHC.getName thing)
1135
1136 -----------------------------------------------------------------------------
1137 -- :main
1138
1139 runMain :: String -> GHCi ()
1140 runMain s = case toArgs s of
1141 Left err -> liftIO (hPutStrLn stderr err)
1142 Right args ->
1143 do dflags <- getDynFlags
1144 let main = fromMaybe "main" (mainFunIs dflags)
1145 -- Wrap the main function in 'void' to discard its value instead
1146 -- of printing it (#9086). See Haskell 2010 report Chapter 5.
1147 doWithArgs args $ "Control.Monad.void (" ++ main ++ ")"
1148
1149 -----------------------------------------------------------------------------
1150 -- :run
1151
1152 runRun :: String -> GHCi ()
1153 runRun s = case toCmdArgs s of
1154 Left err -> liftIO (hPutStrLn stderr err)
1155 Right (cmd, args) -> doWithArgs args cmd
1156
1157 doWithArgs :: [String] -> String -> GHCi ()
1158 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
1159 show args ++ " (" ++ cmd ++ ")"]
1160
1161 -----------------------------------------------------------------------------
1162 -- :cd
1163
1164 changeDirectory :: String -> InputT GHCi ()
1165 changeDirectory "" = do
1166 -- :cd on its own changes to the user's home directory
1167 either_dir <- liftIO $ tryIO getHomeDirectory
1168 case either_dir of
1169 Left _e -> return ()
1170 Right dir -> changeDirectory dir
1171 changeDirectory dir = do
1172 graph <- GHC.getModuleGraph
1173 when (not (null graph)) $
1174 liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."
1175 GHC.setTargets []
1176 _ <- GHC.load LoadAllTargets
1177 lift $ setContextAfterLoad False []
1178 GHC.workingDirectoryChanged
1179 dir' <- expandPath dir
1180 liftIO $ setCurrentDirectory dir'
1181
1182 trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
1183 trySuccess act =
1184 handleSourceError (\e -> do GHC.printException e
1185 return Failed) $ do
1186 act
1187
1188 -----------------------------------------------------------------------------
1189 -- :edit
1190
1191 editFile :: String -> InputT GHCi ()
1192 editFile str =
1193 do file <- if null str then lift chooseEditFile else expandPath str
1194 st <- lift getGHCiState
1195 errs <- liftIO $ readIORef $ lastErrorLocations st
1196 let cmd = editor st
1197 when (null cmd)
1198 $ throwGhcException (CmdLineError "editor not set, use :set editor")
1199 lineOpt <- liftIO $ do
1200 curFileErrs <- filterM (\(f, _) -> unpackFS f `sameFile` file) errs
1201 return $ case curFileErrs of
1202 (_, line):_ -> " +" ++ show line
1203 _ -> ""
1204 let cmdArgs = ' ':(file ++ lineOpt)
1205 code <- liftIO $ system (cmd ++ cmdArgs)
1206
1207 when (code == ExitSuccess)
1208 $ reloadModule ""
1209
1210 -- The user didn't specify a file so we pick one for them.
1211 -- Our strategy is to pick the first module that failed to load,
1212 -- or otherwise the first target.
1213 --
1214 -- XXX: Can we figure out what happened if the depndecy analysis fails
1215 -- (e.g., because the porgrammeer mistyped the name of a module)?
1216 -- XXX: Can we figure out the location of an error to pass to the editor?
1217 -- XXX: if we could figure out the list of errors that occured during the
1218 -- last load/reaload, then we could start the editor focused on the first
1219 -- of those.
1220 chooseEditFile :: GHCi String
1221 chooseEditFile =
1222 do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
1223
1224 graph <- GHC.getModuleGraph
1225 failed_graph <- filterM hasFailed graph
1226 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
1227 pick xs = case xs of
1228 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
1229 _ -> Nothing
1230
1231 case pick (order failed_graph) of
1232 Just file -> return file
1233 Nothing ->
1234 do targets <- GHC.getTargets
1235 case msum (map fromTarget targets) of
1236 Just file -> return file
1237 Nothing -> throwGhcException (CmdLineError "No files to edit.")
1238
1239 where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
1240 fromTarget _ = Nothing -- when would we get a module target?
1241
1242
1243 -----------------------------------------------------------------------------
1244 -- :def
1245
1246 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
1247 defineMacro _ (':':_) =
1248 liftIO $ putStrLn "macro name cannot start with a colon"
1249 defineMacro overwrite s = do
1250 let (macro_name, definition) = break isSpace s
1251 macros <- liftIO (readIORef macros_ref)
1252 let defined = map cmdName macros
1253 if (null macro_name)
1254 then if null defined
1255 then liftIO $ putStrLn "no macros defined"
1256 else liftIO $ putStr ("the following macros are defined:\n" ++
1257 unlines defined)
1258 else do
1259 if (not overwrite && macro_name `elem` defined)
1260 then throwGhcException (CmdLineError
1261 ("macro '" ++ macro_name ++ "' is already defined"))
1262 else do
1263
1264 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
1265
1266 -- give the expression a type signature, so we can be sure we're getting
1267 -- something of the right type.
1268 let new_expr = '(' : definition ++ ") :: String -> IO String"
1269
1270 -- compile the expression
1271 handleSourceError (\e -> GHC.printException e) $
1272 do
1273 hv <- GHC.compileExpr new_expr
1274 liftIO (writeIORef macros_ref -- later defined macros have precedence
1275 ((macro_name, lift . runMacro hv, noCompletion) : filtered))
1276
1277 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
1278 runMacro fun s = do
1279 str <- liftIO ((unsafeCoerce# fun :: String -> IO String) s)
1280 -- make sure we force any exceptions in the result, while we are still
1281 -- inside the exception handler for commands:
1282 seqList str (return ())
1283 enqueueCommands (lines str)
1284 return False
1285
1286
1287 -----------------------------------------------------------------------------
1288 -- :undef
1289
1290 undefineMacro :: String -> GHCi ()
1291 undefineMacro str = mapM_ undef (words str)
1292 where undef macro_name = do
1293 cmds <- liftIO (readIORef macros_ref)
1294 if (macro_name `notElem` map cmdName cmds)
1295 then throwGhcException (CmdLineError
1296 ("macro '" ++ macro_name ++ "' is not defined"))
1297 else do
1298 liftIO (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
1299
1300
1301 -----------------------------------------------------------------------------
1302 -- :cmd
1303
1304 cmdCmd :: String -> GHCi ()
1305 cmdCmd str = do
1306 let expr = '(' : str ++ ") :: IO String"
1307 handleSourceError (\e -> GHC.printException e) $
1308 do
1309 hv <- GHC.compileExpr expr
1310 cmds <- liftIO $ (unsafeCoerce# hv :: IO String)
1311 enqueueCommands (lines cmds)
1312 return ()
1313
1314
1315 -----------------------------------------------------------------------------
1316 -- :check
1317
1318 checkModule :: String -> InputT GHCi ()
1319 checkModule m = do
1320 let modl = GHC.mkModuleName m
1321 ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do
1322 r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
1323 dflags <- getDynFlags
1324 liftIO $ putStrLn $ showSDoc dflags $
1325 case GHC.moduleInfo r of
1326 cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1327 let
1328 (loc, glob) = ASSERT( all isExternalName scope )
1329 partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1330 in
1331 (text "global names: " <+> ppr glob) $$
1332 (text "local names: " <+> ppr loc)
1333 _ -> empty
1334 return True
1335 afterLoad (successIf ok) False
1336
1337
1338 -----------------------------------------------------------------------------
1339 -- :load, :add, :reload
1340
1341 loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
1342 loadModule fs = timeIt (loadModule' fs)
1343
1344 loadModule_ :: [FilePath] -> InputT GHCi ()
1345 loadModule_ fs = loadModule (zip fs (repeat Nothing)) >> return ()
1346
1347 loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
1348 loadModule' files = do
1349 let (filenames, phases) = unzip files
1350 exp_filenames <- mapM expandPath filenames
1351 let files' = zip exp_filenames phases
1352 targets <- mapM (uncurry GHC.guessTarget) files'
1353
1354 -- NOTE: we used to do the dependency anal first, so that if it
1355 -- fails we didn't throw away the current set of modules. This would
1356 -- require some re-working of the GHC interface, so we'll leave it
1357 -- as a ToDo for now.
1358
1359 -- unload first
1360 _ <- GHC.abandonAll
1361 lift discardActiveBreakPoints
1362 GHC.setTargets []
1363 _ <- GHC.load LoadAllTargets
1364
1365 GHC.setTargets targets
1366 doLoad False LoadAllTargets
1367
1368
1369 -- :add
1370 addModule :: [FilePath] -> InputT GHCi ()
1371 addModule files = do
1372 lift revertCAFs -- always revert CAFs on load/add.
1373 files' <- mapM expandPath files
1374 targets <- mapM (\m -> GHC.guessTarget m Nothing) files'
1375 -- remove old targets with the same id; e.g. for :add *M
1376 mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
1377 mapM_ GHC.addTarget targets
1378 _ <- doLoad False LoadAllTargets
1379 return ()
1380
1381
1382 -- :reload
1383 reloadModule :: String -> InputT GHCi ()
1384 reloadModule m = do
1385 _ <- doLoad True $
1386 if null m then LoadAllTargets
1387 else LoadUpTo (GHC.mkModuleName m)
1388 return ()
1389
1390
1391 doLoad :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag
1392 doLoad retain_context howmuch = do
1393 -- turn off breakpoints before we load: we can't turn them off later, because
1394 -- the ModBreaks will have gone away.
1395 lift discardActiveBreakPoints
1396
1397 lift resetLastErrorLocations
1398 -- Enable buffering stdout and stderr as we're compiling. Keeping these
1399 -- handles unbuffered will just slow the compilation down, especially when
1400 -- compiling in parallel.
1401 gbracket (liftIO $ do hSetBuffering stdout LineBuffering
1402 hSetBuffering stderr LineBuffering)
1403 (\_ ->
1404 liftIO $ do hSetBuffering stdout NoBuffering
1405 hSetBuffering stderr NoBuffering) $ \_ -> do
1406 ok <- trySuccess $ GHC.load howmuch
1407 afterLoad ok retain_context
1408 return ok
1409
1410
1411 afterLoad :: SuccessFlag
1412 -> Bool -- keep the remembered_ctx, as far as possible (:reload)
1413 -> InputT GHCi ()
1414 afterLoad ok retain_context = do
1415 lift revertCAFs -- always revert CAFs on load.
1416 lift discardTickArrays
1417 loaded_mod_summaries <- getLoadedModules
1418 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1419 modulesLoadedMsg ok loaded_mods
1420 lift $ setContextAfterLoad retain_context loaded_mod_summaries
1421
1422 setContextAfterLoad :: Bool -> [GHC.ModSummary] -> GHCi ()
1423 setContextAfterLoad keep_ctxt [] = do
1424 setContextKeepingPackageModules keep_ctxt []
1425 setContextAfterLoad keep_ctxt ms = do
1426 -- load a target if one is available, otherwise load the topmost module.
1427 targets <- GHC.getTargets
1428 case [ m | Just m <- map (findTarget ms) targets ] of
1429 [] ->
1430 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1431 load_this (last graph')
1432 (m:_) ->
1433 load_this m
1434 where
1435 findTarget mds t
1436 = case filter (`matches` t) mds of
1437 [] -> Nothing
1438 (m:_) -> Just m
1439
1440 summary `matches` Target (TargetModule m) _ _
1441 = GHC.ms_mod_name summary == m
1442 summary `matches` Target (TargetFile f _) _ _
1443 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1444 _ `matches` _
1445 = False
1446
1447 load_this summary | m <- GHC.ms_mod summary = do
1448 is_interp <- GHC.moduleIsInterpreted m
1449 dflags <- getDynFlags
1450 let star_ok = is_interp && not (safeLanguageOn dflags)
1451 -- We import the module with a * iff
1452 -- - it is interpreted, and
1453 -- - -XSafe is off (it doesn't allow *-imports)
1454 let new_ctx | star_ok = [mkIIModule (GHC.moduleName m)]
1455 | otherwise = [mkIIDecl (GHC.moduleName m)]
1456 setContextKeepingPackageModules keep_ctxt new_ctx
1457
1458
1459 -- | Keep any package modules (except Prelude) when changing the context.
1460 setContextKeepingPackageModules
1461 :: Bool -- True <=> keep all of remembered_ctx
1462 -- False <=> just keep package imports
1463 -> [InteractiveImport] -- new context
1464 -> GHCi ()
1465
1466 setContextKeepingPackageModules keep_ctx trans_ctx = do
1467
1468 st <- getGHCiState
1469 let rem_ctx = remembered_ctx st
1470 new_rem_ctx <- if keep_ctx then return rem_ctx
1471 else keepPackageImports rem_ctx
1472 setGHCiState st{ remembered_ctx = new_rem_ctx,
1473 transient_ctx = filterSubsumed new_rem_ctx trans_ctx }
1474 setGHCContextFromGHCiState
1475
1476 -- | Filters a list of 'InteractiveImport', clearing out any home package
1477 -- imports so only imports from external packages are preserved. ('IIModule'
1478 -- counts as a home package import, because we are only able to bring a
1479 -- full top-level into scope when the source is available.)
1480 keepPackageImports :: [InteractiveImport] -> GHCi [InteractiveImport]
1481 keepPackageImports = filterM is_pkg_import
1482 where
1483 is_pkg_import :: InteractiveImport -> GHCi Bool
1484 is_pkg_import (IIModule _) = return False
1485 is_pkg_import (IIDecl d)
1486 = do e <- gtry $ GHC.findModule mod_name (ideclPkgQual d)
1487 case e :: Either SomeException Module of
1488 Left _ -> return False
1489 Right m -> return (not (isHomeModule m))
1490 where
1491 mod_name = unLoc (ideclName d)
1492
1493
1494 modulesLoadedMsg :: SuccessFlag -> [Module] -> InputT GHCi ()
1495 modulesLoadedMsg ok mods = do
1496 dflags <- getDynFlags
1497 unqual <- GHC.getPrintUnqual
1498 let mod_commas
1499 | null mods = text "none."
1500 | otherwise = hsep (
1501 punctuate comma (map ppr mods)) <> text "."
1502 status = case ok of
1503 Failed -> text "Failed"
1504 Succeeded -> text "Ok"
1505
1506 msg = status <> text ", modules loaded:" <+> mod_commas
1507
1508 when (verbosity dflags > 0) $
1509 liftIO $ putStrLn $ showSDocForUser dflags unqual msg
1510
1511 -----------------------------------------------------------------------------
1512 -- :type
1513
1514 typeOfExpr :: String -> InputT GHCi ()
1515 typeOfExpr str
1516 = handleSourceError GHC.printException
1517 $ do
1518 ty <- GHC.exprType str
1519 printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser ty)]
1520
1521 -----------------------------------------------------------------------------
1522 -- :kind
1523
1524 kindOfType :: Bool -> String -> InputT GHCi ()
1525 kindOfType norm str
1526 = handleSourceError GHC.printException
1527 $ do
1528 (ty, kind) <- GHC.typeKind norm str
1529 printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind
1530 , ppWhen norm $ equals <+> pprTypeForUser ty ]
1531
1532
1533 -----------------------------------------------------------------------------
1534 -- :quit
1535
1536 quit :: String -> InputT GHCi Bool
1537 quit _ = return True
1538
1539
1540 -----------------------------------------------------------------------------
1541 -- :script
1542
1543 -- running a script file #1363
1544
1545 scriptCmd :: String -> InputT GHCi ()
1546 scriptCmd ws = do
1547 case words ws of
1548 [s] -> runScript s
1549 _ -> throwGhcException (CmdLineError "syntax: :script <filename>")
1550
1551 runScript :: String -- ^ filename
1552 -> InputT GHCi ()
1553 runScript filename = do
1554 filename' <- expandPath filename
1555 either_script <- liftIO $ tryIO (openFile filename' ReadMode)
1556 case either_script of
1557 Left _err -> throwGhcException (CmdLineError $ "IO error: \""++filename++"\" "
1558 ++(ioeGetErrorString _err))
1559 Right script -> do
1560 st <- lift $ getGHCiState
1561 let prog = progname st
1562 line = line_number st
1563 lift $ setGHCiState st{progname=filename',line_number=0}
1564 scriptLoop script
1565 liftIO $ hClose script
1566 new_st <- lift $ getGHCiState
1567 lift $ setGHCiState new_st{progname=prog,line_number=line}
1568 where scriptLoop script = do
1569 res <- runOneCommand handler $ fileLoop script
1570 case res of
1571 Nothing -> return ()
1572 Just s -> if s
1573 then scriptLoop script
1574 else return ()
1575
1576 -----------------------------------------------------------------------------
1577 -- :issafe
1578
1579 -- Displaying Safe Haskell properties of a module
1580
1581 isSafeCmd :: String -> InputT GHCi ()
1582 isSafeCmd m =
1583 case words m of
1584 [s] | looksLikeModuleName s -> do
1585 md <- lift $ lookupModule s
1586 isSafeModule md
1587 [] -> do md <- guessCurrentModule "issafe"
1588 isSafeModule md
1589 _ -> throwGhcException (CmdLineError "syntax: :issafe <module>")
1590
1591 isSafeModule :: Module -> InputT GHCi ()
1592 isSafeModule m = do
1593 mb_mod_info <- GHC.getModuleInfo m
1594 when (isNothing mb_mod_info)
1595 (throwGhcException $ CmdLineError $ "unknown module: " ++ mname)
1596
1597 dflags <- getDynFlags
1598 let iface = GHC.modInfoIface $ fromJust mb_mod_info
1599 when (isNothing iface)
1600 (throwGhcException $ CmdLineError $ "can't load interface file for module: " ++
1601 (GHC.moduleNameString $ GHC.moduleName m))
1602
1603 (msafe, pkgs) <- GHC.moduleTrustReqs m
1604 let trust = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface
1605 pkg = if packageTrusted dflags m then "trusted" else "untrusted"
1606 (good, bad) = tallyPkgs dflags pkgs
1607
1608 -- print info to user...
1609 liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")"
1610 liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off")
1611 when (not $ null good)
1612 (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++
1613 (intercalate ", " $ map (showPpr dflags) good))
1614 case msafe && null bad of
1615 True -> liftIO $ putStrLn $ mname ++ " is trusted!"
1616 False -> do
1617 when (not $ null bad)
1618 (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "
1619 ++ (intercalate ", " $ map (showPpr dflags) bad))
1620 liftIO $ putStrLn $ mname ++ " is NOT trusted!"
1621
1622 where
1623 mname = GHC.moduleNameString $ GHC.moduleName m
1624
1625 packageTrusted dflags md
1626 | thisPackage dflags == modulePackageKey md = True
1627 | otherwise = trusted $ getPackageDetails dflags (modulePackageKey md)
1628
1629 tallyPkgs dflags deps | not (packageTrustOn dflags) = ([], [])
1630 | otherwise = partition part deps
1631 where part pkg = trusted $ getPackageDetails dflags pkg
1632
1633 -----------------------------------------------------------------------------
1634 -- :browse
1635
1636 -- Browsing a module's contents
1637
1638 browseCmd :: Bool -> String -> InputT GHCi ()
1639 browseCmd bang m =
1640 case words m of
1641 ['*':s] | looksLikeModuleName s -> do
1642 md <- lift $ wantInterpretedModule s
1643 browseModule bang md False
1644 [s] | looksLikeModuleName s -> do
1645 md <- lift $ lookupModule s
1646 browseModule bang md True
1647 [] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "")
1648 browseModule bang md True
1649 _ -> throwGhcException (CmdLineError "syntax: :browse <module>")
1650
1651 guessCurrentModule :: String -> InputT GHCi Module
1652 -- Guess which module the user wants to browse. Pick
1653 -- modules that are interpreted first. The most
1654 -- recently-added module occurs last, it seems.
1655 guessCurrentModule cmd
1656 = do imports <- GHC.getContext
1657 when (null imports) $ throwGhcException $
1658 CmdLineError (':' : cmd ++ ": no current module")
1659 case (head imports) of
1660 IIModule m -> GHC.findModule m Nothing
1661 IIDecl d -> GHC.findModule (unLoc (ideclName d)) (ideclPkgQual d)
1662
1663 -- without bang, show items in context of their parents and omit children
1664 -- with bang, show class methods and data constructors separately, and
1665 -- indicate import modules, to aid qualifying unqualified names
1666 -- with sorted, sort items alphabetically
1667 browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
1668 browseModule bang modl exports_only = do
1669 -- :browse reports qualifiers wrt current context
1670 unqual <- GHC.getPrintUnqual
1671
1672 mb_mod_info <- GHC.getModuleInfo modl
1673 case mb_mod_info of
1674 Nothing -> throwGhcException (CmdLineError ("unknown module: " ++
1675 GHC.moduleNameString (GHC.moduleName modl)))
1676 Just mod_info -> do
1677 dflags <- getDynFlags
1678 let names
1679 | exports_only = GHC.modInfoExports mod_info
1680 | otherwise = GHC.modInfoTopLevelScope mod_info
1681 `orElse` []
1682
1683 -- sort alphabetically name, but putting locally-defined
1684 -- identifiers first. We would like to improve this; see #1799.
1685 sorted_names = loc_sort local ++ occ_sort external
1686 where
1687 (local,external) = ASSERT( all isExternalName names )
1688 partition ((==modl) . nameModule) names
1689 occ_sort = sortBy (compare `on` nameOccName)
1690 -- try to sort by src location. If the first name in our list
1691 -- has a good source location, then they all should.
1692 loc_sort ns
1693 | n:_ <- ns, isGoodSrcSpan (nameSrcSpan n)
1694 = sortBy (compare `on` nameSrcSpan) ns
1695 | otherwise
1696 = occ_sort ns
1697
1698 mb_things <- mapM GHC.lookupName sorted_names
1699 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1700
1701 rdr_env <- GHC.getGRE
1702
1703 let things | bang = catMaybes mb_things
1704 | otherwise = filtered_things
1705 pretty | bang = pprTyThing
1706 | otherwise = pprTyThingInContext
1707
1708 labels [] = text "-- not currently imported"
1709 labels l = text $ intercalate "\n" $ map qualifier l
1710
1711 qualifier :: Maybe [ModuleName] -> String
1712 qualifier = maybe "-- defined locally"
1713 (("-- imported via "++) . intercalate ", "
1714 . map GHC.moduleNameString)
1715 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1716
1717 modNames :: [[Maybe [ModuleName]]]
1718 modNames = map (importInfo . GHC.getName) things
1719
1720 -- annotate groups of imports with their import modules
1721 -- the default ordering is somewhat arbitrary, so we group
1722 -- by header and sort groups; the names themselves should
1723 -- really come in order of source appearance.. (trac #1799)
1724 annotate mts = concatMap (\(m,ts)->labels m:ts)
1725 $ sortBy cmpQualifiers $ grp mts
1726 where cmpQualifiers =
1727 compare `on` (map (fmap (map moduleNameFS)) . fst)
1728 grp [] = []
1729 grp mts@((m,_):_) = (m,map snd g) : grp ng
1730 where (g,ng) = partition ((==m).fst) mts
1731
1732 let prettyThings, prettyThings' :: [SDoc]
1733 prettyThings = map pretty things
1734 prettyThings' | bang = annotate $ zip modNames prettyThings
1735 | otherwise = prettyThings
1736 liftIO $ putStrLn $ showSDocForUser dflags unqual (vcat prettyThings')
1737 -- ToDo: modInfoInstances currently throws an exception for
1738 -- package modules. When it works, we can do this:
1739 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1740
1741
1742 -----------------------------------------------------------------------------
1743 -- :module
1744
1745 -- Setting the module context. For details on context handling see
1746 -- "remembered_ctx" and "transient_ctx" in GhciMonad.
1747
1748 moduleCmd :: String -> GHCi ()
1749 moduleCmd str
1750 | all sensible strs = cmd
1751 | otherwise = throwGhcException (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1752 where
1753 (cmd, strs) =
1754 case str of
1755 '+':stuff -> rest addModulesToContext stuff
1756 '-':stuff -> rest remModulesFromContext stuff
1757 stuff -> rest setContext stuff
1758
1759 rest op stuff = (op as bs, stuffs)
1760 where (as,bs) = partitionWith starred stuffs
1761 stuffs = words stuff
1762
1763 sensible ('*':m) = looksLikeModuleName m
1764 sensible m = looksLikeModuleName m
1765
1766 starred ('*':m) = Left (GHC.mkModuleName m)
1767 starred m = Right (GHC.mkModuleName m)
1768
1769
1770 -- -----------------------------------------------------------------------------
1771 -- Four ways to manipulate the context:
1772 -- (a) :module +<stuff>: addModulesToContext
1773 -- (b) :module -<stuff>: remModulesFromContext
1774 -- (c) :module <stuff>: setContext
1775 -- (d) import <module>...: addImportToContext
1776
1777 addModulesToContext :: [ModuleName] -> [ModuleName] -> GHCi ()
1778 addModulesToContext starred unstarred = restoreContextOnFailure $ do
1779 addModulesToContext_ starred unstarred
1780
1781 addModulesToContext_ :: [ModuleName] -> [ModuleName] -> GHCi ()
1782 addModulesToContext_ starred unstarred = do
1783 mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)
1784 setGHCContextFromGHCiState
1785
1786 remModulesFromContext :: [ModuleName] -> [ModuleName] -> GHCi ()
1787 remModulesFromContext starred unstarred = do
1788 -- we do *not* call restoreContextOnFailure here. If the user
1789 -- is trying to fix up a context that contains errors by removing
1790 -- modules, we don't want GHC to silently put them back in again.
1791 mapM_ rm (starred ++ unstarred)
1792 setGHCContextFromGHCiState
1793 where
1794 rm :: ModuleName -> GHCi ()
1795 rm str = do
1796 m <- moduleName <$> lookupModuleName str
1797 let filt = filter ((/=) m . iiModuleName)
1798 modifyGHCiState $ \st ->
1799 st { remembered_ctx = filt (remembered_ctx st)
1800 , transient_ctx = filt (transient_ctx st) }
1801
1802 setContext :: [ModuleName] -> [ModuleName] -> GHCi ()
1803 setContext starred unstarred = restoreContextOnFailure $ do
1804 modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] }
1805 -- delete the transient context
1806 addModulesToContext_ starred unstarred
1807
1808 addImportToContext :: String -> GHCi ()
1809 addImportToContext str = restoreContextOnFailure $ do
1810 idecl <- GHC.parseImportDecl str
1811 addII (IIDecl idecl) -- #5836
1812 setGHCContextFromGHCiState
1813
1814 -- Util used by addImportToContext and addModulesToContext
1815 addII :: InteractiveImport -> GHCi ()
1816 addII iidecl = do
1817 checkAdd iidecl
1818 modifyGHCiState $ \st ->
1819 st { remembered_ctx = addNotSubsumed iidecl (remembered_ctx st)
1820 , transient_ctx = filter (not . (iidecl `iiSubsumes`))
1821 (transient_ctx st)
1822 }
1823
1824 -- Sometimes we can't tell whether an import is valid or not until
1825 -- we finally call 'GHC.setContext'. e.g.
1826 --
1827 -- import System.IO (foo)
1828 --
1829 -- will fail because System.IO does not export foo. In this case we
1830 -- don't want to store the import in the context permanently, so we
1831 -- catch the failure from 'setGHCContextFromGHCiState' and set the
1832 -- context back to what it was.
1833 --
1834 -- See #6007
1835 --
1836 restoreContextOnFailure :: GHCi a -> GHCi a
1837 restoreContextOnFailure do_this = do
1838 st <- getGHCiState
1839 let rc = remembered_ctx st; tc = transient_ctx st
1840 do_this `gonException` (modifyGHCiState $ \st' ->
1841 st' { remembered_ctx = rc, transient_ctx = tc })
1842
1843 -- -----------------------------------------------------------------------------
1844 -- Validate a module that we want to add to the context
1845
1846 checkAdd :: InteractiveImport -> GHCi ()
1847 checkAdd ii = do
1848 dflags <- getDynFlags
1849 let safe = safeLanguageOn dflags
1850 case ii of
1851 IIModule modname
1852 | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell"
1853 | otherwise -> wantInterpretedModuleName modname >> return ()
1854
1855 IIDecl d -> do
1856 let modname = unLoc (ideclName d)
1857 pkgqual = ideclPkgQual d
1858 m <- GHC.lookupModule modname pkgqual
1859 when safe $ do
1860 t <- GHC.isModuleTrusted m
1861 when (not t) $ throwGhcException $ ProgramError $ ""
1862
1863 -- -----------------------------------------------------------------------------
1864 -- Update the GHC API's view of the context
1865
1866 -- | Sets the GHC context from the GHCi state. The GHC context is
1867 -- always set this way, we never modify it incrementally.
1868 --
1869 -- We ignore any imports for which the ModuleName does not currently
1870 -- exist. This is so that the remembered_ctx can contain imports for
1871 -- modules that are not currently loaded, perhaps because we just did
1872 -- a :reload and encountered errors.
1873 --
1874 -- Prelude is added if not already present in the list. Therefore to
1875 -- override the implicit Prelude import you can say 'import Prelude ()'
1876 -- at the prompt, just as in Haskell source.
1877 --
1878 setGHCContextFromGHCiState :: GHCi ()
1879 setGHCContextFromGHCiState = do
1880 st <- getGHCiState
1881 -- re-use checkAdd to check whether the module is valid. If the
1882 -- module does not exist, we do *not* want to print an error
1883 -- here, we just want to silently keep the module in the context
1884 -- until such time as the module reappears again. So we ignore
1885 -- the actual exception thrown by checkAdd, using tryBool to
1886 -- turn it into a Bool.
1887 iidecls <- filterM (tryBool.checkAdd) (transient_ctx st ++ remembered_ctx st)
1888 dflags <- GHC.getSessionDynFlags
1889 GHC.setContext $
1890 if xopt Opt_ImplicitPrelude dflags && not (any isPreludeImport iidecls)
1891 then iidecls ++ [implicitPreludeImport]
1892 else iidecls
1893 -- XXX put prel at the end, so that guessCurrentModule doesn't pick it up.
1894
1895
1896 -- -----------------------------------------------------------------------------
1897 -- Utils on InteractiveImport
1898
1899 mkIIModule :: ModuleName -> InteractiveImport
1900 mkIIModule = IIModule
1901
1902 mkIIDecl :: ModuleName -> InteractiveImport
1903 mkIIDecl = IIDecl . simpleImportDecl
1904
1905 iiModules :: [InteractiveImport] -> [ModuleName]
1906 iiModules is = [m | IIModule m <- is]
1907
1908 iiModuleName :: InteractiveImport -> ModuleName
1909 iiModuleName (IIModule m) = m
1910 iiModuleName (IIDecl d) = unLoc (ideclName d)
1911
1912 preludeModuleName :: ModuleName
1913 preludeModuleName = GHC.mkModuleName "Prelude"
1914
1915 implicitPreludeImport :: InteractiveImport
1916 implicitPreludeImport = IIDecl (simpleImportDecl preludeModuleName)
1917
1918 isPreludeImport :: InteractiveImport -> Bool
1919 isPreludeImport (IIModule {}) = True
1920 isPreludeImport (IIDecl d) = unLoc (ideclName d) == preludeModuleName
1921
1922 addNotSubsumed :: InteractiveImport
1923 -> [InteractiveImport] -> [InteractiveImport]
1924 addNotSubsumed i is
1925 | any (`iiSubsumes` i) is = is
1926 | otherwise = i : filter (not . (i `iiSubsumes`)) is
1927
1928 -- | @filterSubsumed is js@ returns the elements of @js@ not subsumed
1929 -- by any of @is@.
1930 filterSubsumed :: [InteractiveImport] -> [InteractiveImport]
1931 -> [InteractiveImport]
1932 filterSubsumed is js = filter (\j -> not (any (`iiSubsumes` j) is)) js
1933
1934 -- | Returns True if the left import subsumes the right one. Doesn't
1935 -- need to be 100% accurate, conservatively returning False is fine.
1936 -- (EXCEPT: (IIModule m) *must* subsume itself, otherwise a panic in
1937 -- plusProv will ensue (#5904))
1938 --
1939 -- Note that an IIModule does not necessarily subsume an IIDecl,
1940 -- because e.g. a module might export a name that is only available
1941 -- qualified within the module itself.
1942 --
1943 -- Note that 'import M' does not necessarily subsume 'import M(foo)',
1944 -- because M might not export foo and we want an error to be produced
1945 -- in that case.
1946 --
1947 iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool
1948 iiSubsumes (IIModule m1) (IIModule m2) = m1==m2
1949 iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude
1950 = unLoc (ideclName d1) == unLoc (ideclName d2)
1951 && ideclAs d1 == ideclAs d2
1952 && (not (ideclQualified d1) || ideclQualified d2)
1953 && (ideclHiding d1 `hidingSubsumes` ideclHiding d2)
1954 where
1955 _ `hidingSubsumes` Just (False,L _ []) = True
1956 Just (False, L _ xs) `hidingSubsumes` Just (False,L _ ys)
1957 = all (`elem` xs) ys
1958 h1 `hidingSubsumes` h2 = h1 == h2
1959 iiSubsumes _ _ = False
1960
1961
1962 ----------------------------------------------------------------------------
1963 -- :set
1964
1965 -- set options in the interpreter. Syntax is exactly the same as the
1966 -- ghc command line, except that certain options aren't available (-C,
1967 -- -E etc.)
1968 --
1969 -- This is pretty fragile: most options won't work as expected. ToDo:
1970 -- figure out which ones & disallow them.
1971
1972 setCmd :: String -> GHCi ()
1973 setCmd "" = showOptions False
1974 setCmd "-a" = showOptions True
1975 setCmd str
1976 = case getCmd str of
1977 Right ("args", rest) ->
1978 case toArgs rest of
1979 Left err -> liftIO (hPutStrLn stderr err)
1980 Right args -> setArgs args
1981 Right ("prog", rest) ->
1982 case toArgs rest of
1983 Right [prog] -> setProg prog
1984 _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")
1985 Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1986 Right ("prompt2", rest) -> setPrompt2 $ dropWhile isSpace rest
1987 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1988 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1989 _ -> case toArgs str of
1990 Left err -> liftIO (hPutStrLn stderr err)
1991 Right wds -> setOptions wds
1992
1993 setiCmd :: String -> GHCi ()
1994 setiCmd "" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False
1995 setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True
1996 setiCmd str =
1997 case toArgs str of
1998 Left err -> liftIO (hPutStrLn stderr err)
1999 Right wds -> newDynFlags True wds
2000
2001 showOptions :: Bool -> GHCi ()
2002 showOptions show_all
2003 = do st <- getGHCiState
2004 dflags <- getDynFlags
2005 let opts = options st
2006 liftIO $ putStrLn (showSDoc dflags (
2007 text "options currently set: " <>
2008 if null opts
2009 then text "none."
2010 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
2011 ))
2012 getDynFlags >>= liftIO . showDynFlags show_all
2013
2014
2015 showDynFlags :: Bool -> DynFlags -> IO ()
2016 showDynFlags show_all dflags = do
2017 showLanguages' show_all dflags
2018 putStrLn $ showSDoc dflags $
2019 text "GHCi-specific dynamic flag settings:" $$
2020 nest 2 (vcat (map (setting gopt) ghciFlags))
2021 putStrLn $ showSDoc dflags $
2022 text "other dynamic, non-language, flag settings:" $$
2023 nest 2 (vcat (map (setting gopt) others))
2024 putStrLn $ showSDoc dflags $
2025 text "warning settings:" $$
2026 nest 2 (vcat (map (setting wopt) DynFlags.fWarningFlags))
2027 where
2028 setting test flag
2029 | quiet = empty
2030 | is_on = fstr name
2031 | otherwise = fnostr name
2032 where name = flagSpecName flag
2033 f = flagSpecFlag flag
2034 is_on = test f dflags
2035 quiet = not show_all && test f default_dflags == is_on
2036
2037 default_dflags = defaultDynFlags (settings dflags)
2038
2039 fstr str = text "-f" <> text str
2040 fnostr str = text "-fno-" <> text str
2041
2042 (ghciFlags,others) = partition (\f -> flagSpecFlag f `elem` flgs)
2043 DynFlags.fFlags
2044 flgs = [ Opt_PrintExplicitForalls
2045 , Opt_PrintExplicitKinds
2046 , Opt_PrintBindResult
2047 , Opt_BreakOnException
2048 , Opt_BreakOnError
2049 , Opt_PrintEvldWithShow
2050 ]
2051
2052 setArgs, setOptions :: [String] -> GHCi ()
2053 setProg, setEditor, setStop :: String -> GHCi ()
2054
2055 setArgs args = do
2056 st <- getGHCiState
2057 setGHCiState st{ GhciMonad.args = args }
2058
2059 setProg prog = do
2060 st <- getGHCiState
2061 setGHCiState st{ progname = prog }
2062
2063 setEditor cmd = do
2064 st <- getGHCiState
2065 setGHCiState st{ editor = cmd }
2066
2067 setStop str@(c:_) | isDigit c
2068 = do let (nm_str,rest) = break (not.isDigit) str
2069 nm = read nm_str
2070 st <- getGHCiState
2071 let old_breaks = breaks st
2072 if all ((/= nm) . fst) old_breaks
2073 then printForUser (text "Breakpoint" <+> ppr nm <+>
2074 text "does not exist")
2075 else do
2076 let new_breaks = map fn old_breaks
2077 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
2078 | otherwise = (i,loc)
2079 setGHCiState st{ breaks = new_breaks }
2080 setStop cmd = do
2081 st <- getGHCiState
2082 setGHCiState st{ stop = cmd }
2083
2084 setPrompt :: String -> GHCi ()
2085 setPrompt = setPrompt_ f err
2086 where
2087 f v st = st { prompt = v }
2088 err st = "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
2089
2090 setPrompt2 :: String -> GHCi ()
2091 setPrompt2 = setPrompt_ f err
2092 where
2093 f v st = st { prompt2 = v }
2094 err st = "syntax: :set prompt2 <prompt>, currently \"" ++ prompt2 st ++ "\""
2095
2096 setPrompt_ :: (String -> GHCiState -> GHCiState) -> (GHCiState -> String) -> String -> GHCi ()
2097 setPrompt_ f err value = do
2098 st <- getGHCiState
2099 if null value
2100 then liftIO $ hPutStrLn stderr $ err st
2101 else case value of
2102 '\"' : _ -> case reads value of
2103 [(value', xs)] | all isSpace xs ->
2104 setGHCiState $ f value' st
2105 _ ->
2106 liftIO $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
2107 _ -> setGHCiState $ f value st
2108
2109 setOptions wds =
2110 do -- first, deal with the GHCi opts (+s, +t, etc.)
2111 let (plus_opts, minus_opts) = partitionWith isPlus wds
2112 mapM_ setOpt plus_opts
2113 -- then, dynamic flags
2114 newDynFlags False minus_opts
2115
2116 newDynFlags :: Bool -> [String] -> GHCi ()
2117 newDynFlags interactive_only minus_opts = do
2118 let lopts = map noLoc minus_opts
2119
2120 idflags0 <- GHC.getInteractiveDynFlags
2121 (idflags1, leftovers, warns) <- GHC.parseDynamicFlags idflags0 lopts
2122
2123 liftIO $ handleFlagWarnings idflags1 warns
2124 when (not $ null leftovers)
2125 (throwGhcException . CmdLineError
2126 $ "Some flags have not been recognized: "
2127 ++ (concat . intersperse ", " $ map unLoc leftovers))
2128
2129 when (interactive_only &&
2130 packageFlags idflags1 /= packageFlags idflags0) $ do
2131 liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"
2132 GHC.setInteractiveDynFlags idflags1
2133 installInteractivePrint (interactivePrint idflags1) False
2134
2135 dflags0 <- getDynFlags
2136 when (not interactive_only) $ do
2137 (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags dflags0 lopts
2138 new_pkgs <- GHC.setProgramDynFlags dflags1
2139
2140 -- if the package flags changed, reset the context and link
2141 -- the new packages.
2142 dflags2 <- getDynFlags
2143 when (packageFlags dflags2 /= packageFlags dflags0) $ do
2144 when (verbosity dflags2 > 0) $
2145 liftIO . putStrLn $
2146 "package flags have changed, resetting and loading new packages..."
2147 GHC.setTargets []
2148 _ <- GHC.load LoadAllTargets
2149 liftIO $ linkPackages dflags2 new_pkgs
2150 -- package flags changed, we can't re-use any of the old context
2151 setContextAfterLoad False []
2152 -- and copy the package state to the interactive DynFlags
2153 idflags <- GHC.getInteractiveDynFlags
2154 GHC.setInteractiveDynFlags
2155 idflags{ pkgState = pkgState dflags2
2156 , pkgDatabase = pkgDatabase dflags2
2157 , packageFlags = packageFlags dflags2 }
2158
2159 let ld0length = length $ ldInputs dflags0
2160 fmrk0length = length $ cmdlineFrameworks dflags0
2161
2162 newLdInputs = drop ld0length (ldInputs dflags2)
2163 newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2)
2164
2165 when (not (null newLdInputs && null newCLFrameworks)) $
2166 liftIO $ linkCmdLineLibs $
2167 dflags2 { ldInputs = newLdInputs
2168 , cmdlineFrameworks = newCLFrameworks }
2169
2170 return ()
2171
2172
2173 unsetOptions :: String -> GHCi ()
2174 unsetOptions str
2175 = -- first, deal with the GHCi opts (+s, +t, etc.)
2176 let opts = words str
2177 (minus_opts, rest1) = partition isMinus opts
2178 (plus_opts, rest2) = partitionWith isPlus rest1
2179 (other_opts, rest3) = partition (`elem` map fst defaulters) rest2
2180
2181 defaulters =
2182 [ ("args" , setArgs default_args)
2183 , ("prog" , setProg default_progname)
2184 , ("prompt" , setPrompt default_prompt)
2185 , ("prompt2", setPrompt2 default_prompt2)
2186 , ("editor" , liftIO findEditor >>= setEditor)
2187 , ("stop" , setStop default_stop)
2188 ]
2189
2190 no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
2191 no_flag ('-':'X':rest) = return ("-XNo" ++ rest)
2192 no_flag f = throwGhcException (ProgramError ("don't know how to reverse " ++ f))
2193
2194 in if (not (null rest3))
2195 then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))
2196 else do
2197 mapM_ (fromJust.flip lookup defaulters) other_opts
2198
2199 mapM_ unsetOpt plus_opts
2200
2201 no_flags <- mapM no_flag minus_opts
2202 newDynFlags False no_flags
2203
2204 isMinus :: String -> Bool
2205 isMinus ('-':_) = True
2206 isMinus _ = False
2207
2208 isPlus :: String -> Either String String
2209 isPlus ('+':opt) = Left opt
2210 isPlus other = Right other
2211
2212 setOpt, unsetOpt :: String -> GHCi ()
2213
2214 setOpt str
2215 = case strToGHCiOpt str of
2216 Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
2217 Just o -> setOption o
2218
2219 unsetOpt str
2220 = case strToGHCiOpt str of
2221 Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
2222 Just o -> unsetOption o
2223
2224 strToGHCiOpt :: String -> (Maybe GHCiOption)
2225 strToGHCiOpt "m" = Just Multiline
2226 strToGHCiOpt "s" = Just ShowTiming
2227 strToGHCiOpt "t" = Just ShowType
2228 strToGHCiOpt "r" = Just RevertCAFs
2229 strToGHCiOpt _ = Nothing
2230
2231 optToStr :: GHCiOption -> String
2232 optToStr Multiline = "m"
2233 optToStr ShowTiming = "s"
2234 optToStr ShowType = "t"
2235 optToStr RevertCAFs = "r"
2236
2237
2238 -- ---------------------------------------------------------------------------
2239 -- :show
2240
2241 showCmd :: String -> GHCi ()
2242 showCmd "" = showOptions False
2243 showCmd "-a" = showOptions True
2244 showCmd str = do
2245 st <- getGHCiState
2246 case words str of
2247 ["args"] -> liftIO $ putStrLn (show (GhciMonad.args st))
2248 ["prog"] -> liftIO $ putStrLn (show (progname st))
2249 ["prompt"] -> liftIO $ putStrLn (show (prompt st))
2250 ["prompt2"] -> liftIO $ putStrLn (show (prompt2 st))
2251 ["editor"] -> liftIO $ putStrLn (show (editor st))
2252 ["stop"] -> liftIO $ putStrLn (show (stop st))
2253 ["imports"] -> showImports
2254 ["modules" ] -> showModules
2255 ["bindings"] -> showBindings
2256 ["linker"] ->
2257 do dflags <- getDynFlags
2258 liftIO $ showLinkerState dflags
2259 ["breaks"] -> showBkptTable
2260 ["context"] -> showContext
2261 ["packages"] -> showPackages
2262 ["paths"] -> showPaths
2263 ["languages"] -> showLanguages -- backwards compat
2264 ["language"] -> showLanguages
2265 ["lang"] -> showLanguages -- useful abbreviation
2266 _ -> throwGhcException (CmdLineError ("syntax: :show [ args | prog | prompt | prompt2 | editor | stop | modules\n" ++
2267 " | bindings | breaks | context | packages | language ]"))
2268
2269 showiCmd :: String -> GHCi ()
2270 showiCmd str = do
2271 case words str of
2272 ["languages"] -> showiLanguages -- backwards compat
2273 ["language"] -> showiLanguages
2274 ["lang"] -> showiLanguages -- useful abbreviation
2275 _ -> throwGhcException (CmdLineError ("syntax: :showi language"))
2276
2277 showImports :: GHCi ()
2278 showImports = do
2279 st <- getGHCiState
2280 dflags <- getDynFlags
2281 let rem_ctx = reverse (remembered_ctx st)
2282 trans_ctx = transient_ctx st
2283
2284 show_one (IIModule star_m)
2285 = ":module +*" ++ moduleNameString star_m
2286 show_one (IIDecl imp) = showPpr dflags imp
2287
2288 prel_imp
2289 | any isPreludeImport (rem_ctx ++ trans_ctx) = []
2290 | not (xopt Opt_ImplicitPrelude dflags) = []
2291 | otherwise = ["import Prelude -- implicit"]
2292
2293 trans_comment s = s ++ " -- added automatically"
2294 --
2295 liftIO $ mapM_ putStrLn (prel_imp ++ map show_one rem_ctx
2296 ++ map (trans_comment . show_one) trans_ctx)
2297
2298 showModules :: GHCi ()
2299 showModules = do
2300 loaded_mods <- getLoadedModules
2301 -- we want *loaded* modules only, see #1734
2302 let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)
2303 mapM_ show_one loaded_mods
2304
2305 getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
2306 getLoadedModules = do
2307 graph <- GHC.getModuleGraph
2308 filterM (GHC.isLoaded . GHC.ms_mod_name) graph
2309
2310 showBindings :: GHCi ()
2311 showBindings = do
2312 bindings <- GHC.getBindings
2313 (insts, finsts) <- GHC.getInsts
2314 docs <- mapM makeDoc (reverse bindings)
2315 -- reverse so the new ones come last
2316 let idocs = map GHC.pprInstanceHdr insts
2317 fidocs = map GHC.pprFamInst finsts
2318 mapM_ printForUserPartWay (docs ++ idocs ++ fidocs)
2319 where
2320 makeDoc (AnId i) = pprTypeAndContents i
2321 makeDoc tt = do
2322 mb_stuff <- GHC.getInfo False (getName tt)
2323 return $ maybe (text "") pprTT mb_stuff
2324
2325 pprTT :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc
2326 pprTT (thing, fixity, _cls_insts, _fam_insts)
2327 = pprTyThing thing
2328 $$ show_fixity
2329 where
2330 show_fixity
2331 | fixity == GHC.defaultFixity = empty
2332 | otherwise = ppr fixity <+> ppr (GHC.getName thing)
2333
2334
2335 printTyThing :: TyThing -> GHCi ()
2336 printTyThing tyth = printForUser (pprTyThing tyth)
2337
2338 showBkptTable :: GHCi ()
2339 showBkptTable = do
2340 st <- getGHCiState
2341 printForUser $ prettyLocations (breaks st)
2342
2343 showContext :: GHCi ()
2344 showContext = do
2345 resumes <- GHC.getResumeContext
2346 printForUser $ vcat (map pp_resume (reverse resumes))
2347 where
2348 pp_resume res =
2349 ptext (sLit "--> ") <> text (GHC.resumeStmt res)
2350 $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan res))
2351
2352 showPackages :: GHCi ()
2353 showPackages = do
2354 dflags <- getDynFlags
2355 let pkg_flags = packageFlags dflags
2356 liftIO $ putStrLn $ showSDoc dflags $
2357 text ("active package flags:"++if null pkg_flags then " none" else "") $$
2358 nest 2 (vcat (map pprFlag pkg_flags))
2359
2360 showPaths :: GHCi ()
2361 showPaths = do
2362 dflags <- getDynFlags
2363 liftIO $ do
2364 cwd <- getCurrentDirectory
2365 putStrLn $ showSDoc dflags $
2366 text "current working directory: " $$
2367 nest 2 (text cwd)
2368 let ipaths = importPaths dflags
2369 putStrLn $ showSDoc dflags $
2370 text ("module import search paths:"++if null ipaths then " none" else "") $$
2371 nest 2 (vcat (map text ipaths))
2372
2373 showLanguages :: GHCi ()
2374 showLanguages = getDynFlags >>= liftIO . showLanguages' False
2375
2376 showiLanguages :: GHCi ()
2377 showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False
2378
2379 showLanguages' :: Bool -> DynFlags -> IO ()
2380 showLanguages' show_all dflags =
2381 putStrLn $ showSDoc dflags $ vcat
2382 [ text "base language is: " <>
2383 case language dflags of
2384 Nothing -> text "Haskell2010"
2385 Just Haskell98 -> text "Haskell98"
2386 Just Haskell2010 -> text "Haskell2010"
2387 , (if show_all then text "all active language options:"
2388 else text "with the following modifiers:") $$
2389 nest 2 (vcat (map (setting xopt) DynFlags.xFlags))
2390 ]
2391 where
2392 setting test flag
2393 | quiet = empty
2394 | is_on = text "-X" <> text name
2395 | otherwise = text "-XNo" <> text name
2396 where name = flagSpecName flag
2397 f = flagSpecFlag flag
2398 is_on = test f dflags
2399 quiet = not show_all && test f default_dflags == is_on
2400
2401 default_dflags =
2402 defaultDynFlags (settings dflags) `lang_set`
2403 case language dflags of
2404 Nothing -> Just Haskell2010
2405 other -> other
2406
2407 -- -----------------------------------------------------------------------------
2408 -- Completion
2409
2410 completeCmd :: String -> GHCi ()
2411 completeCmd argLine0 = case parseLine argLine0 of
2412 Just ("repl", resultRange, left) -> do
2413 (unusedLine,compls) <- ghciCompleteWord (reverse left,"")
2414 let compls' = takeRange resultRange compls
2415 liftIO . putStrLn $ unwords [ show (length compls'), show (length compls), show (reverse unusedLine) ]
2416 forM_ (takeRange resultRange compls) $ \(Completion r _ _) -> do
2417 liftIO $ print r
2418 _ -> throwGhcException (CmdLineError "Syntax: :complete repl [<range>] <quoted-string-to-complete>")
2419 where
2420 parseLine argLine
2421 | null argLine = Nothing
2422 | null rest1 = Nothing
2423 | otherwise = (,,) dom <$> resRange <*> s
2424 where
2425 (dom, rest1) = breakSpace argLine
2426 (rng, rest2) = breakSpace rest1
2427 resRange | head rest1 == '"' = parseRange ""
2428 | otherwise = parseRange rng
2429 s | head rest1 == '"' = readMaybe rest1 :: Maybe String
2430 | otherwise = readMaybe rest2
2431 breakSpace = fmap (dropWhile isSpace) . break isSpace
2432
2433 takeRange (lb,ub) = maybe id (drop . pred) lb . maybe id take ub
2434
2435 -- syntax: [n-][m] with semantics "drop (n-1) . take m"
2436 parseRange :: String -> Maybe (Maybe Int,Maybe Int)
2437 parseRange s = case span isDigit s of
2438 (_, "") ->
2439 -- upper limit only
2440 Just (Nothing, bndRead s)
2441 (s1, '-' : s2)
2442 | all isDigit s2 ->
2443 Just (bndRead s1, bndRead s2)
2444 _ ->
2445 Nothing
2446 where
2447 bndRead x = if null x then Nothing else Just (read x)
2448
2449
2450
2451 completeGhciCommand, completeMacro, completeIdentifier, completeModule,
2452 completeSetModule, completeSeti, completeShowiOptions,
2453 completeHomeModule, completeSetOptions, completeShowOptions,
2454 completeHomeModuleOrFile, completeExpression
2455 :: CompletionFunc GHCi
2456
2457 ghciCompleteWord :: CompletionFunc GHCi
2458 ghciCompleteWord line@(left,_) = case firstWord of
2459 ':':cmd | null rest -> completeGhciCommand line
2460 | otherwise -> do
2461 completion <- lookupCompletion cmd
2462 completion line
2463 "import" -> completeModule line
2464 _ -> completeExpression line
2465 where
2466 (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
2467 lookupCompletion ('!':_) = return completeFilename
2468 lookupCompletion c = do
2469 maybe_cmd <- lookupCommand' c
2470 case maybe_cmd of
2471 Just (_,_,f) -> return f
2472 Nothing -> return completeFilename
2473
2474 completeGhciCommand = wrapCompleter " " $ \w -> do
2475 macros <- liftIO $ readIORef macros_ref
2476 cmds <- ghci_commands `fmap` getGHCiState
2477 let macro_names = map (':':) . map cmdName $ macros
2478 let command_names = map (':':) . map cmdName $ cmds
2479 let{ candidates = case w of
2480 ':' : ':' : _ -> map (':':) command_names
2481 _ -> nub $ macro_names ++ command_names }
2482 return $ filter (w `isPrefixOf`) candidates
2483
2484 completeMacro = wrapIdentCompleter $ \w -> do
2485 cmds <- liftIO $ readIORef macros_ref
2486 return (filter (w `isPrefixOf`) (map cmdName cmds))
2487
2488 completeIdentifier = wrapIdentCompleter $ \w -> do
2489 rdrs <- GHC.getRdrNamesInScope
2490 dflags <- GHC.getSessionDynFlags
2491 return (filter (w `isPrefixOf`) (map (showPpr dflags) rdrs))
2492
2493 completeModule = wrapIdentCompleter $ \w -> do
2494 dflags <- GHC.getSessionDynFlags
2495 let pkg_mods = allVisibleModules dflags
2496 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
2497 return $ filter (w `isPrefixOf`)
2498 $ map (showPpr dflags) $ loaded_mods ++ pkg_mods
2499
2500 completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
2501 dflags <- GHC.getSessionDynFlags
2502 modules <- case m of
2503 Just '-' -> do
2504 imports <- GHC.getContext
2505 return $ map iiModuleName imports
2506 _ -> do
2507 let pkg_mods = allVisibleModules dflags
2508 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
2509 return $ loaded_mods ++ pkg_mods
2510 return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules
2511
2512 completeHomeModule = wrapIdentCompleter listHomeModules
2513
2514 listHomeModules :: String -> GHCi [String]
2515 listHomeModules w = do
2516 g <- GHC.getModuleGraph
2517 let home_mods = map GHC.ms_mod_name g
2518 dflags <- getDynFlags
2519 return $ sort $ filter (w `isPrefixOf`)
2520 $ map (showPpr dflags) home_mods
2521
2522 completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
2523 return (filter (w `isPrefixOf`) opts)
2524 where opts = "args":"prog":"prompt":"prompt2":"editor":"stop":flagList
2525 flagList = map head $ group $ sort allFlags
2526
2527 completeSeti = wrapCompleter flagWordBreakChars $ \w -> do
2528 return (filter (w `isPrefixOf`) flagList)
2529 where flagList = map head $ group $ sort allFlags
2530
2531 completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
2532 return (filter (w `isPrefixOf`) opts)
2533 where opts = ["args", "prog", "prompt", "prompt2", "editor", "stop",
2534 "modules", "bindings", "linker", "breaks",
2535 "context", "packages", "paths", "language", "imports"]
2536
2537 completeShowiOptions = wrapCompleter flagWordBreakChars $ \w -> do
2538 return (filter (w `isPrefixOf`) ["language"])
2539
2540 completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
2541 $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
2542 listFiles
2543
2544 unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
2545 unionComplete f1 f2 line = do
2546 cs1 <- f1 line
2547 cs2 <- f2 line
2548 return (cs1 ++ cs2)
2549
2550 wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
2551 wrapCompleter breakChars fun = completeWord Nothing breakChars
2552 $ fmap (map simpleCompletion . nubSort) . fun
2553
2554 wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
2555 wrapIdentCompleter = wrapCompleter word_break_chars
2556
2557 wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi
2558 wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars
2559 $ \rest -> fmap (map simpleCompletion . nubSort) . fun (getModifier rest)
2560 where
2561 getModifier = find (`elem` modifChars)
2562
2563 -- | Return a list of visible module names for autocompletion.
2564 -- (NB: exposed != visible)
2565 allVisibleModules :: DynFlags -> [ModuleName]
2566 allVisibleModules dflags = listVisibleModuleNames dflags
2567
2568 completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
2569 completeIdentifier
2570
2571
2572 -- -----------------------------------------------------------------------------
2573 -- commands for debugger
2574
2575 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
2576 sprintCmd = pprintCommand False False
2577 printCmd = pprintCommand True False
2578 forceCmd = pprintCommand False True
2579
2580 pprintCommand :: Bool -> Bool -> String -> GHCi ()
2581 pprintCommand bind force str = do
2582 pprintClosureCommand bind force str
2583
2584 stepCmd :: String -> GHCi ()
2585 stepCmd arg = withSandboxOnly ":step" $ step arg
2586 where
2587 step [] = doContinue (const True) GHC.SingleStep
2588 step expression = runStmt expression GHC.SingleStep >> return ()
2589
2590 stepLocalCmd :: String -> GHCi ()
2591 stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg
2592 where
2593 step expr
2594 | not (null expr) = stepCmd expr
2595 | otherwise = do
2596 mb_span <- getCurrentBreakSpan
2597 case mb_span of
2598 Nothing -> stepCmd []
2599 Just loc -> do
2600 Just md <- getCurrentBreakModule
2601 current_toplevel_decl <- enclosingTickSpan md loc
2602 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
2603
2604 stepModuleCmd :: String -> GHCi ()
2605 stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg
2606 where
2607 step expr
2608 | not (null expr) = stepCmd expr
2609 | otherwise = do
2610 mb_span <- getCurrentBreakSpan
2611 case mb_span of
2612 Nothing -> stepCmd []
2613 Just pan -> do
2614 let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span
2615 doContinue f GHC.SingleStep
2616
2617 -- | Returns the span of the largest tick containing the srcspan given
2618 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
2619 enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
2620 enclosingTickSpan md (RealSrcSpan src) = do
2621 ticks <- getTickArray md
2622 let line = srcSpanStartLine src
2623 ASSERT(inRange (bounds ticks) line) do
2624 let toRealSrcSpan (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
2625 toRealSrcSpan (RealSrcSpan s) = s
2626 enclosing_spans = [ pan | (_,pan) <- ticks ! line
2627 , realSrcSpanEnd (toRealSrcSpan pan) >= realSrcSpanEnd src]
2628 return . head . sortBy leftmost_largest $ enclosing_spans
2629
2630 traceCmd :: String -> GHCi ()
2631 traceCmd arg
2632 = withSandboxOnly ":trace" $ tr arg
2633 where
2634 tr [] = doContinue (const True) GHC.RunAndLogSteps
2635 tr expression = runStmt expression GHC.RunAndLogSteps >> return ()
2636
2637 continueCmd :: String -> GHCi ()
2638 continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion
2639
2640 -- doContinue :: SingleStep -> GHCi ()
2641 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
2642 doContinue pre step = do
2643 runResult <- resume pre step
2644 _ <- afterRunStmt pre runResult
2645 return ()
2646
2647 abandonCmd :: String -> GHCi ()
2648 abandonCmd = noArgs $ withSandboxOnly ":abandon" $ do
2649 b <- GHC.abandon -- the prompt will change to indicate the new context
2650 when (not b) $ liftIO $ putStrLn "There is no computation running."
2651
2652 deleteCmd :: String -> GHCi ()
2653 deleteCmd argLine = withSandboxOnly ":delete" $ do
2654 deleteSwitch $ words argLine
2655 where
2656 deleteSwitch :: [String] -> GHCi ()
2657 deleteSwitch [] =
2658 liftIO $ putStrLn "The delete command requires at least one argument."
2659 -- delete all break points
2660 deleteSwitch ("*":_rest) = discardActiveBreakPoints
2661 deleteSwitch idents = do
2662 mapM_ deleteOneBreak idents
2663 where
2664 deleteOneBreak :: String -> GHCi ()
2665 deleteOneBreak str
2666 | all isDigit str = deleteBreak (read str)
2667 | otherwise = return ()
2668
2669 historyCmd :: String -> GHCi ()
2670 historyCmd arg
2671 | null arg = history 20
2672 | all isDigit arg = history (read arg)
2673 | otherwise = liftIO $ putStrLn "Syntax: :history [num]"
2674 where
2675 history num = do
2676 resumes <- GHC.getResumeContext
2677 case resumes of
2678 [] -> liftIO $ putStrLn "Not stopped at a breakpoint"
2679 (r:_) -> do
2680 let hist = GHC.resumeHistory r
2681 (took,rest) = splitAt num hist
2682 case hist of
2683 [] -> liftIO $ putStrLn $
2684 "Empty history. Perhaps you forgot to use :trace?"
2685 _ -> do
2686 pans <- mapM GHC.getHistorySpan took
2687 let nums = map (printf "-%-3d:") [(1::Int)..]
2688 names = map GHC.historyEnclosingDecls took
2689 printForUser (vcat(zipWith3
2690 (\x y z -> x <+> y <+> z)
2691 (map text nums)
2692 (map (bold . hcat . punctuate colon . map text) names)
2693 (map (parens . ppr) pans)))
2694 liftIO $ putStrLn $ if null rest then "<end of history>" else "..."
2695
2696 bold :: SDoc -> SDoc
2697 bold c | do_bold = text start_bold <> c <> text end_bold
2698 | otherwise = c
2699
2700 backCmd :: String -> GHCi ()
2701 backCmd = noArgs $ withSandboxOnly ":back" $ do
2702 (names, _, pan) <- GHC.back
2703 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan
2704 printTypeOfNames names
2705 -- run the command set with ":set stop <cmd>"
2706 st <- getGHCiState
2707 enqueueCommands [stop st]
2708
2709 forwardCmd :: String -> GHCi ()
2710 forwardCmd = noArgs $ withSandboxOnly ":forward" $ do
2711 (names, ix, pan) <- GHC.forward
2712 printForUser $ (if (ix == 0)
2713 then ptext (sLit "Stopped at")
2714 else ptext (sLit "Logged breakpoint at")) <+> ppr pan
2715 printTypeOfNames names
2716 -- run the command set with ":set stop <cmd>"
2717 st <- getGHCiState
2718 enqueueCommands [stop st]
2719
2720 -- handle the "break" command
2721 breakCmd :: String -> GHCi ()
2722 breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine
2723
2724 breakSwitch :: [String] -> GHCi ()
2725 breakSwitch [] = do
2726 liftIO $ putStrLn "The break command requires at least one argument."
2727 breakSwitch (arg1:rest)
2728 | looksLikeModuleName arg1 && not (null rest) = do
2729 md <- wantInterpretedModule arg1
2730 breakByModule md rest
2731 | all isDigit arg1 = do
2732 imports <- GHC.getContext
2733 case iiModules imports of
2734 (mn : _) -> do
2735 md <- lookupModuleName mn
2736 breakByModuleLine md (read arg1) rest
2737 [] -> do
2738 liftIO $ putStrLn "No modules are loaded with debugging support."
2739 | otherwise = do -- try parsing it as an identifier
2740 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
2741 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2742 case loc of
2743 RealSrcLoc l ->
2744 ASSERT( isExternalName name )
2745 findBreakAndSet (GHC.nameModule name) $
2746 findBreakByCoord (Just (GHC.srcLocFile l))
2747 (GHC.srcLocLine l,
2748 GHC.srcLocCol l)
2749 UnhelpfulLoc _ ->
2750 noCanDo name $ text "can't find its location: " <> ppr loc
2751 where
2752 noCanDo n why = printForUser $
2753 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
2754
2755 breakByModule :: Module -> [String] -> GHCi ()
2756 breakByModule md (arg1:rest)
2757 | all isDigit arg1 = do -- looks like a line number
2758 breakByModuleLine md (read arg1) rest
2759 breakByModule _ _
2760 = breakSyntax
2761
2762 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
2763 breakByModuleLine md line args
2764 | [] <- args = findBreakAndSet md $ findBreakByLine line
2765 | [col] <- args, all isDigit col =
2766 findBreakAndSet md $ findBreakByCoord Nothing (line, read col)
2767 | otherwise = breakSyntax
2768
2769 breakSyntax :: a
2770 breakSyntax = throwGhcException (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
2771
2772 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
2773 findBreakAndSet md lookupTickTree = do
2774 dflags <- getDynFlags
2775 tickArray <- getTickArray md
2776 (breakArray, _) <- getModBreak md
2777 case lookupTickTree tickArray of
2778 Nothing -> liftIO $ putStrLn $ "No breakpoints found at that location."
2779 Just (tick, pan) -> do
2780 success <- liftIO $ setBreakFlag dflags True breakArray tick
2781 if success
2782 then do
2783 (alreadySet, nm) <-
2784 recordBreak $ BreakLocation
2785 { breakModule = md
2786 , breakLoc = pan
2787 , breakTick = tick
2788 , onBreakCmd = ""
2789 }
2790 printForUser $
2791 text "Breakpoint " <> ppr nm <>
2792 if alreadySet
2793 then text " was already set at " <> ppr pan
2794 else text " activated at " <> ppr pan
2795 else do
2796 printForUser $ text "Breakpoint could not be activated at"
2797 <+> ppr pan
2798
2799 -- When a line number is specified, the current policy for choosing
2800 -- the best breakpoint is this:
2801 -- - the leftmost complete subexpression on the specified line, or
2802 -- - the leftmost subexpression starting on the specified line, or
2803 -- - the rightmost subexpression enclosing the specified line
2804 --
2805 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2806 findBreakByLine line arr
2807 | not (inRange (bounds arr) line) = Nothing
2808 | otherwise =
2809 listToMaybe (sortBy (leftmost_largest `on` snd) comp) `mplus`
2810 listToMaybe (sortBy (leftmost_smallest `on` snd) incomp) `mplus`
2811 listToMaybe (sortBy (rightmost `on` snd) ticks)
2812 where
2813 ticks = arr ! line
2814
2815 starts_here = [ tick | tick@(_,pan) <- ticks,
2816 GHC.srcSpanStartLine (toRealSpan pan) == line ]
2817
2818 (comp, incomp) = partition ends_here starts_here
2819 where ends_here (_,pan) = GHC.srcSpanEndLine (toRealSpan pan) == line
2820 toRealSpan (RealSrcSpan pan) = pan
2821 toRealSpan (UnhelpfulSpan _) = panic "findBreakByLine UnhelpfulSpan"
2822
2823 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2824 -> Maybe (BreakIndex,SrcSpan)
2825 findBreakByCoord mb_file (line, col) arr
2826 | not (inRange (bounds arr) line) = Nothing
2827 | otherwise =
2828 listToMaybe (sortBy (rightmost `on` snd) contains ++
2829 sortBy (leftmost_smallest `on` snd) after_here)
2830 where
2831 ticks = arr ! line
2832
2833 -- the ticks that span this coordinate
2834 contains = [ tick | tick@(_,pan) <- ticks, pan `spans` (line,col),
2835 is_correct_file pan ]
2836
2837 is_correct_file pan
2838 | Just f <- mb_file = GHC.srcSpanFile (toRealSpan pan) == f
2839 | otherwise = True
2840
2841 after_here = [ tick | tick@(_,pan) <- ticks,
2842 let pan' = toRealSpan pan,
2843 GHC.srcSpanStartLine pan' == line,
2844 GHC.srcSpanStartCol pan' >= col ]
2845
2846 toRealSpan (RealSrcSpan pan) = pan
2847 toRealSpan (UnhelpfulSpan _) = panic "findBreakByCoord UnhelpfulSpan"
2848
2849 -- For now, use ANSI bold on terminals that we know support it.
2850 -- Otherwise, we add a line of carets under the active expression instead.
2851 -- In particular, on Windows and when running the testsuite (which sets
2852 -- TERM to vt100 for other reasons) we get carets.
2853 -- We really ought to use a proper termcap/terminfo library.
2854 do_bold :: Bool
2855 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2856 where mTerm = System.Environment.getEnv "TERM"
2857 `catchIO` \_ -> return "TERM not set"
2858
2859 start_bold :: String
2860 start_bold = "\ESC[1m"
2861 end_bold :: String
2862 end_bold = "\ESC[0m"
2863
2864
2865 -----------------------------------------------------------------------------
2866 -- :list
2867
2868 listCmd :: String -> InputT GHCi ()
2869 listCmd c = listCmd' c
2870
2871 listCmd' :: String -> InputT GHCi ()
2872 listCmd' "" = do
2873 mb_span <- lift getCurrentBreakSpan
2874 case mb_span of
2875 Nothing ->
2876 printForUser $ text "Not stopped at a breakpoint; nothing to list"
2877 Just (RealSrcSpan pan) ->
2878 listAround pan True
2879 Just pan@(UnhelpfulSpan _) ->
2880 do resumes <- GHC.getResumeContext
2881 case resumes of
2882 [] -> panic "No resumes"
2883 (r:_) ->
2884 do let traceIt = case GHC.resumeHistory r of
2885 [] -> text "rerunning with :trace,"
2886 _ -> empty
2887 doWhat = traceIt <+> text ":back then :list"
2888 printForUser (text "Unable to list source for" <+>
2889 ppr pan
2890 $$ text "Try" <+> doWhat)
2891 listCmd' str = list2 (words str)
2892
2893 list2 :: [String] -> InputT GHCi ()
2894 list2 [arg] | all isDigit arg = do
2895 imports <- GHC.getContext
2896 case iiModules imports of
2897 [] -> liftIO $ putStrLn "No module to list"
2898 (mn : _) -> do
2899 md <- lift $ lookupModuleName mn
2900 listModuleLine md (read arg)
2901 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2902 md <- wantInterpretedModule arg1
2903 listModuleLine md (read arg2)
2904 list2 [arg] = do
2905 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2906 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2907 case loc of
2908 RealSrcLoc l ->
2909 do tickArray <- ASSERT( isExternalName name )
2910 lift $ getTickArray (GHC.nameModule name)
2911 let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))
2912 (GHC.srcLocLine l, GHC.srcLocCol l)
2913 tickArray
2914 case mb_span of
2915 Nothing -> listAround (realSrcLocSpan l) False
2916 Just (_, UnhelpfulSpan _) -> panic "list2 UnhelpfulSpan"
2917 Just (_, RealSrcSpan pan) -> listAround pan False
2918 UnhelpfulLoc _ ->
2919 noCanDo name $ text "can't find its location: " <>
2920 ppr loc
2921 where
2922 noCanDo n why = printForUser $
2923 text "cannot list source code for " <> ppr n <> text ": " <> why
2924 list2 _other =
2925 liftIO $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2926
2927 listModuleLine :: Module -> Int -> InputT GHCi ()
2928 listModuleLine modl line = do
2929 graph <- GHC.getModuleGraph
2930 let this = filter ((== modl) . GHC.ms_mod) graph
2931 case this of
2932 [] -> panic "listModuleLine"
2933 summ:_ -> do
2934 let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
2935 loc = mkRealSrcLoc (mkFastString (filename)) line 0
2936 listAround (realSrcLocSpan loc) False
2937
2938 -- | list a section of a source file around a particular SrcSpan.
2939 -- If the highlight flag is True, also highlight the span using
2940 -- start_bold\/end_bold.
2941
2942 -- GHC files are UTF-8, so we can implement this by:
2943 -- 1) read the file in as a BS and syntax highlight it as before
2944 -- 2) convert the BS to String using utf-string, and write it out.
2945 -- It would be better if we could convert directly between UTF-8 and the
2946 -- console encoding, of course.
2947 listAround :: MonadIO m => RealSrcSpan -> Bool -> InputT m ()
2948 listAround pan do_highlight = do
2949 contents <- liftIO $ BS.readFile (unpackFS file)
2950 -- Drop carriage returns to avoid duplicates, see #9367.
2951 let ls = BS.split '\n' $ BS.filter (/= '\r') contents
2952 ls' = take (line2 - line1 + 1 + pad_before + pad_after) $
2953 drop (line1 - 1 - pad_before) $ ls
2954 fst_line = max 1 (line1 - pad_before)
2955 line_nos = [ fst_line .. ]
2956
2957 highlighted | do_highlight = zipWith highlight line_nos ls'
2958 | otherwise = [\p -> BS.concat[p,l] | l <- ls']
2959
2960 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2961 prefixed = zipWith ($) highlighted bs_line_nos
2962 output = BS.intercalate (BS.pack "\n") prefixed
2963
2964 utf8Decoded <- liftIO $ BS.useAsCStringLen output
2965 $ \(p,n) -> utf8DecodeString (castPtr p) n
2966 liftIO $ putStrLn utf8Decoded
2967 where
2968 file = GHC.srcSpanFile pan
2969 line1 = GHC.srcSpanStartLine pan
2970 col1 = GHC.srcSpanStartCol pan - 1
2971 line2 = GHC.srcSpanEndLine pan
2972 col2 = GHC.srcSpanEndCol pan - 1
2973
2974 pad_before | line1 == 1 = 0
2975 | otherwise = 1
2976 pad_after = 1
2977
2978 highlight | do_bold = highlight_bold
2979 | otherwise = highlight_carets
2980
2981 highlight_bold no line prefix
2982 | no == line1 && no == line2
2983 = let (a,r) = BS.splitAt col1 line
2984 (b,c) = BS.splitAt (col2-col1) r
2985 in
2986 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2987 | no == line1
2988 = let (a,b) = BS.splitAt col1 line in
2989 BS.concat [prefix, a, BS.pack start_bold, b]
2990 | no == line2
2991 = let (a,b) = BS.splitAt col2 line in
2992 BS.concat [prefix, a, BS.pack end_bold, b]
2993 | otherwise = BS.concat [prefix, line]
2994
2995 highlight_carets no line prefix
2996 | no == line1 && no == line2
2997 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2998 BS.replicate (col2-col1) '^']
2999 | no == line1
3000 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
3001 prefix, line]
3002 | no == line2
3003 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
3004 BS.pack "^^"]
3005 | otherwise = BS.concat [prefix, line]
3006 where
3007 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
3008 nl = BS.singleton '\n'
3009
3010
3011 -- --------------------------------------------------------------------------
3012 -- Tick arrays
3013
3014 getTickArray :: Module -> GHCi TickArray
3015 getTickArray modl = do
3016 st <- getGHCiState
3017 let arrmap = tickarrays st
3018 case lookupModuleEnv arrmap modl of
3019 Just arr -> return arr
3020 Nothing -> do
3021 (_breakArray, ticks) <- getModBreak modl
3022 let arr = mkTickArray (assocs ticks)
3023 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
3024 return arr
3025
3026 discardTickArrays :: GHCi ()
3027 discardTickArrays = do
3028 st <- getGHCiState
3029 setGHCiState st{tickarrays = emptyModuleEnv}
3030
3031 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
3032 mkTickArray ticks
3033 = accumArray (flip (:)) [] (1, max_line)
3034 [ (line, (nm,pan)) | (nm,pan) <- ticks,
3035 let pan' = toRealSpan pan,
3036 line <- srcSpanLines pan' ]
3037 where
3038 max_line = foldr max 0 (map (GHC.srcSpanEndLine . toRealSpan . snd) ticks)
3039 srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ]
3040 toRealSpan (RealSrcSpan pan) = pan
3041 toRealSpan (UnhelpfulSpan _) = panic "mkTickArray UnhelpfulSpan"
3042
3043 -- don't reset the counter back to zero?
3044 discardActiveBreakPoints :: GHCi ()
3045 discardActiveBreakPoints = do
3046 st <- getGHCiState
3047 mapM_ (turnOffBreak.snd) (breaks st)
3048 setGHCiState $ st { breaks = [] }
3049
3050 deleteBreak :: Int -> GHCi ()
3051 deleteBreak identity = do
3052 st <- getGHCiState
3053 let oldLocations = breaks st
3054 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
3055 if null this
3056 then printForUser (text "Breakpoint" <+> ppr identity <+>
3057 text "does not exist")
3058 else do
3059 mapM_ (turnOffBreak.snd) this
3060 setGHCiState $ st { breaks = rest }
3061
3062 turnOffBreak :: BreakLocation -> GHCi Bool
3063 turnOffBreak loc = do
3064 dflags <- getDynFlags
3065 (arr, _) <- getModBreak (breakModule loc)
3066 liftIO $ setBreakFlag dflags False arr (breakTick loc)
3067
3068 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
3069 getModBreak m = do
3070 Just mod_info <- GHC.getModuleInfo m
3071 let modBreaks = GHC.modInfoModBreaks mod_info
3072 let arr = GHC.modBreaks_flags modBreaks
3073 let ticks = GHC.modBreaks_locs modBreaks
3074 return (arr, ticks)
3075
3076 setBreakFlag :: DynFlags -> Bool -> GHC.BreakArray -> Int -> IO Bool
3077 setBreakFlag dflags toggle arr i
3078 | toggle = GHC.setBreakOn dflags arr i
3079 | otherwise = GHC.setBreakOff dflags arr i
3080
3081
3082 -- ---------------------------------------------------------------------------
3083 -- User code exception handling
3084
3085 -- This is the exception handler for exceptions generated by the
3086 -- user's code and exceptions coming from children sessions;
3087 -- it normally just prints out the exception. The
3088 -- handler must be recursive, in case showing the exception causes
3089 -- more exceptions to be raised.
3090 --
3091 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
3092 -- raising another exception. We therefore don't put the recursive
3093 -- handler arond the flushing operation, so if stderr is closed
3094 -- GHCi will just die gracefully rather than going into an infinite loop.
3095 handler :: SomeException -> GHCi Bool
3096
3097 handler exception = do
3098 flushInterpBuffers
3099 liftIO installSignalHandlers
3100 ghciHandle handler (showException exception >> return False)
3101
3102 showException :: SomeException -> GHCi ()
3103 showException se =
3104 liftIO $ case fromException se of
3105 -- omit the location for CmdLineError:
3106 Just (CmdLineError s) -> putException s
3107 -- ditto:
3108 Just ph@(PhaseFailed {}) -> putException (showGhcException ph "")
3109 Just other_ghc_ex -> putException (show other_ghc_ex)
3110 Nothing ->
3111 case fromException se of
3112 Just UserInterrupt -> putException "Interrupted."
3113 _ -> putException ("*** Exception: " ++ show se)
3114 where
3115 putException = hPutStrLn stderr
3116
3117
3118 -----------------------------------------------------------------------------
3119 -- recursive exception handlers
3120
3121 -- Don't forget to unblock async exceptions in the handler, or if we're
3122 -- in an exception loop (eg. let a = error a in a) the ^C exception
3123 -- may never be delivered. Thanks to Marcin for pointing out the bug.
3124
3125 ghciHandle :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a
3126 ghciHandle h m = gmask $ \restore -> do
3127 dflags <- getDynFlags
3128 gcatch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e)
3129
3130 ghciTry :: GHCi a -> GHCi (Either SomeException a)
3131 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
3132
3133 tryBool :: GHCi a -> GHCi Bool
3134 tryBool m = do
3135 r <- ghciTry m
3136 case r of
3137 Left _ -> return False
3138 Right _ -> return True
3139
3140 -- ----------------------------------------------------------------------------
3141 -- Utils
3142
3143 lookupModule :: GHC.GhcMonad m => String -> m Module
3144 lookupModule mName = lookupModuleName (GHC.mkModuleName mName)
3145
3146 lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module
3147 lookupModuleName mName = GHC.lookupModule mName Nothing
3148
3149 isHomeModule :: Module -> Bool
3150 isHomeModule m = GHC.modulePackageKey m == mainPackageKey
3151
3152 -- TODO: won't work if home dir is encoded.
3153 -- (changeDirectory may not work either in that case.)
3154 expandPath :: MonadIO m => String -> InputT m String
3155 expandPath = liftIO . expandPathIO
3156
3157 expandPathIO :: String -> IO String
3158 expandPathIO p =
3159 case dropWhile isSpace p of
3160 ('~':d) -> do
3161 tilde <- getHomeDirectory -- will fail if HOME not defined
3162 return (tilde ++ '/':d)
3163 other ->
3164 return other
3165
3166 sameFile :: FilePath -> FilePath -> IO Bool
3167 sameFile path1 path2 = do
3168 absPath1 <- canonicalizePath path1
3169 absPath2 <- canonicalizePath path2
3170 return $ absPath1 == absPath2
3171
3172 wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
3173 wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str)
3174
3175 wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module
3176 wantInterpretedModuleName modname = do
3177 modl <- lookupModuleName modname
3178 let str = moduleNameString modname
3179 dflags <- getDynFlags
3180 when (GHC.modulePackageKey modl /= thisPackage dflags) $
3181 throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
3182 is_interpreted <- GHC.moduleIsInterpreted modl
3183 when (not is_interpreted) $
3184 throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
3185 return modl
3186
3187 wantNameFromInterpretedModule :: GHC.GhcMonad m
3188 => (Name -> SDoc -> m ())
3189 -> String
3190 -> (Name -> m ())
3191 -> m ()
3192 wantNameFromInterpretedModule noCanDo str and_then =
3193 handleSourceError GHC.printException $ do
3194 names <- GHC.parseName str
3195 case names of
3196 [] -> return ()
3197 (n:_) -> do
3198 let modl = ASSERT( isExternalName n ) GHC.nameModule n
3199 if not (GHC.isExternalName n)
3200 then noCanDo n $ ppr n <>
3201 text " is not defined in an interpreted module"
3202 else do
3203 is_interpreted <- GHC.moduleIsInterpreted modl
3204 if not is_interpreted
3205 then noCanDo n $ text "module " <> ppr modl <>
3206 text " is not interpreted"
3207 else and_then n