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