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