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