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