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