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