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