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