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