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