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