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