ghci: add message when reusing compiled code #9887
[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, msObjFilePath )
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 -- Force originalFlags to avoid leaking the associated HscEnv
1467 !originalFlags <- getDynFlags
1468 when defer $ Monad.void $
1469 GHC.setProgramDynFlags $ setGeneralFlag' Opt_DeferTypeErrors originalFlags
1470 Monad.void $ load
1471 Monad.void $ GHC.setProgramDynFlags $ originalFlags
1472
1473 loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
1474 loadModule fs = timeIt (const Nothing) (loadModule' fs)
1475
1476 -- | @:load@ command
1477 loadModule_ :: Bool -> [FilePath] -> InputT GHCi ()
1478 loadModule_ defer fs = deferredLoad defer (loadModule (zip fs (repeat Nothing)))
1479
1480 loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
1481 loadModule' files = do
1482 let (filenames, phases) = unzip files
1483 exp_filenames <- mapM expandPath filenames
1484 let files' = zip exp_filenames phases
1485 targets <- mapM (uncurry GHC.guessTarget) files'
1486
1487 -- NOTE: we used to do the dependency anal first, so that if it
1488 -- fails we didn't throw away the current set of modules. This would
1489 -- require some re-working of the GHC interface, so we'll leave it
1490 -- as a ToDo for now.
1491
1492 -- unload first
1493 _ <- GHC.abandonAll
1494 lift discardActiveBreakPoints
1495 GHC.setTargets []
1496 _ <- GHC.load LoadAllTargets
1497
1498 GHC.setTargets targets
1499 doLoadAndCollectInfo False LoadAllTargets
1500
1501 -- | @:add@ command
1502 addModule :: [FilePath] -> InputT GHCi ()
1503 addModule files = do
1504 lift revertCAFs -- always revert CAFs on load/add.
1505 files' <- mapM expandPath files
1506 targets <- mapM (\m -> GHC.guessTarget m Nothing) files'
1507 -- remove old targets with the same id; e.g. for :add *M
1508 mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
1509 mapM_ GHC.addTarget targets
1510 _ <- doLoadAndCollectInfo False LoadAllTargets
1511 return ()
1512
1513 -- | @:reload@ command
1514 reloadModule :: Bool -> String -> InputT GHCi ()
1515 reloadModule defer m = deferredLoad defer $
1516 doLoadAndCollectInfo True loadTargets
1517 where
1518 loadTargets | null m = LoadAllTargets
1519 | otherwise = LoadUpTo (GHC.mkModuleName m)
1520
1521 -- | Load/compile targets and (optionally) collect module-info
1522 --
1523 -- This collects the necessary SrcSpan annotated type information (via
1524 -- 'collectInfo') required by the @:all-types@, @:loc-at@, @:type-at@,
1525 -- and @:uses@ commands.
1526 --
1527 -- Meta-info collection is not enabled by default and needs to be
1528 -- enabled explicitly via @:set +c@. The reason is that collecting
1529 -- the type-information for all sub-spans can be quite expensive, and
1530 -- since those commands are designed to be used by editors and
1531 -- tooling, it's useless to collect this data for normal GHCi
1532 -- sessions.
1533 doLoadAndCollectInfo :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag
1534 doLoadAndCollectInfo retain_context howmuch = do
1535 doCollectInfo <- lift (isOptionSet CollectInfo)
1536
1537 doLoad retain_context howmuch >>= \case
1538 Succeeded | doCollectInfo -> do
1539 loaded <- getModuleGraph >>= filterM GHC.isLoaded . map GHC.ms_mod_name
1540 v <- mod_infos <$> getGHCiState
1541 !newInfos <- collectInfo v loaded
1542 modifyGHCiState (\st -> st { mod_infos = newInfos })
1543 return Succeeded
1544 flag -> return flag
1545
1546 doLoad :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag
1547 doLoad retain_context howmuch = do
1548 -- turn off breakpoints before we load: we can't turn them off later, because
1549 -- the ModBreaks will have gone away.
1550 lift discardActiveBreakPoints
1551
1552 lift resetLastErrorLocations
1553 -- Enable buffering stdout and stderr as we're compiling. Keeping these
1554 -- handles unbuffered will just slow the compilation down, especially when
1555 -- compiling in parallel.
1556 gbracket (liftIO $ do hSetBuffering stdout LineBuffering
1557 hSetBuffering stderr LineBuffering)
1558 (\_ ->
1559 liftIO $ do hSetBuffering stdout NoBuffering
1560 hSetBuffering stderr NoBuffering) $ \_ -> do
1561 ok <- trySuccess $ GHC.load howmuch
1562 afterLoad ok retain_context
1563 return ok
1564
1565
1566 afterLoad :: SuccessFlag
1567 -> Bool -- keep the remembered_ctx, as far as possible (:reload)
1568 -> InputT GHCi ()
1569 afterLoad ok retain_context = do
1570 lift revertCAFs -- always revert CAFs on load.
1571 lift discardTickArrays
1572 loaded_mods <- getLoadedModules
1573 modulesLoadedMsg ok loaded_mods
1574 lift $ setContextAfterLoad retain_context loaded_mods
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 -> [GHC.ModSummary] -> InputT GHCi ()
1649 modulesLoadedMsg ok mods = do
1650 dflags <- getDynFlags
1651 unqual <- GHC.getPrintUnqual
1652 let mod_name mod = do
1653 is_interpreted <- GHC.isModuleInterpreted mod
1654 return $ if is_interpreted
1655 then ppr (GHC.ms_mod mod)
1656 else ppr (GHC.ms_mod mod)
1657 <> text " ("
1658 <> text (normalise $ msObjFilePath mod)
1659 <> text ")" -- fix #9887
1660 mod_names <- mapM mod_name mods
1661 let mod_commas
1662 | null mods = text "none."
1663 | otherwise = hsep (punctuate comma mod_names) <> text "."
1664 status = case ok of
1665 Failed -> text "Failed"
1666 Succeeded -> text "Ok"
1667
1668 msg = status <> text ", modules loaded:" <+> mod_commas
1669
1670 when (verbosity dflags > 0) $
1671 liftIO $ putStrLn $ showSDocForUser dflags unqual msg
1672
1673
1674 -- | Run an 'ExceptT' wrapped 'GhcMonad' while handling source errors
1675 -- and printing 'throwE' strings to 'stderr'
1676 runExceptGhcMonad :: GHC.GhcMonad m => ExceptT SDoc m () -> m ()
1677 runExceptGhcMonad act = handleSourceError GHC.printException $
1678 either handleErr pure =<<
1679 runExceptT act
1680 where
1681 handleErr sdoc = do
1682 dflags <- getDynFlags
1683 liftIO . hPutStrLn stderr . showSDocForUser dflags alwaysQualify $ sdoc
1684
1685 -- | Inverse of 'runExceptT' for \"pure\" computations
1686 -- (c.f. 'except' for 'Except')
1687 exceptT :: Applicative m => Either e a -> ExceptT e m a
1688 exceptT = ExceptT . pure
1689
1690 -----------------------------------------------------------------------------
1691 -- | @:type@ command
1692
1693 typeOfExpr :: String -> InputT GHCi ()
1694 typeOfExpr str = handleSourceError GHC.printException $ do
1695 ty <- GHC.exprType str
1696 printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser ty)]
1697
1698 -----------------------------------------------------------------------------
1699 -- | @:type-at@ command
1700
1701 typeAtCmd :: String -> InputT GHCi ()
1702 typeAtCmd str = runExceptGhcMonad $ do
1703 (span',sample) <- exceptT $ parseSpanArg str
1704 infos <- mod_infos <$> getGHCiState
1705 (info, ty) <- findType infos span' sample
1706 lift $ printForUserModInfo (modinfoInfo info)
1707 (sep [text sample,nest 2 (dcolon <+> ppr ty)])
1708
1709 -----------------------------------------------------------------------------
1710 -- | @:uses@ command
1711
1712 usesCmd :: String -> InputT GHCi ()
1713 usesCmd str = runExceptGhcMonad $ do
1714 (span',sample) <- exceptT $ parseSpanArg str
1715 infos <- mod_infos <$> getGHCiState
1716 uses <- findNameUses infos span' sample
1717 forM_ uses (liftIO . putStrLn . showSrcSpan)
1718
1719 -----------------------------------------------------------------------------
1720 -- | @:loc-at@ command
1721
1722 locAtCmd :: String -> InputT GHCi ()
1723 locAtCmd str = runExceptGhcMonad $ do
1724 (span',sample) <- exceptT $ parseSpanArg str
1725 infos <- mod_infos <$> getGHCiState
1726 (_,_,sp) <- findLoc infos span' sample
1727 liftIO . putStrLn . showSrcSpan $ sp
1728
1729 -----------------------------------------------------------------------------
1730 -- | @:all-types@ command
1731
1732 allTypesCmd :: String -> InputT GHCi ()
1733 allTypesCmd _ = runExceptGhcMonad $ do
1734 infos <- mod_infos <$> getGHCiState
1735 forM_ (M.elems infos) $ \mi ->
1736 forM_ (modinfoSpans mi) (lift . printSpan)
1737 where
1738 printSpan span'
1739 | Just ty <- spaninfoType span' = do
1740 df <- getDynFlags
1741 let tyInfo = unwords . words $
1742 showSDocForUser df alwaysQualify (pprTypeForUser ty)
1743 liftIO . putStrLn $
1744 showRealSrcSpan (spaninfoSrcSpan span') ++ ": " ++ tyInfo
1745 | otherwise = return ()
1746
1747 -----------------------------------------------------------------------------
1748 -- Helpers for locAtCmd/typeAtCmd/usesCmd
1749
1750 -- | Parse a span: <module-name/filepath> <sl> <sc> <el> <ec> <string>
1751 parseSpanArg :: String -> Either SDoc (RealSrcSpan,String)
1752 parseSpanArg s = do
1753 (fp,s0) <- readAsString (skipWs s)
1754 s0' <- skipWs1 s0
1755 (sl,s1) <- readAsInt s0'
1756 s1' <- skipWs1 s1
1757 (sc,s2) <- readAsInt s1'
1758 s2' <- skipWs1 s2
1759 (el,s3) <- readAsInt s2'
1760 s3' <- skipWs1 s3
1761 (ec,s4) <- readAsInt s3'
1762
1763 trailer <- case s4 of
1764 [] -> Right ""
1765 _ -> skipWs1 s4
1766
1767 let fs = mkFastString fp
1768 span' = mkRealSrcSpan (mkRealSrcLoc fs sl sc)
1769 (mkRealSrcLoc fs el ec)
1770
1771 return (span',trailer)
1772 where
1773 readAsInt :: String -> Either SDoc (Int,String)
1774 readAsInt "" = Left "Premature end of string while expecting Int"
1775 readAsInt s0 = case reads s0 of
1776 [s_rest] -> Right s_rest
1777 _ -> Left ("Couldn't read" <+> text (show s0) <+> "as Int")
1778
1779 readAsString :: String -> Either SDoc (String,String)
1780 readAsString s0
1781 | '"':_ <- s0 = case reads s0 of
1782 [s_rest] -> Right s_rest
1783 _ -> leftRes
1784 | s_rest@(_:_,_) <- breakWs s0 = Right s_rest
1785 | otherwise = leftRes
1786 where
1787 leftRes = Left ("Couldn't read" <+> text (show s0) <+> "as String")
1788
1789 skipWs1 :: String -> Either SDoc String
1790 skipWs1 (c:cs) | isWs c = Right (skipWs cs)
1791 skipWs1 s0 = Left ("Expected whitespace in" <+> text (show s0))
1792
1793 isWs = (`elem` [' ','\t'])
1794 skipWs = dropWhile isWs
1795 breakWs = break isWs
1796
1797
1798 -- | Pretty-print \"real\" 'SrcSpan's as
1799 -- @<filename>:(<line>,<col>)-(<line-end>,<col-end>)@
1800 -- while simply unpacking 'UnhelpfulSpan's
1801 showSrcSpan :: SrcSpan -> String
1802 showSrcSpan (UnhelpfulSpan s) = unpackFS s
1803 showSrcSpan (RealSrcSpan spn) = showRealSrcSpan spn
1804
1805 -- | Variant of 'showSrcSpan' for 'RealSrcSpan's
1806 showRealSrcSpan :: RealSrcSpan -> String
1807 showRealSrcSpan spn = concat [ fp, ":(", show sl, ",", show sc
1808 , ")-(", show el, ",", show ec, ")"
1809 ]
1810 where
1811 fp = unpackFS (srcSpanFile spn)
1812 sl = srcSpanStartLine spn
1813 sc = srcSpanStartCol spn
1814 el = srcSpanEndLine spn
1815 ec = srcSpanEndCol spn
1816
1817 -----------------------------------------------------------------------------
1818 -- | @:kind@ command
1819
1820 kindOfType :: Bool -> String -> InputT GHCi ()
1821 kindOfType norm str = handleSourceError GHC.printException $ do
1822 (ty, kind) <- GHC.typeKind norm str
1823 printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind
1824 , ppWhen norm $ equals <+> pprTypeForUser ty ]
1825
1826 -----------------------------------------------------------------------------
1827 -- :quit
1828
1829 quit :: String -> InputT GHCi Bool
1830 quit _ = return True
1831
1832
1833 -----------------------------------------------------------------------------
1834 -- :script
1835
1836 -- running a script file #1363
1837
1838 scriptCmd :: String -> InputT GHCi ()
1839 scriptCmd ws = do
1840 case words ws of
1841 [s] -> runScript s
1842 _ -> throwGhcException (CmdLineError "syntax: :script <filename>")
1843
1844 runScript :: String -- ^ filename
1845 -> InputT GHCi ()
1846 runScript filename = do
1847 filename' <- expandPath filename
1848 either_script <- liftIO $ tryIO (openFile filename' ReadMode)
1849 case either_script of
1850 Left _err -> throwGhcException (CmdLineError $ "IO error: \""++filename++"\" "
1851 ++(ioeGetErrorString _err))
1852 Right script -> do
1853 st <- getGHCiState
1854 let prog = progname st
1855 line = line_number st
1856 setGHCiState st{progname=filename',line_number=0}
1857 scriptLoop script
1858 liftIO $ hClose script
1859 new_st <- getGHCiState
1860 setGHCiState new_st{progname=prog,line_number=line}
1861 where scriptLoop script = do
1862 res <- runOneCommand handler $ fileLoop script
1863 case res of
1864 Nothing -> return ()
1865 Just s -> if s
1866 then scriptLoop script
1867 else return ()
1868
1869 -----------------------------------------------------------------------------
1870 -- :issafe
1871
1872 -- Displaying Safe Haskell properties of a module
1873
1874 isSafeCmd :: String -> InputT GHCi ()
1875 isSafeCmd m =
1876 case words m of
1877 [s] | looksLikeModuleName s -> do
1878 md <- lift $ lookupModule s
1879 isSafeModule md
1880 [] -> do md <- guessCurrentModule "issafe"
1881 isSafeModule md
1882 _ -> throwGhcException (CmdLineError "syntax: :issafe <module>")
1883
1884 isSafeModule :: Module -> InputT GHCi ()
1885 isSafeModule m = do
1886 mb_mod_info <- GHC.getModuleInfo m
1887 when (isNothing mb_mod_info)
1888 (throwGhcException $ CmdLineError $ "unknown module: " ++ mname)
1889
1890 dflags <- getDynFlags
1891 let iface = GHC.modInfoIface $ fromJust mb_mod_info
1892 when (isNothing iface)
1893 (throwGhcException $ CmdLineError $ "can't load interface file for module: " ++
1894 (GHC.moduleNameString $ GHC.moduleName m))
1895
1896 (msafe, pkgs) <- GHC.moduleTrustReqs m
1897 let trust = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface
1898 pkg = if packageTrusted dflags m then "trusted" else "untrusted"
1899 (good, bad) = tallyPkgs dflags pkgs
1900
1901 -- print info to user...
1902 liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")"
1903 liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off")
1904 when (not $ null good)
1905 (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++
1906 (intercalate ", " $ map (showPpr dflags) good))
1907 case msafe && null bad of
1908 True -> liftIO $ putStrLn $ mname ++ " is trusted!"
1909 False -> do
1910 when (not $ null bad)
1911 (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "
1912 ++ (intercalate ", " $ map (showPpr dflags) bad))
1913 liftIO $ putStrLn $ mname ++ " is NOT trusted!"
1914
1915 where
1916 mname = GHC.moduleNameString $ GHC.moduleName m
1917
1918 packageTrusted dflags md
1919 | thisPackage dflags == moduleUnitId md = True
1920 | otherwise = trusted $ getPackageDetails dflags (moduleUnitId md)
1921
1922 tallyPkgs dflags deps | not (packageTrustOn dflags) = ([], [])
1923 | otherwise = partition part deps
1924 where part pkg = trusted $ getPackageDetails dflags pkg
1925
1926 -----------------------------------------------------------------------------
1927 -- :browse
1928
1929 -- Browsing a module's contents
1930
1931 browseCmd :: Bool -> String -> InputT GHCi ()
1932 browseCmd bang m =
1933 case words m of
1934 ['*':s] | looksLikeModuleName s -> do
1935 md <- lift $ wantInterpretedModule s
1936 browseModule bang md False
1937 [s] | looksLikeModuleName s -> do
1938 md <- lift $ lookupModule s
1939 browseModule bang md True
1940 [] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "")
1941 browseModule bang md True
1942 _ -> throwGhcException (CmdLineError "syntax: :browse <module>")
1943
1944 guessCurrentModule :: String -> InputT GHCi Module
1945 -- Guess which module the user wants to browse. Pick
1946 -- modules that are interpreted first. The most
1947 -- recently-added module occurs last, it seems.
1948 guessCurrentModule cmd
1949 = do imports <- GHC.getContext
1950 when (null imports) $ throwGhcException $
1951 CmdLineError (':' : cmd ++ ": no current module")
1952 case (head imports) of
1953 IIModule m -> GHC.findModule m Nothing
1954 IIDecl d -> GHC.findModule (unLoc (ideclName d))
1955 (fmap sl_fs $ ideclPkgQual d)
1956
1957 -- without bang, show items in context of their parents and omit children
1958 -- with bang, show class methods and data constructors separately, and
1959 -- indicate import modules, to aid qualifying unqualified names
1960 -- with sorted, sort items alphabetically
1961 browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
1962 browseModule bang modl exports_only = do
1963 -- :browse reports qualifiers wrt current context
1964 unqual <- GHC.getPrintUnqual
1965
1966 mb_mod_info <- GHC.getModuleInfo modl
1967 case mb_mod_info of
1968 Nothing -> throwGhcException (CmdLineError ("unknown module: " ++
1969 GHC.moduleNameString (GHC.moduleName modl)))
1970 Just mod_info -> do
1971 dflags <- getDynFlags
1972 let names
1973 | exports_only = GHC.modInfoExports mod_info
1974 | otherwise = GHC.modInfoTopLevelScope mod_info
1975 `orElse` []
1976
1977 -- sort alphabetically name, but putting locally-defined
1978 -- identifiers first. We would like to improve this; see #1799.
1979 sorted_names = loc_sort local ++ occ_sort external
1980 where
1981 (local,external) = ASSERT( all isExternalName names )
1982 partition ((==modl) . nameModule) names
1983 occ_sort = sortBy (compare `on` nameOccName)
1984 -- try to sort by src location. If the first name in our list
1985 -- has a good source location, then they all should.
1986 loc_sort ns
1987 | n:_ <- ns, isGoodSrcSpan (nameSrcSpan n)
1988 = sortBy (compare `on` nameSrcSpan) ns
1989 | otherwise
1990 = occ_sort ns
1991
1992 mb_things <- mapM GHC.lookupName sorted_names
1993 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1994
1995 rdr_env <- GHC.getGRE
1996
1997 let things | bang = catMaybes mb_things
1998 | otherwise = filtered_things
1999 pretty | bang = pprTyThing
2000 | otherwise = pprTyThingInContext
2001
2002 labels [] = text "-- not currently imported"
2003 labels l = text $ intercalate "\n" $ map qualifier l
2004
2005 qualifier :: Maybe [ModuleName] -> String
2006 qualifier = maybe "-- defined locally"
2007 (("-- imported via "++) . intercalate ", "
2008 . map GHC.moduleNameString)
2009 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
2010
2011 modNames :: [[Maybe [ModuleName]]]
2012 modNames = map (importInfo . GHC.getName) things
2013
2014 -- annotate groups of imports with their import modules
2015 -- the default ordering is somewhat arbitrary, so we group
2016 -- by header and sort groups; the names themselves should
2017 -- really come in order of source appearance.. (trac #1799)
2018 annotate mts = concatMap (\(m,ts)->labels m:ts)
2019 $ sortBy cmpQualifiers $ grp mts
2020 where cmpQualifiers =
2021 compare `on` (map (fmap (map moduleNameFS)) . fst)
2022 grp [] = []
2023 grp mts@((m,_):_) = (m,map snd g) : grp ng
2024 where (g,ng) = partition ((==m).fst) mts
2025
2026 let prettyThings, prettyThings' :: [SDoc]
2027 prettyThings = map pretty things
2028 prettyThings' | bang = annotate $ zip modNames prettyThings
2029 | otherwise = prettyThings
2030 liftIO $ putStrLn $ showSDocForUser dflags unqual (vcat prettyThings')
2031 -- ToDo: modInfoInstances currently throws an exception for
2032 -- package modules. When it works, we can do this:
2033 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
2034
2035
2036 -----------------------------------------------------------------------------
2037 -- :module
2038
2039 -- Setting the module context. For details on context handling see
2040 -- "remembered_ctx" and "transient_ctx" in GhciMonad.
2041
2042 moduleCmd :: String -> GHCi ()
2043 moduleCmd str
2044 | all sensible strs = cmd
2045 | otherwise = throwGhcException (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
2046 where
2047 (cmd, strs) =
2048 case str of
2049 '+':stuff -> rest addModulesToContext stuff
2050 '-':stuff -> rest remModulesFromContext stuff
2051 stuff -> rest setContext stuff
2052
2053 rest op stuff = (op as bs, stuffs)
2054 where (as,bs) = partitionWith starred stuffs
2055 stuffs = words stuff
2056
2057 sensible ('*':m) = looksLikeModuleName m
2058 sensible m = looksLikeModuleName m
2059
2060 starred ('*':m) = Left (GHC.mkModuleName m)
2061 starred m = Right (GHC.mkModuleName m)
2062
2063
2064 -- -----------------------------------------------------------------------------
2065 -- Four ways to manipulate the context:
2066 -- (a) :module +<stuff>: addModulesToContext
2067 -- (b) :module -<stuff>: remModulesFromContext
2068 -- (c) :module <stuff>: setContext
2069 -- (d) import <module>...: addImportToContext
2070
2071 addModulesToContext :: [ModuleName] -> [ModuleName] -> GHCi ()
2072 addModulesToContext starred unstarred = restoreContextOnFailure $ do
2073 addModulesToContext_ starred unstarred
2074
2075 addModulesToContext_ :: [ModuleName] -> [ModuleName] -> GHCi ()
2076 addModulesToContext_ starred unstarred = do
2077 mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)
2078 setGHCContextFromGHCiState
2079
2080 remModulesFromContext :: [ModuleName] -> [ModuleName] -> GHCi ()
2081 remModulesFromContext starred unstarred = do
2082 -- we do *not* call restoreContextOnFailure here. If the user
2083 -- is trying to fix up a context that contains errors by removing
2084 -- modules, we don't want GHC to silently put them back in again.
2085 mapM_ rm (starred ++ unstarred)
2086 setGHCContextFromGHCiState
2087 where
2088 rm :: ModuleName -> GHCi ()
2089 rm str = do
2090 m <- moduleName <$> lookupModuleName str
2091 let filt = filter ((/=) m . iiModuleName)
2092 modifyGHCiState $ \st ->
2093 st { remembered_ctx = filt (remembered_ctx st)
2094 , transient_ctx = filt (transient_ctx st) }
2095
2096 setContext :: [ModuleName] -> [ModuleName] -> GHCi ()
2097 setContext starred unstarred = restoreContextOnFailure $ do
2098 modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] }
2099 -- delete the transient context
2100 addModulesToContext_ starred unstarred
2101
2102 addImportToContext :: String -> GHCi ()
2103 addImportToContext str = restoreContextOnFailure $ do
2104 idecl <- GHC.parseImportDecl str
2105 addII (IIDecl idecl) -- #5836
2106 setGHCContextFromGHCiState
2107
2108 -- Util used by addImportToContext and addModulesToContext
2109 addII :: InteractiveImport -> GHCi ()
2110 addII iidecl = do
2111 checkAdd iidecl
2112 modifyGHCiState $ \st ->
2113 st { remembered_ctx = addNotSubsumed iidecl (remembered_ctx st)
2114 , transient_ctx = filter (not . (iidecl `iiSubsumes`))
2115 (transient_ctx st)
2116 }
2117
2118 -- Sometimes we can't tell whether an import is valid or not until
2119 -- we finally call 'GHC.setContext'. e.g.
2120 --
2121 -- import System.IO (foo)
2122 --
2123 -- will fail because System.IO does not export foo. In this case we
2124 -- don't want to store the import in the context permanently, so we
2125 -- catch the failure from 'setGHCContextFromGHCiState' and set the
2126 -- context back to what it was.
2127 --
2128 -- See #6007
2129 --
2130 restoreContextOnFailure :: GHCi a -> GHCi a
2131 restoreContextOnFailure do_this = do
2132 st <- getGHCiState
2133 let rc = remembered_ctx st; tc = transient_ctx st
2134 do_this `gonException` (modifyGHCiState $ \st' ->
2135 st' { remembered_ctx = rc, transient_ctx = tc })
2136
2137 -- -----------------------------------------------------------------------------
2138 -- Validate a module that we want to add to the context
2139
2140 checkAdd :: InteractiveImport -> GHCi ()
2141 checkAdd ii = do
2142 dflags <- getDynFlags
2143 let safe = safeLanguageOn dflags
2144 case ii of
2145 IIModule modname
2146 | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell"
2147 | otherwise -> wantInterpretedModuleName modname >> return ()
2148
2149 IIDecl d -> do
2150 let modname = unLoc (ideclName d)
2151 pkgqual = ideclPkgQual d
2152 m <- GHC.lookupModule modname (fmap sl_fs pkgqual)
2153 when safe $ do
2154 t <- GHC.isModuleTrusted m
2155 when (not t) $ throwGhcException $ ProgramError $ ""
2156
2157 -- -----------------------------------------------------------------------------
2158 -- Update the GHC API's view of the context
2159
2160 -- | Sets the GHC context from the GHCi state. The GHC context is
2161 -- always set this way, we never modify it incrementally.
2162 --
2163 -- We ignore any imports for which the ModuleName does not currently
2164 -- exist. This is so that the remembered_ctx can contain imports for
2165 -- modules that are not currently loaded, perhaps because we just did
2166 -- a :reload and encountered errors.
2167 --
2168 -- Prelude is added if not already present in the list. Therefore to
2169 -- override the implicit Prelude import you can say 'import Prelude ()'
2170 -- at the prompt, just as in Haskell source.
2171 --
2172 setGHCContextFromGHCiState :: GHCi ()
2173 setGHCContextFromGHCiState = do
2174 st <- getGHCiState
2175 -- re-use checkAdd to check whether the module is valid. If the
2176 -- module does not exist, we do *not* want to print an error
2177 -- here, we just want to silently keep the module in the context
2178 -- until such time as the module reappears again. So we ignore
2179 -- the actual exception thrown by checkAdd, using tryBool to
2180 -- turn it into a Bool.
2181 iidecls <- filterM (tryBool.checkAdd) (transient_ctx st ++ remembered_ctx st)
2182 dflags <- GHC.getSessionDynFlags
2183 GHC.setContext $
2184 if xopt LangExt.ImplicitPrelude dflags && not (any isPreludeImport iidecls)
2185 then iidecls ++ [implicitPreludeImport]
2186 else iidecls
2187 -- XXX put prel at the end, so that guessCurrentModule doesn't pick it up.
2188
2189
2190 -- -----------------------------------------------------------------------------
2191 -- Utils on InteractiveImport
2192
2193 mkIIModule :: ModuleName -> InteractiveImport
2194 mkIIModule = IIModule
2195
2196 mkIIDecl :: ModuleName -> InteractiveImport
2197 mkIIDecl = IIDecl . simpleImportDecl
2198
2199 iiModules :: [InteractiveImport] -> [ModuleName]
2200 iiModules is = [m | IIModule m <- is]
2201
2202 iiModuleName :: InteractiveImport -> ModuleName
2203 iiModuleName (IIModule m) = m
2204 iiModuleName (IIDecl d) = unLoc (ideclName d)
2205
2206 preludeModuleName :: ModuleName
2207 preludeModuleName = GHC.mkModuleName "Prelude"
2208
2209 implicitPreludeImport :: InteractiveImport
2210 implicitPreludeImport = IIDecl (simpleImportDecl preludeModuleName)
2211
2212 isPreludeImport :: InteractiveImport -> Bool
2213 isPreludeImport (IIModule {}) = True
2214 isPreludeImport (IIDecl d) = unLoc (ideclName d) == preludeModuleName
2215
2216 addNotSubsumed :: InteractiveImport
2217 -> [InteractiveImport] -> [InteractiveImport]
2218 addNotSubsumed i is
2219 | any (`iiSubsumes` i) is = is
2220 | otherwise = i : filter (not . (i `iiSubsumes`)) is
2221
2222 -- | @filterSubsumed is js@ returns the elements of @js@ not subsumed
2223 -- by any of @is@.
2224 filterSubsumed :: [InteractiveImport] -> [InteractiveImport]
2225 -> [InteractiveImport]
2226 filterSubsumed is js = filter (\j -> not (any (`iiSubsumes` j) is)) js
2227
2228 -- | Returns True if the left import subsumes the right one. Doesn't
2229 -- need to be 100% accurate, conservatively returning False is fine.
2230 -- (EXCEPT: (IIModule m) *must* subsume itself, otherwise a panic in
2231 -- plusProv will ensue (#5904))
2232 --
2233 -- Note that an IIModule does not necessarily subsume an IIDecl,
2234 -- because e.g. a module might export a name that is only available
2235 -- qualified within the module itself.
2236 --
2237 -- Note that 'import M' does not necessarily subsume 'import M(foo)',
2238 -- because M might not export foo and we want an error to be produced
2239 -- in that case.
2240 --
2241 iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool
2242 iiSubsumes (IIModule m1) (IIModule m2) = m1==m2
2243 iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude
2244 = unLoc (ideclName d1) == unLoc (ideclName d2)
2245 && ideclAs d1 == ideclAs d2
2246 && (not (ideclQualified d1) || ideclQualified d2)
2247 && (ideclHiding d1 `hidingSubsumes` ideclHiding d2)
2248 where
2249 _ `hidingSubsumes` Just (False,L _ []) = True
2250 Just (False, L _ xs) `hidingSubsumes` Just (False,L _ ys)
2251 = all (`elem` xs) ys
2252 h1 `hidingSubsumes` h2 = h1 == h2
2253 iiSubsumes _ _ = False
2254
2255
2256 ----------------------------------------------------------------------------
2257 -- :set
2258
2259 -- set options in the interpreter. Syntax is exactly the same as the
2260 -- ghc command line, except that certain options aren't available (-C,
2261 -- -E etc.)
2262 --
2263 -- This is pretty fragile: most options won't work as expected. ToDo:
2264 -- figure out which ones & disallow them.
2265
2266 setCmd :: String -> GHCi ()
2267 setCmd "" = showOptions False
2268 setCmd "-a" = showOptions True
2269 setCmd str
2270 = case getCmd str of
2271 Right ("args", rest) ->
2272 case toArgs rest of
2273 Left err -> liftIO (hPutStrLn stderr err)
2274 Right args -> setArgs args
2275 Right ("prog", rest) ->
2276 case toArgs rest of
2277 Right [prog] -> setProg prog
2278 _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")
2279 Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
2280 Right ("prompt2", rest) -> setPrompt2 $ dropWhile isSpace rest
2281 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
2282 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
2283 _ -> case toArgs str of
2284 Left err -> liftIO (hPutStrLn stderr err)
2285 Right wds -> setOptions wds
2286
2287 setiCmd :: String -> GHCi ()
2288 setiCmd "" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False
2289 setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True
2290 setiCmd str =
2291 case toArgs str of
2292 Left err -> liftIO (hPutStrLn stderr err)
2293 Right wds -> newDynFlags True wds
2294
2295 showOptions :: Bool -> GHCi ()
2296 showOptions show_all
2297 = do st <- getGHCiState
2298 dflags <- getDynFlags
2299 let opts = options st
2300 liftIO $ putStrLn (showSDoc dflags (
2301 text "options currently set: " <>
2302 if null opts
2303 then text "none."
2304 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
2305 ))
2306 getDynFlags >>= liftIO . showDynFlags show_all
2307
2308
2309 showDynFlags :: Bool -> DynFlags -> IO ()
2310 showDynFlags show_all dflags = do
2311 showLanguages' show_all dflags
2312 putStrLn $ showSDoc dflags $
2313 text "GHCi-specific dynamic flag settings:" $$
2314 nest 2 (vcat (map (setting "-f" "-fno-" gopt) ghciFlags))
2315 putStrLn $ showSDoc dflags $
2316 text "other dynamic, non-language, flag settings:" $$
2317 nest 2 (vcat (map (setting "-f" "-fno-" gopt) others))
2318 putStrLn $ showSDoc dflags $
2319 text "warning settings:" $$
2320 nest 2 (vcat (map (setting "-W" "-Wno-" wopt) DynFlags.wWarningFlags))
2321 where
2322 setting prefix noPrefix test flag
2323 | quiet = empty
2324 | is_on = text prefix <> text name
2325 | otherwise = text noPrefix <> text name
2326 where name = flagSpecName flag
2327 f = flagSpecFlag flag
2328 is_on = test f dflags
2329 quiet = not show_all && test f default_dflags == is_on
2330
2331 default_dflags = defaultDynFlags (settings dflags)
2332
2333 (ghciFlags,others) = partition (\f -> flagSpecFlag f `elem` flgs)
2334 DynFlags.fFlags
2335 flgs = [ Opt_PrintExplicitForalls
2336 , Opt_PrintExplicitKinds
2337 , Opt_PrintUnicodeSyntax
2338 , Opt_PrintBindResult
2339 , Opt_BreakOnException
2340 , Opt_BreakOnError
2341 , Opt_PrintEvldWithShow
2342 ]
2343
2344 setArgs, setOptions :: [String] -> GHCi ()
2345 setProg, setEditor, setStop :: String -> GHCi ()
2346
2347 setArgs args = do
2348 st <- getGHCiState
2349 wrapper <- mkEvalWrapper (progname st) args
2350 setGHCiState st { GhciMonad.args = args, evalWrapper = wrapper }
2351
2352 setProg prog = do
2353 st <- getGHCiState
2354 wrapper <- mkEvalWrapper prog (GhciMonad.args st)
2355 setGHCiState st { progname = prog, evalWrapper = wrapper }
2356
2357 setEditor cmd = modifyGHCiState (\st -> st { editor = cmd })
2358
2359 setStop str@(c:_) | isDigit c
2360 = do let (nm_str,rest) = break (not.isDigit) str
2361 nm = read nm_str
2362 st <- getGHCiState
2363 let old_breaks = breaks st
2364 if all ((/= nm) . fst) old_breaks
2365 then printForUser (text "Breakpoint" <+> ppr nm <+>
2366 text "does not exist")
2367 else do
2368 let new_breaks = map fn old_breaks
2369 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
2370 | otherwise = (i,loc)
2371 setGHCiState st{ breaks = new_breaks }
2372 setStop cmd = modifyGHCiState (\st -> st { stop = cmd })
2373
2374 setPrompt :: String -> GHCi ()
2375 setPrompt = setPrompt_ f err
2376 where
2377 f v st = st { prompt = v }
2378 err st = "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
2379
2380 setPrompt2 :: String -> GHCi ()
2381 setPrompt2 = setPrompt_ f err
2382 where
2383 f v st = st { prompt2 = v }
2384 err st = "syntax: :set prompt2 <prompt>, currently \"" ++ prompt2 st ++ "\""
2385
2386 setPrompt_ :: (String -> GHCiState -> GHCiState) -> (GHCiState -> String) -> String -> GHCi ()
2387 setPrompt_ f err value = do
2388 st <- getGHCiState
2389 if null value
2390 then liftIO $ hPutStrLn stderr $ err st
2391 else case value of
2392 '\"' : _ -> case reads value of
2393 [(value', xs)] | all isSpace xs ->
2394 setGHCiState $ f value' st
2395 _ ->
2396 liftIO $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
2397 _ -> setGHCiState $ f value st
2398
2399 setOptions wds =
2400 do -- first, deal with the GHCi opts (+s, +t, etc.)
2401 let (plus_opts, minus_opts) = partitionWith isPlus wds
2402 mapM_ setOpt plus_opts
2403 -- then, dynamic flags
2404 newDynFlags False minus_opts
2405
2406 packageFlagsChanged :: DynFlags -> DynFlags -> Bool
2407 packageFlagsChanged idflags1 idflags0 =
2408 packageFlags idflags1 /= packageFlags idflags0 ||
2409 ignorePackageFlags idflags1 /= ignorePackageFlags idflags0 ||
2410 pluginPackageFlags idflags1 /= pluginPackageFlags idflags0 ||
2411 trustFlags idflags1 /= trustFlags idflags0
2412
2413 newDynFlags :: Bool -> [String] -> GHCi ()
2414 newDynFlags interactive_only minus_opts = do
2415 let lopts = map noLoc minus_opts
2416
2417 idflags0 <- GHC.getInteractiveDynFlags
2418 (idflags1, leftovers, warns) <- GHC.parseDynamicFlags idflags0 lopts
2419
2420 liftIO $ handleFlagWarnings idflags1 warns
2421 when (not $ null leftovers)
2422 (throwGhcException . CmdLineError
2423 $ "Some flags have not been recognized: "
2424 ++ (concat . intersperse ", " $ map unLoc leftovers))
2425
2426 when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do
2427 liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"
2428 GHC.setInteractiveDynFlags idflags1
2429 installInteractivePrint (interactivePrint idflags1) False
2430
2431 dflags0 <- getDynFlags
2432 when (not interactive_only) $ do
2433 (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags dflags0 lopts
2434 new_pkgs <- GHC.setProgramDynFlags dflags1
2435
2436 -- if the package flags changed, reset the context and link
2437 -- the new packages.
2438 hsc_env <- GHC.getSession
2439 let dflags2 = hsc_dflags hsc_env
2440 when (packageFlagsChanged dflags2 dflags0) $ do
2441 when (verbosity dflags2 > 0) $
2442 liftIO . putStrLn $
2443 "package flags have changed, resetting and loading new packages..."
2444 GHC.setTargets []
2445 _ <- GHC.load LoadAllTargets
2446 liftIO $ linkPackages hsc_env new_pkgs
2447 -- package flags changed, we can't re-use any of the old context
2448 setContextAfterLoad False []
2449 -- and copy the package state to the interactive DynFlags
2450 idflags <- GHC.getInteractiveDynFlags
2451 GHC.setInteractiveDynFlags
2452 idflags{ pkgState = pkgState dflags2
2453 , pkgDatabase = pkgDatabase dflags2
2454 , packageFlags = packageFlags dflags2 }
2455
2456 let ld0length = length $ ldInputs dflags0
2457 fmrk0length = length $ cmdlineFrameworks dflags0
2458
2459 newLdInputs = drop ld0length (ldInputs dflags2)
2460 newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2)
2461
2462 hsc_env' = hsc_env { hsc_dflags =
2463 dflags2 { ldInputs = newLdInputs
2464 , cmdlineFrameworks = newCLFrameworks } }
2465
2466 when (not (null newLdInputs && null newCLFrameworks)) $
2467 liftIO $ linkCmdLineLibs hsc_env'
2468
2469 return ()
2470
2471
2472 unsetOptions :: String -> GHCi ()
2473 unsetOptions str
2474 = -- first, deal with the GHCi opts (+s, +t, etc.)
2475 let opts = words str
2476 (minus_opts, rest1) = partition isMinus opts
2477 (plus_opts, rest2) = partitionWith isPlus rest1
2478 (other_opts, rest3) = partition (`elem` map fst defaulters) rest2
2479
2480 defaulters =
2481 [ ("args" , setArgs default_args)
2482 , ("prog" , setProg default_progname)
2483 , ("prompt" , setPrompt default_prompt)
2484 , ("prompt2", setPrompt2 default_prompt2)
2485 , ("editor" , liftIO findEditor >>= setEditor)
2486 , ("stop" , setStop default_stop)
2487 ]
2488
2489 no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
2490 no_flag ('-':'X':rest) = return ("-XNo" ++ rest)
2491 no_flag f = throwGhcException (ProgramError ("don't know how to reverse " ++ f))
2492
2493 in if (not (null rest3))
2494 then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))
2495 else do
2496 mapM_ (fromJust.flip lookup defaulters) other_opts
2497
2498 mapM_ unsetOpt plus_opts
2499
2500 no_flags <- mapM no_flag minus_opts
2501 newDynFlags False no_flags
2502
2503 isMinus :: String -> Bool
2504 isMinus ('-':_) = True
2505 isMinus _ = False
2506
2507 isPlus :: String -> Either String String
2508 isPlus ('+':opt) = Left opt
2509 isPlus other = Right other
2510
2511 setOpt, unsetOpt :: String -> GHCi ()
2512
2513 setOpt str
2514 = case strToGHCiOpt str of
2515 Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
2516 Just o -> setOption o
2517
2518 unsetOpt str
2519 = case strToGHCiOpt str of
2520 Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
2521 Just o -> unsetOption o
2522
2523 strToGHCiOpt :: String -> (Maybe GHCiOption)
2524 strToGHCiOpt "m" = Just Multiline
2525 strToGHCiOpt "s" = Just ShowTiming
2526 strToGHCiOpt "t" = Just ShowType
2527 strToGHCiOpt "r" = Just RevertCAFs
2528 strToGHCiOpt "c" = Just CollectInfo
2529 strToGHCiOpt _ = Nothing
2530
2531 optToStr :: GHCiOption -> String
2532 optToStr Multiline = "m"
2533 optToStr ShowTiming = "s"
2534 optToStr ShowType = "t"
2535 optToStr RevertCAFs = "r"
2536 optToStr CollectInfo = "c"
2537
2538
2539 -- ---------------------------------------------------------------------------
2540 -- :show
2541
2542 showCmd :: String -> GHCi ()
2543 showCmd "" = showOptions False
2544 showCmd "-a" = showOptions True
2545 showCmd str = do
2546 st <- getGHCiState
2547 dflags <- getDynFlags
2548
2549 let lookupCmd :: String -> Maybe (GHCi ())
2550 lookupCmd name = lookup name $ map (\(_,b,c) -> (b,c)) cmds
2551
2552 -- (show in help?, command name, action)
2553 action :: String -> GHCi () -> (Bool, String, GHCi ())
2554 action name m = (True, name, m)
2555
2556 hidden :: String -> GHCi () -> (Bool, String, GHCi ())
2557 hidden name m = (False, name, m)
2558
2559 cmds =
2560 [ action "args" $ liftIO $ putStrLn (show (GhciMonad.args st))
2561 , action "prog" $ liftIO $ putStrLn (show (progname st))
2562 , action "prompt" $ liftIO $ putStrLn (show (prompt st))
2563 , action "prompt2" $ liftIO $ putStrLn (show (prompt2 st))
2564 , action "editor" $ liftIO $ putStrLn (show (editor st))
2565 , action "stop" $ liftIO $ putStrLn (show (stop st))
2566 , action "imports" $ showImports
2567 , action "modules" $ showModules
2568 , action "bindings" $ showBindings
2569 , action "linker" $ getDynFlags >>= liftIO . showLinkerState
2570 , action "breaks" $ showBkptTable
2571 , action "context" $ showContext
2572 , action "packages" $ showPackages
2573 , action "paths" $ showPaths
2574 , action "language" $ showLanguages
2575 , hidden "languages" $ showLanguages -- backwards compat
2576 , hidden "lang" $ showLanguages -- useful abbreviation
2577 ]
2578
2579 case words str of
2580 [w] | Just action <- lookupCmd w -> action
2581
2582 _ -> let helpCmds = [ text name | (True, name, _) <- cmds ]
2583 in throwGhcException $ CmdLineError $ showSDoc dflags
2584 $ hang (text "syntax:") 4
2585 $ hang (text ":show") 6
2586 $ brackets (fsep $ punctuate (text " |") helpCmds)
2587
2588 showiCmd :: String -> GHCi ()
2589 showiCmd str = do
2590 case words str of
2591 ["languages"] -> showiLanguages -- backwards compat
2592 ["language"] -> showiLanguages
2593 ["lang"] -> showiLanguages -- useful abbreviation
2594 _ -> throwGhcException (CmdLineError ("syntax: :showi language"))
2595
2596 showImports :: GHCi ()
2597 showImports = do
2598 st <- getGHCiState
2599 dflags <- getDynFlags
2600 let rem_ctx = reverse (remembered_ctx st)
2601 trans_ctx = transient_ctx st
2602
2603 show_one (IIModule star_m)
2604 = ":module +*" ++ moduleNameString star_m
2605 show_one (IIDecl imp) = showPpr dflags imp
2606
2607 prel_imp
2608 | any isPreludeImport (rem_ctx ++ trans_ctx) = []
2609 | not (xopt LangExt.ImplicitPrelude dflags) = []
2610 | otherwise = ["import Prelude -- implicit"]
2611
2612 trans_comment s = s ++ " -- added automatically" :: String
2613 --
2614 liftIO $ mapM_ putStrLn (prel_imp ++ map show_one rem_ctx
2615 ++ map (trans_comment . show_one) trans_ctx)
2616
2617 showModules :: GHCi ()
2618 showModules = do
2619 loaded_mods <- getLoadedModules
2620 -- we want *loaded* modules only, see #1734
2621 let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)
2622 mapM_ show_one loaded_mods
2623
2624 getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
2625 getLoadedModules = do
2626 graph <- GHC.getModuleGraph
2627 filterM (GHC.isLoaded . GHC.ms_mod_name) graph
2628
2629 showBindings :: GHCi ()
2630 showBindings = do
2631 bindings <- GHC.getBindings
2632 (insts, finsts) <- GHC.getInsts
2633 docs <- mapM makeDoc (reverse bindings)
2634 -- reverse so the new ones come last
2635 let idocs = map GHC.pprInstanceHdr insts
2636 fidocs = map GHC.pprFamInst finsts
2637 mapM_ printForUserPartWay (docs ++ idocs ++ fidocs)
2638 where
2639 makeDoc (AnId i) = pprTypeAndContents i
2640 makeDoc tt = do
2641 mb_stuff <- GHC.getInfo False (getName tt)
2642 return $ maybe (text "") pprTT mb_stuff
2643
2644 pprTT :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc
2645 pprTT (thing, fixity, _cls_insts, _fam_insts)
2646 = pprTyThing thing
2647 $$ show_fixity
2648 where
2649 show_fixity
2650 | fixity == GHC.defaultFixity = empty
2651 | otherwise = ppr fixity <+> ppr (GHC.getName thing)
2652
2653
2654 printTyThing :: TyThing -> GHCi ()
2655 printTyThing tyth = printForUser (pprTyThing tyth)
2656
2657 showBkptTable :: GHCi ()
2658 showBkptTable = do
2659 st <- getGHCiState
2660 printForUser $ prettyLocations (breaks st)
2661
2662 showContext :: GHCi ()
2663 showContext = do
2664 resumes <- GHC.getResumeContext
2665 printForUser $ vcat (map pp_resume (reverse resumes))
2666 where
2667 pp_resume res =
2668 ptext (sLit "--> ") <> text (GHC.resumeStmt res)
2669 $$ nest 2 (pprStopped res)
2670
2671 pprStopped :: GHC.Resume -> SDoc
2672 pprStopped res =
2673 ptext (sLit "Stopped in")
2674 <+> ((case mb_mod_name of
2675 Nothing -> empty
2676 Just mod_name -> text (moduleNameString mod_name) <> char '.')
2677 <> text (GHC.resumeDecl res))
2678 <> char ',' <+> ppr (GHC.resumeSpan res)
2679 where
2680 mb_mod_name = moduleName <$> GHC.breakInfo_module <$> GHC.resumeBreakInfo res
2681
2682 showPackages :: GHCi ()
2683 showPackages = do
2684 dflags <- getDynFlags
2685 let pkg_flags = packageFlags dflags
2686 liftIO $ putStrLn $ showSDoc dflags $
2687 text ("active package flags:"++if null pkg_flags then " none" else "") $$
2688 nest 2 (vcat (map pprFlag pkg_flags))
2689
2690 showPaths :: GHCi ()
2691 showPaths = do
2692 dflags <- getDynFlags
2693 liftIO $ do
2694 cwd <- getCurrentDirectory
2695 putStrLn $ showSDoc dflags $
2696 text "current working directory: " $$
2697 nest 2 (text cwd)
2698 let ipaths = importPaths dflags
2699 putStrLn $ showSDoc dflags $
2700 text ("module import search paths:"++if null ipaths then " none" else "") $$
2701 nest 2 (vcat (map text ipaths))
2702
2703 showLanguages :: GHCi ()
2704 showLanguages = getDynFlags >>= liftIO . showLanguages' False
2705
2706 showiLanguages :: GHCi ()
2707 showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False
2708
2709 showLanguages' :: Bool -> DynFlags -> IO ()
2710 showLanguages' show_all dflags =
2711 putStrLn $ showSDoc dflags $ vcat
2712 [ text "base language is: " <>
2713 case language dflags of
2714 Nothing -> text "Haskell2010"
2715 Just Haskell98 -> text "Haskell98"
2716 Just Haskell2010 -> text "Haskell2010"
2717 , (if show_all then text "all active language options:"
2718 else text "with the following modifiers:") $$
2719 nest 2 (vcat (map (setting xopt) DynFlags.xFlags))
2720 ]
2721 where
2722 setting test flag
2723 | quiet = empty
2724 | is_on = text "-X" <> text name
2725 | otherwise = text "-XNo" <> text name
2726 where name = flagSpecName flag
2727 f = flagSpecFlag flag
2728 is_on = test f dflags
2729 quiet = not show_all && test f default_dflags == is_on
2730
2731 default_dflags =
2732 defaultDynFlags (settings dflags) `lang_set`
2733 case language dflags of
2734 Nothing -> Just Haskell2010
2735 other -> other
2736
2737 -- -----------------------------------------------------------------------------
2738 -- Completion
2739
2740 completeCmd :: String -> GHCi ()
2741 completeCmd argLine0 = case parseLine argLine0 of
2742 Just ("repl", resultRange, left) -> do
2743 (unusedLine,compls) <- ghciCompleteWord (reverse left,"")
2744 let compls' = takeRange resultRange compls
2745 liftIO . putStrLn $ unwords [ show (length compls'), show (length compls), show (reverse unusedLine) ]
2746 forM_ (takeRange resultRange compls) $ \(Completion r _ _) -> do
2747 liftIO $ print r
2748 _ -> throwGhcException (CmdLineError "Syntax: :complete repl [<range>] <quoted-string-to-complete>")
2749 where
2750 parseLine argLine
2751 | null argLine = Nothing
2752 | null rest1 = Nothing
2753 | otherwise = (,,) dom <$> resRange <*> s
2754 where
2755 (dom, rest1) = breakSpace argLine
2756 (rng, rest2) = breakSpace rest1
2757 resRange | head rest1 == '"' = parseRange ""
2758 | otherwise = parseRange rng
2759 s | head rest1 == '"' = readMaybe rest1 :: Maybe String
2760 | otherwise = readMaybe rest2
2761 breakSpace = fmap (dropWhile isSpace) . break isSpace
2762
2763 takeRange (lb,ub) = maybe id (drop . pred) lb . maybe id take ub
2764
2765 -- syntax: [n-][m] with semantics "drop (n-1) . take m"
2766 parseRange :: String -> Maybe (Maybe Int,Maybe Int)
2767 parseRange s = case span isDigit s of
2768 (_, "") ->
2769 -- upper limit only
2770 Just (Nothing, bndRead s)
2771 (s1, '-' : s2)
2772 | all isDigit s2 ->
2773 Just (bndRead s1, bndRead s2)
2774 _ ->
2775 Nothing
2776 where
2777 bndRead x = if null x then Nothing else Just (read x)
2778
2779
2780
2781 completeGhciCommand, completeMacro, completeIdentifier, completeModule,
2782 completeSetModule, completeSeti, completeShowiOptions,
2783 completeHomeModule, completeSetOptions, completeShowOptions,
2784 completeHomeModuleOrFile, completeExpression
2785 :: CompletionFunc GHCi
2786
2787 -- | Provide completions for last word in a given string.
2788 --
2789 -- Takes a tuple of two strings. First string is a reversed line to be
2790 -- completed. Second string is likely unused, 'completeCmd' always passes an
2791 -- empty string as second item in tuple.
2792 ghciCompleteWord :: CompletionFunc GHCi
2793 ghciCompleteWord line@(left,_) = case firstWord of
2794 -- If given string starts with `:` colon, and there is only one following
2795 -- word then provide REPL command completions. If there is more than one
2796 -- word complete either filename or builtin ghci commands or macros.
2797 ':':cmd | null rest -> completeGhciCommand line
2798 | otherwise -> do
2799 completion <- lookupCompletion cmd
2800 completion line
2801 -- If given string starts with `import` keyword provide module name
2802 -- completions
2803 "import" -> completeModule line
2804 -- otherwise provide identifier completions
2805 _ -> completeExpression line
2806 where
2807 (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
2808 lookupCompletion ('!':_) = return completeFilename
2809 lookupCompletion c = do
2810 maybe_cmd <- lookupCommand' c
2811 case maybe_cmd of
2812 Just cmd -> return (cmdCompletionFunc cmd)
2813 Nothing -> return completeFilename
2814
2815 completeGhciCommand = wrapCompleter " " $ \w -> do
2816 macros <- ghci_macros <$> getGHCiState
2817 cmds <- ghci_commands `fmap` getGHCiState
2818 let macro_names = map (':':) . map cmdName $ macros
2819 let command_names = map (':':) . map cmdName $ filter (not . cmdHidden) cmds
2820 let{ candidates = case w of
2821 ':' : ':' : _ -> map (':':) command_names
2822 _ -> nub $ macro_names ++ command_names }
2823 return $ filter (w `isPrefixOf`) candidates
2824
2825 completeMacro = wrapIdentCompleter $ \w -> do
2826 cmds <- ghci_macros <$> getGHCiState
2827 return (filter (w `isPrefixOf`) (map cmdName cmds))
2828
2829 completeIdentifier line@(left, _) =
2830 -- Note: `left` is a reversed input
2831 case left of
2832 (x:_) | isSymbolChar x -> wrapCompleter (specials ++ spaces) complete line
2833 _ -> wrapIdentCompleter complete line
2834 where
2835 complete w = do
2836 rdrs <- GHC.getRdrNamesInScope
2837 dflags <- GHC.getSessionDynFlags
2838 return (filter (w `isPrefixOf`) (map (showPpr dflags) rdrs))
2839
2840 completeModule = wrapIdentCompleter $ \w -> do
2841 dflags <- GHC.getSessionDynFlags
2842 let pkg_mods = allVisibleModules dflags
2843 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
2844 return $ filter (w `isPrefixOf`)
2845 $ map (showPpr dflags) $ loaded_mods ++ pkg_mods
2846
2847 completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
2848 dflags <- GHC.getSessionDynFlags
2849 modules <- case m of
2850 Just '-' -> do
2851 imports <- GHC.getContext
2852 return $ map iiModuleName imports
2853 _ -> do
2854 let pkg_mods = allVisibleModules dflags
2855 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
2856 return $ loaded_mods ++ pkg_mods
2857 return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules
2858
2859 completeHomeModule = wrapIdentCompleter listHomeModules
2860
2861 listHomeModules :: String -> GHCi [String]
2862 listHomeModules w = do
2863 g <- GHC.getModuleGraph
2864 let home_mods = map GHC.ms_mod_name g
2865 dflags <- getDynFlags
2866 return $ sort $ filter (w `isPrefixOf`)
2867 $ map (showPpr dflags) home_mods
2868
2869 completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
2870 return (filter (w `isPrefixOf`) opts)
2871 where opts = "args":"prog":"prompt":"prompt2":"editor":"stop":flagList
2872 flagList = map head $ group $ sort allNonDeprecatedFlags
2873
2874 completeSeti = wrapCompleter flagWordBreakChars $ \w -> do
2875 return (filter (w `isPrefixOf`) flagList)
2876 where flagList = map head $ group $ sort allNonDeprecatedFlags
2877
2878 completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
2879 return (filter (w `isPrefixOf`) opts)
2880 where opts = ["args", "prog", "prompt", "prompt2", "editor", "stop",
2881 "modules", "bindings", "linker", "breaks",
2882 "context", "packages", "paths", "language", "imports"]
2883
2884 completeShowiOptions = wrapCompleter flagWordBreakChars $ \w -> do
2885 return (filter (w `isPrefixOf`) ["language"])
2886
2887 completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
2888 $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
2889 listFiles
2890
2891 unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
2892 unionComplete f1 f2 line = do
2893 cs1 <- f1 line
2894 cs2 <- f2 line
2895 return (cs1 ++ cs2)
2896
2897 wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
2898 wrapCompleter breakChars fun = completeWord Nothing breakChars
2899 $ fmap (map simpleCompletion . nubSort) . fun
2900
2901 wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
2902 wrapIdentCompleter = wrapCompleter word_break_chars
2903
2904 wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi
2905 wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars
2906 $ \rest -> fmap (map simpleCompletion . nubSort) . fun (getModifier rest)
2907 where
2908 getModifier = find (`elem` modifChars)
2909
2910 -- | Return a list of visible module names for autocompletion.
2911 -- (NB: exposed != visible)
2912 allVisibleModules :: DynFlags -> [ModuleName]
2913 allVisibleModules dflags = listVisibleModuleNames dflags
2914
2915 completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
2916 completeIdentifier
2917
2918
2919 -- -----------------------------------------------------------------------------
2920 -- commands for debugger
2921
2922 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
2923 sprintCmd = pprintCommand False False
2924 printCmd = pprintCommand True False
2925 forceCmd = pprintCommand False True
2926
2927 pprintCommand :: Bool -> Bool -> String -> GHCi ()
2928 pprintCommand bind force str = do
2929 pprintClosureCommand bind force str
2930
2931 stepCmd :: String -> GHCi ()
2932 stepCmd arg = withSandboxOnly ":step" $ step arg
2933 where
2934 step [] = doContinue (const True) GHC.SingleStep
2935 step expression = runStmt expression GHC.SingleStep >> return ()
2936
2937 stepLocalCmd :: String -> GHCi ()
2938 stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg
2939 where
2940 step expr
2941 | not (null expr) = stepCmd expr
2942 | otherwise = do
2943 mb_span <- getCurrentBreakSpan
2944 case mb_span of
2945 Nothing -> stepCmd []
2946 Just loc -> do
2947 Just md <- getCurrentBreakModule
2948 current_toplevel_decl <- enclosingTickSpan md loc
2949 doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl) GHC.SingleStep
2950
2951 stepModuleCmd :: String -> GHCi ()
2952 stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg
2953 where
2954 step expr
2955 | not (null expr) = stepCmd expr
2956 | otherwise = do
2957 mb_span <- getCurrentBreakSpan
2958 case mb_span of
2959 Nothing -> stepCmd []
2960 Just pan -> do
2961 let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span
2962 doContinue f GHC.SingleStep
2963
2964 -- | Returns the span of the largest tick containing the srcspan given
2965 enclosingTickSpan :: Module -> SrcSpan -> GHCi RealSrcSpan
2966 enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
2967 enclosingTickSpan md (RealSrcSpan src) = do
2968 ticks <- getTickArray md
2969 let line = srcSpanStartLine src
2970 ASSERT(inRange (bounds ticks) line) do
2971 let enclosing_spans = [ pan | (_,pan) <- ticks ! line
2972 , realSrcSpanEnd pan >= realSrcSpanEnd src]
2973 return . head . sortBy leftmostLargestRealSrcSpan $ enclosing_spans
2974 where
2975
2976 leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering
2977 leftmostLargestRealSrcSpan a b =
2978 (realSrcSpanStart a `compare` realSrcSpanStart b)
2979 `thenCmp`
2980 (realSrcSpanEnd b `compare` realSrcSpanEnd a)
2981
2982 traceCmd :: String -> GHCi ()
2983 traceCmd arg
2984 = withSandboxOnly ":trace" $ tr arg
2985 where
2986 tr [] = doContinue (const True) GHC.RunAndLogSteps
2987 tr expression = runStmt expression GHC.RunAndLogSteps >> return ()
2988
2989 continueCmd :: String -> GHCi ()
2990 continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion
2991
2992 -- doContinue :: SingleStep -> GHCi ()
2993 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
2994 doContinue pre step = do
2995 runResult <- resume pre step
2996 _ <- afterRunStmt pre runResult
2997 return ()
2998
2999 abandonCmd :: String -> GHCi ()
3000 abandonCmd = noArgs $ withSandboxOnly ":abandon" $ do
3001 b <- GHC.abandon -- the prompt will change to indicate the new context
3002 when (not b) $ liftIO $ putStrLn "There is no computation running."
3003
3004 deleteCmd :: String -> GHCi ()
3005 deleteCmd argLine = withSandboxOnly ":delete" $ do
3006 deleteSwitch $ words argLine
3007 where
3008 deleteSwitch :: [String] -> GHCi ()
3009 deleteSwitch [] =
3010 liftIO $ putStrLn "The delete command requires at least one argument."
3011 -- delete all break points
3012 deleteSwitch ("*":_rest) = discardActiveBreakPoints
3013 deleteSwitch idents = do
3014 mapM_ deleteOneBreak idents
3015 where
3016 deleteOneBreak :: String -> GHCi ()
3017 deleteOneBreak str
3018 | all isDigit str = deleteBreak (read str)
3019 | otherwise = return ()
3020
3021 historyCmd :: String -> GHCi ()
3022 historyCmd arg
3023 | null arg = history 20
3024 | all isDigit arg = history (read arg)
3025 | otherwise = liftIO $ putStrLn "Syntax: :history [num]"
3026 where
3027 history num = do
3028 resumes <- GHC.getResumeContext
3029 case resumes of
3030 [] -> liftIO $ putStrLn "Not stopped at a breakpoint"
3031 (r:_) -> do
3032 let hist = GHC.resumeHistory r
3033 (took,rest) = splitAt num hist
3034 case hist of
3035 [] -> liftIO $ putStrLn $
3036 "Empty history. Perhaps you forgot to use :trace?"
3037 _ -> do
3038 pans <- mapM GHC.getHistorySpan took
3039 let nums = map (printf "-%-3d:") [(1::Int)..]
3040 names = map GHC.historyEnclosingDecls took
3041 printForUser (vcat(zipWith3
3042 (\x y z -> x <+> y <+> z)
3043 (map text nums)
3044 (map (bold . hcat . punctuate colon . map text) names)
3045 (map (parens . ppr) pans)))
3046 liftIO $ putStrLn $ if null rest then "<end of history>" else "..."
3047
3048 bold :: SDoc -> SDoc
3049 bold c | do_bold = text start_bold <> c <> text end_bold
3050 | otherwise = c
3051
3052 backCmd :: String -> GHCi ()
3053 backCmd arg
3054 | null arg = back 1
3055 | all isDigit arg = back (read arg)
3056 | otherwise = liftIO $ putStrLn "Syntax: :back [num]"
3057 where
3058 back num = withSandboxOnly ":back" $ do
3059 (names, _, pan, _) <- GHC.back num
3060 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan
3061 printTypeOfNames names
3062 -- run the command set with ":set stop <cmd>"
3063 st <- getGHCiState
3064 enqueueCommands [stop st]
3065
3066 forwardCmd :: String -> GHCi ()
3067 forwardCmd arg
3068 | null arg = forward 1
3069 | all isDigit arg = forward (read arg)
3070 | otherwise = liftIO $ putStrLn "Syntax: :back [num]"
3071 where
3072 forward num = withSandboxOnly ":forward" $ do
3073 (names, ix, pan, _) <- GHC.forward num
3074 printForUser $ (if (ix == 0)
3075 then ptext (sLit "Stopped at")
3076 else ptext (sLit "Logged breakpoint at")) <+> ppr pan
3077 printTypeOfNames names
3078 -- run the command set with ":set stop <cmd>"
3079 st <- getGHCiState
3080 enqueueCommands [stop st]
3081
3082 -- handle the "break" command
3083 breakCmd :: String -> GHCi ()
3084 breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine
3085
3086 breakSwitch :: [String] -> GHCi ()
3087 breakSwitch [] = do
3088 liftIO $ putStrLn "The break command requires at least one argument."
3089 breakSwitch (arg1:rest)
3090 | looksLikeModuleName arg1 && not (null rest) = do
3091 md <- wantInterpretedModule arg1
3092 breakByModule md rest
3093 | all isDigit arg1 = do
3094 imports <- GHC.getContext
3095 case iiModules imports of
3096 (mn : _) -> do
3097 md <- lookupModuleName mn
3098 breakByModuleLine md (read arg1) rest
3099 [] -> do
3100 liftIO $ putStrLn "No modules are loaded with debugging support."
3101 | otherwise = do -- try parsing it as an identifier
3102 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
3103 maybe_info <- GHC.getModuleInfo (GHC.nameModule name)
3104 case maybe_info of
3105 Nothing -> noCanDo name (ptext (sLit "cannot get module info"))
3106 Just minf ->
3107 ASSERT( isExternalName name )
3108 findBreakAndSet (GHC.nameModule name) $
3109 findBreakForBind name (GHC.modInfoModBreaks minf)
3110 where
3111 noCanDo n why = printForUser $
3112 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
3113
3114 breakByModule :: Module -> [String] -> GHCi ()
3115 breakByModule md (arg1:rest)
3116 | all isDigit arg1 = do -- looks like a line number
3117 breakByModuleLine md (read arg1) rest
3118 breakByModule _ _
3119 = breakSyntax
3120
3121 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
3122 breakByModuleLine md line args
3123 | [] <- args = findBreakAndSet md $ maybeToList . findBreakByLine line
3124 | [col] <- args, all isDigit col =
3125 findBreakAndSet md $ maybeToList . findBreakByCoord Nothing (line, read col)
3126 | otherwise = breakSyntax
3127
3128 breakSyntax :: a
3129 breakSyntax = throwGhcException (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
3130
3131 findBreakAndSet :: Module -> (TickArray -> [(Int, RealSrcSpan)]) -> GHCi ()
3132 findBreakAndSet md lookupTickTree = do
3133 tickArray <- getTickArray md
3134 (breakArray, _) <- getModBreak md
3135 case lookupTickTree tickArray of
3136 [] -> liftIO $ putStrLn $ "No breakpoints found at that location."
3137 some -> mapM_ (breakAt breakArray) some
3138 where
3139 breakAt breakArray (tick, pan) = do
3140 setBreakFlag True breakArray tick
3141 (alreadySet, nm) <-
3142 recordBreak $ BreakLocation
3143 { breakModule = md
3144 , breakLoc = RealSrcSpan pan
3145 , breakTick = tick
3146 , onBreakCmd = ""
3147 }
3148 printForUser $
3149 text "Breakpoint " <> ppr nm <>
3150 if alreadySet
3151 then text " was already set at " <> ppr pan
3152 else text " activated at " <> ppr pan
3153
3154 -- When a line number is specified, the current policy for choosing
3155 -- the best breakpoint is this:
3156 -- - the leftmost complete subexpression on the specified line, or
3157 -- - the leftmost subexpression starting on the specified line, or
3158 -- - the rightmost subexpression enclosing the specified line
3159 --
3160 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,RealSrcSpan)
3161 findBreakByLine line arr
3162 | not (inRange (bounds arr) line) = Nothing
3163 | otherwise =
3164 listToMaybe (sortBy (leftmostLargestRealSrcSpan `on` snd) comp) `mplus`
3165 listToMaybe (sortBy (compare `on` snd) incomp) `mplus`
3166 listToMaybe (sortBy (flip compare `on` snd) ticks)
3167 where
3168 ticks = arr ! line
3169
3170 starts_here = [ (ix,pan) | (ix, pan) <- ticks,
3171 GHC.srcSpanStartLine pan == line ]
3172
3173 (comp, incomp) = partition ends_here starts_here
3174 where ends_here (_,pan) = GHC.srcSpanEndLine pan == line
3175
3176 -- The aim is to find the breakpionts for all the RHSs of the
3177 -- equations corresponding to a binding. So we find all breakpoints
3178 -- for
3179 -- (a) this binder only (not a nested declaration)
3180 -- (b) that do not have an enclosing breakpoint
3181 findBreakForBind :: Name -> GHC.ModBreaks -> TickArray
3182 -> [(BreakIndex,RealSrcSpan)]
3183 findBreakForBind name modbreaks _ = filter (not . enclosed) ticks
3184 where
3185 ticks = [ (index, span)
3186 | (index, [n]) <- assocs (GHC.modBreaks_decls modbreaks),
3187 n == occNameString (nameOccName name),
3188 RealSrcSpan span <- [GHC.modBreaks_locs modbreaks ! index] ]
3189 enclosed (_,sp0) = any subspan ticks
3190 where subspan (_,sp) = sp /= sp0 &&
3191 realSrcSpanStart sp <= realSrcSpanStart sp0 &&
3192 realSrcSpanEnd sp0 <= realSrcSpanEnd sp
3193
3194 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
3195 -> Maybe (BreakIndex,RealSrcSpan)
3196 findBreakByCoord mb_file (line, col) arr
3197 | not (inRange (bounds arr) line) = Nothing
3198 | otherwise =
3199 listToMaybe (sortBy (flip compare `on` snd) contains ++
3200 sortBy (compare `on` snd) after_here)
3201 where
3202 ticks = arr ! line
3203
3204 -- the ticks that span this coordinate
3205 contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan `spans` (line,col),
3206 is_correct_file pan ]
3207
3208 is_correct_file pan
3209 | Just f <- mb_file = GHC.srcSpanFile pan == f
3210 | otherwise = True
3211
3212 after_here = [ tick | tick@(_,pan) <- ticks,
3213 GHC.srcSpanStartLine pan == line,
3214 GHC.srcSpanStartCol pan >= col ]
3215
3216 -- For now, use ANSI bold on terminals that we know support it.
3217 -- Otherwise, we add a line of carets under the active expression instead.
3218 -- In particular, on Windows and when running the testsuite (which sets
3219 -- TERM to vt100 for other reasons) we get carets.
3220 -- We really ought to use a proper termcap/terminfo library.
3221 do_bold :: Bool
3222 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
3223 where mTerm = System.Environment.getEnv "TERM"
3224 `catchIO` \_ -> return "TERM not set"
3225
3226 start_bold :: String
3227 start_bold = "\ESC[1m"
3228 end_bold :: String
3229 end_bold = "\ESC[0m"
3230
3231 -----------------------------------------------------------------------------
3232 -- :where
3233
3234 whereCmd :: String -> GHCi ()
3235 whereCmd = noArgs $ do
3236 mstrs <- getCallStackAtCurrentBreakpoint
3237 case mstrs of
3238 Nothing -> return ()
3239 Just strs -> liftIO $ putStrLn (renderStack strs)
3240
3241 -----------------------------------------------------------------------------
3242 -- :list
3243
3244 listCmd :: String -> InputT GHCi ()
3245 listCmd c = listCmd' c
3246
3247 listCmd' :: String -> InputT GHCi ()
3248 listCmd' "" = do
3249 mb_span <- lift getCurrentBreakSpan
3250 case mb_span of
3251 Nothing ->
3252 printForUser $ text "Not stopped at a breakpoint; nothing to list"
3253 Just (RealSrcSpan pan) ->
3254 listAround pan True
3255 Just pan@(UnhelpfulSpan _) ->
3256 do resumes <- GHC.getResumeContext
3257 case resumes of
3258 [] -> panic "No resumes"
3259 (r:_) ->
3260 do let traceIt = case GHC.resumeHistory r of
3261 [] -> text "rerunning with :trace,"
3262 _ -> empty
3263 doWhat = traceIt <+> text ":back then :list"
3264 printForUser (text "Unable to list source for" <+>
3265 ppr pan
3266 $$ text "Try" <+> doWhat)
3267 listCmd' str = list2 (words str)
3268
3269 list2 :: [String] -> InputT GHCi ()
3270 list2 [arg] | all isDigit arg = do
3271 imports <- GHC.getContext
3272 case iiModules imports of
3273 [] -> liftIO $ putStrLn "No module to list"
3274 (mn : _) -> do
3275 md <- lift $ lookupModuleName mn
3276 listModuleLine md (read arg)
3277 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
3278 md <- wantInterpretedModule arg1
3279 listModuleLine md (read arg2)
3280 list2 [arg] = do
3281 wantNameFromInterpretedModule noCanDo arg $ \name -> do
3282 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
3283 case loc of
3284 RealSrcLoc l ->
3285 do tickArray <- ASSERT( isExternalName name )
3286 lift $ getTickArray (GHC.nameModule name)
3287 let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))
3288 (GHC.srcLocLine l, GHC.srcLocCol l)
3289 tickArray
3290 case mb_span of
3291 Nothing -> listAround (realSrcLocSpan l) False
3292 Just (_, pan) -> listAround pan False
3293 UnhelpfulLoc _ ->
3294 noCanDo name $ text "can't find its location: " <>
3295 ppr loc
3296 where
3297 noCanDo n why = printForUser $
3298 text "cannot list source code for " <> ppr n <> text ": " <> why
3299 list2 _other =
3300 liftIO $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
3301
3302 listModuleLine :: Module -> Int -> InputT GHCi ()
3303 listModuleLine modl line = do
3304 graph <- GHC.getModuleGraph
3305 let this = filter ((== modl) . GHC.ms_mod) graph
3306 case this of
3307 [] -> panic "listModuleLine"
3308 summ:_ -> do
3309 let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
3310 loc = mkRealSrcLoc (mkFastString (filename)) line 0
3311 listAround (realSrcLocSpan loc) False
3312
3313 -- | list a section of a source file around a particular SrcSpan.
3314 -- If the highlight flag is True, also highlight the span using
3315 -- start_bold\/end_bold.
3316
3317 -- GHC files are UTF-8, so we can implement this by:
3318 -- 1) read the file in as a BS and syntax highlight it as before
3319 -- 2) convert the BS to String using utf-string, and write it out.
3320 -- It would be better if we could convert directly between UTF-8 and the
3321 -- console encoding, of course.
3322 listAround :: MonadIO m => RealSrcSpan -> Bool -> InputT m ()
3323 listAround pan do_highlight = do
3324 contents <- liftIO $ BS.readFile (unpackFS file)
3325 -- Drop carriage returns to avoid duplicates, see #9367.
3326 let ls = BS.split '\n' $ BS.filter (/= '\r') contents
3327 ls' = take (line2 - line1 + 1 + pad_before + pad_after) $
3328 drop (line1 - 1 - pad_before) $ ls
3329 fst_line = max 1 (line1 - pad_before)
3330 line_nos = [ fst_line .. ]
3331
3332 highlighted | do_highlight = zipWith highlight line_nos ls'
3333 | otherwise = [\p -> BS.concat[p,l] | l <- ls']
3334
3335 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
3336 prefixed = zipWith ($) highlighted bs_line_nos
3337 output = BS.intercalate (BS.pack "\n") prefixed
3338
3339 utf8Decoded <- liftIO $ BS.useAsCStringLen output
3340 $ \(p,n) -> utf8DecodeString (castPtr p) n
3341 liftIO $ putStrLn utf8Decoded
3342 where
3343 file = GHC.srcSpanFile pan
3344 line1 = GHC.srcSpanStartLine pan
3345 col1 = GHC.srcSpanStartCol pan - 1
3346 line2 = GHC.srcSpanEndLine pan
3347 col2 = GHC.srcSpanEndCol pan - 1
3348
3349 pad_before | line1 == 1 = 0
3350 | otherwise = 1
3351 pad_after = 1
3352
3353 highlight | do_bold = highlight_bold
3354 | otherwise = highlight_carets
3355
3356 highlight_bold no line prefix
3357 | no == line1 && no == line2
3358 = let (a,r) = BS.splitAt col1 line
3359 (b,c) = BS.splitAt (col2-col1) r
3360 in
3361 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
3362 | no == line1
3363 = let (a,b) = BS.splitAt col1 line in
3364 BS.concat [prefix, a, BS.pack start_bold, b]
3365 | no == line2
3366 = let (a,b) = BS.splitAt col2 line in
3367 BS.concat [prefix, a, BS.pack end_bold, b]
3368 | otherwise = BS.concat [prefix, line]
3369
3370 highlight_carets no line prefix
3371 | no == line1 && no == line2
3372 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
3373 BS.replicate (col2-col1) '^']
3374 | no == line1
3375 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
3376 prefix, line]
3377 | no == line2
3378 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
3379 BS.pack "^^"]
3380 | otherwise = BS.concat [prefix, line]
3381 where
3382 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
3383 nl = BS.singleton '\n'
3384
3385
3386 -- --------------------------------------------------------------------------
3387 -- Tick arrays
3388
3389 getTickArray :: Module -> GHCi TickArray
3390 getTickArray modl = do
3391 st <- getGHCiState
3392 let arrmap = tickarrays st
3393 case lookupModuleEnv arrmap modl of
3394 Just arr -> return arr
3395 Nothing -> do
3396 (_breakArray, ticks) <- getModBreak modl
3397 let arr = mkTickArray (assocs ticks)
3398 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
3399 return arr
3400
3401 discardTickArrays :: GHCi ()
3402 discardTickArrays = modifyGHCiState (\st -> st {tickarrays = emptyModuleEnv})
3403
3404 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
3405 mkTickArray ticks
3406 = accumArray (flip (:)) [] (1, max_line)
3407 [ (line, (nm,pan)) | (nm,RealSrcSpan pan) <- ticks, line <- srcSpanLines pan ]
3408 where
3409 max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp) <- ticks ]
3410 srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ]
3411
3412 -- don't reset the counter back to zero?
3413 discardActiveBreakPoints :: GHCi ()
3414 discardActiveBreakPoints = do
3415 st <- getGHCiState
3416 mapM_ (turnOffBreak.snd) (breaks st)
3417 setGHCiState $ st { breaks = [] }
3418
3419 deleteBreak :: Int -> GHCi ()
3420 deleteBreak identity = do
3421 st <- getGHCiState
3422 let oldLocations = breaks st
3423 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
3424 if null this
3425 then printForUser (text "Breakpoint" <+> ppr identity <+>
3426 text "does not exist")
3427 else do
3428 mapM_ (turnOffBreak.snd) this
3429 setGHCiState $ st { breaks = rest }
3430
3431 turnOffBreak :: BreakLocation -> GHCi ()
3432 turnOffBreak loc = do
3433 (arr, _) <- getModBreak (breakModule loc)
3434 hsc_env <- GHC.getSession
3435 liftIO $ enableBreakpoint hsc_env arr (breakTick loc) False
3436
3437 getModBreak :: Module -> GHCi (ForeignRef BreakArray, Array Int SrcSpan)
3438 getModBreak m = do
3439 Just mod_info <- GHC.getModuleInfo m
3440 let modBreaks = GHC.modInfoModBreaks mod_info
3441 let arr = GHC.modBreaks_flags modBreaks
3442 let ticks = GHC.modBreaks_locs modBreaks
3443 return (arr, ticks)
3444
3445 setBreakFlag :: Bool -> ForeignRef BreakArray -> Int -> GHCi ()
3446 setBreakFlag toggle arr i = do
3447 hsc_env <- GHC.getSession
3448 liftIO $ enableBreakpoint hsc_env arr i toggle
3449
3450 -- ---------------------------------------------------------------------------
3451 -- User code exception handling
3452
3453 -- This is the exception handler for exceptions generated by the
3454 -- user's code and exceptions coming from children sessions;
3455 -- it normally just prints out the exception. The
3456 -- handler must be recursive, in case showing the exception causes
3457 -- more exceptions to be raised.
3458 --
3459 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
3460 -- raising another exception. We therefore don't put the recursive
3461 -- handler arond the flushing operation, so if stderr is closed
3462 -- GHCi will just die gracefully rather than going into an infinite loop.
3463 handler :: SomeException -> GHCi Bool
3464
3465 handler exception = do
3466 flushInterpBuffers
3467 liftIO installSignalHandlers
3468 ghciHandle handler (showException exception >> return False)
3469
3470 showException :: SomeException -> GHCi ()
3471 showException se =
3472 liftIO $ case fromException se of
3473 -- omit the location for CmdLineError:
3474 Just (CmdLineError s) -> putException s
3475 -- ditto:
3476 Just other_ghc_ex -> putException (show other_ghc_ex)
3477 Nothing ->
3478 case fromException se of
3479 Just UserInterrupt -> putException "Interrupted."
3480 _ -> putException ("*** Exception: " ++ show se)
3481 where
3482 putException = hPutStrLn stderr
3483
3484
3485 -----------------------------------------------------------------------------
3486 -- recursive exception handlers
3487
3488 -- Don't forget to unblock async exceptions in the handler, or if we're
3489 -- in an exception loop (eg. let a = error a in a) the ^C exception
3490 -- may never be delivered. Thanks to Marcin for pointing out the bug.
3491
3492 ghciHandle :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a
3493 ghciHandle h m = gmask $ \restore -> do
3494 -- Force dflags to avoid leaking the associated HscEnv
3495 !dflags <- getDynFlags
3496 gcatch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e)
3497
3498 ghciTry :: GHCi a -> GHCi (Either SomeException a)
3499 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
3500
3501 tryBool :: GHCi a -> GHCi Bool
3502 tryBool m = do
3503 r <- ghciTry m
3504 case r of
3505 Left _ -> return False
3506 Right _ -> return True
3507
3508 -- ----------------------------------------------------------------------------
3509 -- Utils
3510
3511 lookupModule :: GHC.GhcMonad m => String -> m Module
3512 lookupModule mName = lookupModuleName (GHC.mkModuleName mName)
3513
3514 lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module
3515 lookupModuleName mName = GHC.lookupModule mName Nothing
3516
3517 isHomeModule :: Module -> Bool
3518 isHomeModule m = GHC.moduleUnitId m == mainUnitId
3519
3520 -- TODO: won't work if home dir is encoded.
3521 -- (changeDirectory may not work either in that case.)
3522 expandPath :: MonadIO m => String -> InputT m String
3523 expandPath = liftIO . expandPathIO
3524
3525 expandPathIO :: String -> IO String
3526 expandPathIO p =
3527 case dropWhile isSpace p of
3528 ('~':d) -> do
3529 tilde <- getHomeDirectory -- will fail if HOME not defined
3530 return (tilde ++ '/':d)
3531 other ->
3532 return other
3533
3534 wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
3535 wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str)
3536
3537 wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module
3538 wantInterpretedModuleName modname = do
3539 modl <- lookupModuleName modname
3540 let str = moduleNameString modname
3541 dflags <- getDynFlags
3542 when (GHC.moduleUnitId modl /= thisPackage dflags) $
3543 throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
3544 is_interpreted <- GHC.moduleIsInterpreted modl
3545 when (not is_interpreted) $
3546 throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
3547 return modl
3548
3549 wantNameFromInterpretedModule :: GHC.GhcMonad m
3550 => (Name -> SDoc -> m ())
3551 -> String
3552 -> (Name -> m ())
3553 -> m ()
3554 wantNameFromInterpretedModule noCanDo str and_then =
3555 handleSourceError GHC.printException $ do
3556 names <- GHC.parseName str
3557 case names of
3558 [] -> return ()
3559 (n:_) -> do
3560 let modl = ASSERT( isExternalName n ) GHC.nameModule n
3561 if not (GHC.isExternalName n)
3562 then noCanDo n $ ppr n <>
3563 text " is not defined in an interpreted module"
3564 else do
3565 is_interpreted <- GHC.moduleIsInterpreted modl
3566 if not is_interpreted
3567 then noCanDo n $ text "module " <> ppr modl <>
3568 text " is not interpreted"
3569 else and_then n