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