never executed always true always false
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE BangPatterns #-}
3 {-# LANGUAGE LambdaCase #-}
4 {-# LANGUAGE MagicHash #-}
5 {-# LANGUAGE MultiWayIf #-}
6 {-# LANGUAGE NondecreasingIndentation #-}
7 {-# LANGUAGE OverloadedStrings #-}
8 {-# LANGUAGE RecordWildCards #-}
9 {-# LANGUAGE ScopedTypeVariables #-}
10 {-# LANGUAGE TupleSections #-}
11 {-# LANGUAGE ViewPatterns #-}
12 {-# LANGUAGE TypeFamilies #-}
13
14 {-# OPTIONS -fno-warn-name-shadowing #-}
15 -- This module does a lot of it
16
17 -----------------------------------------------------------------------------
18 --
19 -- GHC Interactive User Interface
20 --
21 -- (c) The GHC Team 2005-2006
22 --
23 -----------------------------------------------------------------------------
24
25 module GHCi.UI (
26 interactiveUI,
27 GhciSettings(..),
28 defaultGhciSettings,
29 ghciCommands,
30 ghciWelcomeMsg
31 ) where
32
33 -- GHCi
34 import qualified GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls' )
35 import GHCi.UI.Monad hiding ( args, runStmt )
36 import GHCi.UI.Tags
37 import GHCi.UI.Info
38 import GHC.Runtime.Debugger
39
40 -- The GHC interface
41 import GHC.Runtime.Interpreter
42 import GHCi.RemoteTypes
43 import GHCi.BreakArray( breakOn, breakOff )
44 import GHC.ByteCode.Types
45 import GHC.Core.DataCon
46 import GHC.Core.ConLike
47 import GHC.Core.PatSyn
48 import GHC.Driver.Errors
49 import GHC.Driver.Phases
50 import GHC.Driver.Session as DynFlags
51 import GHC.Driver.Ppr hiding (printForUser)
52 import GHC.Utils.Error hiding (traceCmd)
53 import GHC.Driver.Monad ( modifySession )
54 import GHC.Driver.Config.Finder (initFinderOpts)
55 import GHC.Driver.Config.Parser (initParserOpts)
56 import GHC.Driver.Config.Diagnostic
57 import qualified GHC
58 import GHC ( LoadHowMuch(..), Target(..), TargetId(..),
59 Resume, SingleStep, Ghc,
60 GetDocsFailure(..), putLogMsgM, pushLogHookM,
61 getModuleGraph, handleSourceError, ms_mod )
62 import GHC.Driver.Main (hscParseDeclsWithLocation, hscParseStmtWithLocation)
63 import GHC.Hs.ImpExp
64 import GHC.Hs
65 import GHC.Driver.Env
66 import GHC.Runtime.Context
67 import GHC.Types.TyThing
68 import GHC.Types.TyThing.Ppr
69 import GHC.Core.TyCo.Ppr
70 import GHC.Types.SafeHaskell ( getSafeMode )
71 import GHC.Types.Name
72 import GHC.Types.Var ( varType )
73 import GHC.Iface.Syntax ( showToHeader )
74 import GHC.Builtin.Names
75 import GHC.Builtin.Types( stringTyCon_RDR )
76 import GHC.Types.Name.Reader as RdrName ( getGRE_NameQualifier_maybes, getRdrName )
77 import GHC.Types.SrcLoc as SrcLoc
78 import qualified GHC.Parser.Lexer as Lexer
79 import GHC.Parser.Header ( toArgs )
80 import GHC.Types.PkgQual
81
82 import GHC.Unit
83 import GHC.Unit.Finder as Finder
84 import GHC.Unit.Module.Graph (filterToposortToModules)
85 import GHC.Unit.Module.ModSummary
86
87 import GHC.Data.StringBuffer
88 import GHC.Utils.Outputable
89 import GHC.Utils.Logger
90
91 -- Other random utilities
92 import GHC.Types.Basic hiding ( isTopLevel )
93 import GHC.Settings.Config
94 import GHC.Data.Graph.Directed
95 import GHC.Utils.Encoding
96 import GHC.Data.FastString
97 import qualified GHC.Linker.Loader as Loader
98 import GHC.Data.Maybe ( orElse, expectJust )
99 import GHC.Types.Name.Set
100 import GHC.Utils.Panic hiding ( showException, try )
101 import GHC.Utils.Panic.Plain
102 import GHC.Utils.Misc
103 import qualified GHC.LanguageExtensions as LangExt
104 import GHC.Data.Bag (unitBag)
105 import qualified GHC.Data.Strict as Strict
106
107 -- Haskell Libraries
108 import System.Console.Haskeline as Haskeline
109
110 import Control.Applicative hiding (empty)
111 import Control.DeepSeq (deepseq)
112 import Control.Monad as Monad
113 import Control.Monad.Catch as MC
114 import Control.Monad.IO.Class
115 import Control.Monad.Trans.Class
116 import Control.Monad.Trans.Except
117
118 import Data.Array
119 import qualified Data.ByteString.Char8 as BS
120 import Data.Char
121 import Data.Function
122 import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )
123 import Data.List ( elemIndices, find, group, intercalate, intersperse,
124 isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) )
125 import qualified Data.Set as S
126 import Data.Maybe
127 import qualified Data.Map as M
128 import Data.IntMap.Strict (IntMap)
129 import qualified Data.IntMap.Strict as IntMap
130 import Data.Time.LocalTime ( getZonedTime )
131 import Data.Time.Format ( formatTime, defaultTimeLocale )
132 import Data.Version ( showVersion )
133 import Prelude hiding ((<>))
134
135 import GHC.Utils.Exception as Exception hiding (catch, mask, handle)
136 import Foreign hiding (void)
137 import GHC.Stack hiding (SrcLoc(..))
138
139 import System.Directory
140 import System.Environment
141 import System.Exit ( exitWith, ExitCode(..) )
142 import System.FilePath
143 import System.Info
144 import System.IO
145 import System.IO.Error
146 import System.IO.Unsafe ( unsafePerformIO )
147 import System.Process
148 import Text.Printf
149 import Text.Read ( readMaybe )
150 import Text.Read.Lex (isSymbolChar)
151
152 import Unsafe.Coerce
153
154 #if !defined(mingw32_HOST_OS)
155 import System.Posix hiding ( getEnv )
156 #else
157 import qualified System.Win32
158 #endif
159
160 import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
161 import GHC.IO.Handle ( hFlushAll )
162 import GHC.TopHandler ( topHandler )
163
164 import GHCi.Leak
165
166 -----------------------------------------------------------------------------
167
168 data GhciSettings = GhciSettings {
169 availableCommands :: [Command],
170 shortHelpText :: String,
171 fullHelpText :: String,
172 defPrompt :: PromptFunction,
173 defPromptCont :: PromptFunction
174 }
175
176 defaultGhciSettings :: GhciSettings
177 defaultGhciSettings =
178 GhciSettings {
179 availableCommands = ghciCommands,
180 shortHelpText = defShortHelpText,
181 defPrompt = default_prompt,
182 defPromptCont = default_prompt_cont,
183 fullHelpText = defFullHelpText
184 }
185
186 ghciWelcomeMsg :: String
187 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
188 ": https://www.haskell.org/ghc/ :? for help"
189
190 ghciCommands :: [Command]
191 ghciCommands = map mkCmd [
192 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
193 ("?", keepGoing help, noCompletion),
194 ("add", keepGoingPaths addModule, completeFilename),
195 ("abandon", keepGoing abandonCmd, noCompletion),
196 ("break", keepGoing breakCmd, completeBreakpoint),
197 ("back", keepGoing backCmd, noCompletion),
198 ("browse", keepGoing' (browseCmd False), completeModule),
199 ("browse!", keepGoing' (browseCmd True), completeModule),
200 ("cd", keepGoing' changeDirectory, completeFilename),
201 ("check", keepGoing' checkModule, completeHomeModule),
202 ("continue", keepGoing continueCmd, noCompletion),
203 ("cmd", keepGoing cmdCmd, completeExpression),
204 ("ctags", keepGoing createCTagsWithLineNumbersCmd, completeFilename),
205 ("ctags!", keepGoing createCTagsWithRegExesCmd, completeFilename),
206 ("def", keepGoing (defineMacro False), completeExpression),
207 ("def!", keepGoing (defineMacro True), completeExpression),
208 ("delete", keepGoing deleteCmd, noCompletion),
209 ("disable", keepGoing disableCmd, noCompletion),
210 ("doc", keepGoing' docCmd, completeIdentifier),
211 ("edit", keepGoing' editFile, completeFilename),
212 ("enable", keepGoing enableCmd, noCompletion),
213 ("etags", keepGoing createETagsFileCmd, completeFilename),
214 ("force", keepGoing forceCmd, completeExpression),
215 ("forward", keepGoing forwardCmd, noCompletion),
216 ("help", keepGoing help, noCompletion),
217 ("history", keepGoing historyCmd, noCompletion),
218 ("info", keepGoing' (info False), completeIdentifier),
219 ("info!", keepGoing' (info True), completeIdentifier),
220 ("issafe", keepGoing' isSafeCmd, completeModule),
221 ("ignore", keepGoing ignoreCmd, noCompletion),
222 ("kind", keepGoing' (kindOfType False), completeIdentifier),
223 ("kind!", keepGoing' (kindOfType True), completeIdentifier),
224 ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),
225 ("load!", keepGoingPaths loadModuleDefer, completeHomeModuleOrFile),
226 ("list", keepGoing' listCmd, noCompletion),
227 ("module", keepGoing moduleCmd, completeSetModule),
228 ("main", keepGoing runMain, completeFilename),
229 ("print", keepGoing printCmd, completeExpression),
230 ("quit", quit, noCompletion),
231 ("reload", keepGoing' reloadModule, noCompletion),
232 ("reload!", keepGoing' reloadModuleDefer, noCompletion),
233 ("run", keepGoing runRun, completeFilename),
234 ("script", keepGoing' scriptCmd, completeFilename),
235 ("set", keepGoing setCmd, completeSetOptions),
236 ("seti", keepGoing setiCmd, completeSeti),
237 ("show", keepGoing showCmd, completeShowOptions),
238 ("showi", keepGoing showiCmd, completeShowiOptions),
239 ("sprint", keepGoing sprintCmd, completeExpression),
240 ("step", keepGoing stepCmd, completeIdentifier),
241 ("steplocal", keepGoing stepLocalCmd, completeIdentifier),
242 ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),
243 ("type", keepGoing' typeOfExpr, completeExpression),
244 ("trace", keepGoing traceCmd, completeExpression),
245 ("unadd", keepGoingPaths unAddModule, completeFilename),
246 ("undef", keepGoing undefineMacro, completeMacro),
247 ("unset", keepGoing unsetOptions, completeSetOptions),
248 ("where", keepGoing whereCmd, noCompletion),
249 ("instances", keepGoing' instancesCmd, completeExpression)
250 ] ++ map mkCmdHidden [ -- hidden commands
251 ("all-types", keepGoing' allTypesCmd),
252 ("complete", keepGoing completeCmd),
253 ("loc-at", keepGoing' locAtCmd),
254 ("type-at", keepGoing' typeAtCmd),
255 ("uses", keepGoing' usesCmd)
256 ]
257 where
258 mkCmd (n,a,c) = Command { cmdName = n
259 , cmdAction = a
260 , cmdHidden = False
261 , cmdCompletionFunc = c
262 }
263
264 mkCmdHidden (n,a) = Command { cmdName = n
265 , cmdAction = a
266 , cmdHidden = True
267 , cmdCompletionFunc = noCompletion
268 }
269
270 -- We initialize readline (in the interactiveUI function) to use
271 -- word_break_chars as the default set of completion word break characters.
272 -- This can be overridden for a particular command (for example, filename
273 -- expansion shouldn't consider '/' to be a word break) by setting the third
274 -- entry in the Command tuple above.
275 --
276 -- NOTE: in order for us to override the default correctly, any custom entry
277 -- must be a SUBSET of word_break_chars.
278 word_break_chars :: String
279 word_break_chars = spaces ++ specials ++ symbols
280
281 word_break_chars_pred :: Char -> Bool
282 word_break_chars_pred '.' = False
283 word_break_chars_pred c = c `elem` (spaces ++ specials) || isSymbolChar c
284
285 symbols, specials, spaces :: String
286 symbols = "!#$%&*+/<=>?@\\^|-~"
287 specials = "(),;[]`{}"
288 spaces = " \t\n"
289
290 flagWordBreakChars :: String
291 flagWordBreakChars = " \t\n"
292
293
294 keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)
295 keepGoing a str = keepGoing' (lift . a) str
296
297 keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool
298 keepGoing' a str = a str >> return False
299
300 keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
301 keepGoingPaths a str
302 = do case toArgsNoLoc str of
303 Left err -> liftIO $ hPutStrLn stderr err
304 Right args -> a args
305 return False
306
307 defShortHelpText :: String
308 defShortHelpText = "use :? for help.\n"
309
310 defFullHelpText :: String
311 defFullHelpText =
312 " Commands available from the prompt:\n" ++
313 "\n" ++
314 " <statement> evaluate/run <statement>\n" ++
315 " : repeat last command\n" ++
316 " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
317 " :add [*]<module> ... add module(s) to the current target set\n" ++
318 " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
319 " (!: more details; *: all top-level names)\n" ++
320 " :cd <dir> change directory to <dir>\n" ++
321 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
322 " :complete <dom> [<rng>] <s> list completions for partial input string\n" ++
323 " :ctags[!] [<file>] create tags file <file> for Vi (default: \"tags\")\n" ++
324 " (!: use regex instead of line number)\n" ++
325 " :def[!] <cmd> <expr> define command :<cmd> (later defined command has\n" ++
326 " precedence, ::<cmd> is always a builtin command)\n" ++
327 " (!: redefine an existing command name)\n" ++
328 " :doc <name> display docs for the given name (experimental)\n" ++
329 " :edit <file> edit file\n" ++
330 " :edit edit last module\n" ++
331 " :etags [<file>] create tags file <file> for Emacs (default: \"TAGS\")\n" ++
332 " :help, :? display this list of commands\n" ++
333 " :info[!] [<name> ...] display information about the given names\n" ++
334 " (!: do not filter instances)\n" ++
335 " :instances <type> display the class instances available for <type>\n" ++
336 " :issafe [<mod>] display safe haskell information of module <mod>\n" ++
337 " :kind[!] <type> show the kind of <type>\n" ++
338 " (!: also print the normalised type)\n" ++
339 " :load[!] [*]<module> ... load module(s) and their dependents\n" ++
340 " (!: defer type errors)\n" ++
341 " :main [<arguments> ...] run the main function with the given arguments\n" ++
342 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
343 " :quit exit GHCi\n" ++
344 " :reload[!] reload the current module set\n" ++
345 " (!: defer type errors)\n" ++
346 " :run function [<arguments> ...] run the function with the given arguments\n" ++
347 " :script <file> run the script <file>\n" ++
348 " :type <expr> show the type of <expr>\n" ++
349 " :type +d <expr> show the type of <expr>, defaulting type variables\n" ++
350 " :type +v <expr> show the type of <expr>, with its specified tyvars\n" ++
351 " :unadd <module> ... remove module(s) from the current target set\n" ++
352 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
353 " ::<cmd> run the builtin command\n" ++
354 " :!<command> run the shell command <command>\n" ++
355 "\n" ++
356 " -- Commands for debugging:\n" ++
357 "\n" ++
358 " :abandon at a breakpoint, abandon current computation\n" ++
359 " :back [<n>] go back in the history N steps (after :trace)\n" ++
360 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
361 " :break <name> set a breakpoint on the specified function\n" ++
362 " :continue [<count>] resume after a breakpoint [and set break ignore count]\n" ++
363 " :delete <number> ... delete the specified breakpoints\n" ++
364 " :delete * delete all breakpoints\n" ++
365 " :disable <number> ... disable the specified breakpoints\n" ++
366 " :disable * disable all breakpoints\n" ++
367 " :enable <number> ... enable the specified breakpoints\n" ++
368 " :enable * enable all breakpoints\n" ++
369 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
370 " :forward [<n>] go forward in the history N step s(after :back)\n" ++
371 " :history [<n>] after :trace, show the execution history\n" ++
372 " :ignore <breaknum> <count> for break <breaknum> set break ignore <count>\n" ++
373 " :list show the source code around current breakpoint\n" ++
374 " :list <identifier> show the source code for <identifier>\n" ++
375 " :list [<module>] <line> show the source code around line number <line>\n" ++
376 " :print [<name> ...] show a value without forcing its computation\n" ++
377 " :sprint [<name> ...] simplified version of :print\n" ++
378 " :step single-step after stopping at a breakpoint\n"++
379 " :step <expr> single-step into <expr>\n"++
380 " :steplocal single-step within the current top-level binding\n"++
381 " :stepmodule single-step restricted to the current module\n"++
382 " :trace trace after stopping at a breakpoint\n"++
383 " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++
384
385 "\n" ++
386 " -- Commands for changing settings:\n" ++
387 "\n" ++
388 " :set <option> ... set options\n" ++
389 " :seti <option> ... set options for interactive evaluation only\n" ++
390 " :set local-config { source | ignore }\n" ++
391 " set whether to source .ghci in current dir\n" ++
392 " (loading untrusted config is a security issue)\n" ++
393 " :set args <arg> ... set the arguments returned by System.Environment.getArgs\n" ++
394 " :set prog <progname> set the value returned by System.Environment.getProgName\n" ++
395 " :set prompt <prompt> set the prompt used in GHCi\n" ++
396 " :set prompt-cont <prompt> set the continuation prompt used in GHCi\n" ++
397 " :set prompt-function <expr> set the function to handle the prompt\n" ++
398 " :set prompt-cont-function <expr>\n" ++
399 " set the function to handle the continuation prompt\n" ++
400 " :set editor <cmd> set the command used for :edit\n" ++
401 " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" ++
402 " :unset <option> ... unset options\n" ++
403 "\n" ++
404 " Options for ':set' and ':unset':\n" ++
405 "\n" ++
406 " +m allow multiline commands\n" ++
407 " +r revert top-level expressions after each evaluation\n" ++
408 " +s print timing/memory stats after each evaluation\n" ++
409 " +t print type after evaluation\n" ++
410 " +c collect type/location info after loading modules\n" ++
411 " -<flags> most GHC command line flags can also be set here\n" ++
412 " (eg. -v2, -XFlexibleInstances, etc.)\n" ++
413 " for GHCi-specific flags, see User's Guide,\n"++
414 " Flag reference, Interactive-mode options\n" ++
415 "\n" ++
416 " -- Commands for displaying information:\n" ++
417 "\n" ++
418 " :show bindings show the current bindings made at the prompt\n" ++
419 " :show breaks show the active breakpoints\n" ++
420 " :show context show the breakpoint context\n" ++
421 " :show imports show the current imports\n" ++
422 " :show linker show current linker state\n" ++
423 " :show modules show the currently loaded modules\n" ++
424 " :show packages show the currently active package flags\n" ++
425 " :show paths show the currently active search paths\n" ++
426 " :show language show the currently active language flags\n" ++
427 " :show targets show the current set of targets\n" ++
428 " :show <setting> show value of <setting>, which is one of\n" ++
429 " [args, prog, editor, stop]\n" ++
430 " :showi language show language flags for interactive evaluation\n" ++
431 "\n" ++
432 " The User's Guide has more information. An online copy can be found here:\n" ++
433 "\n" ++
434 " https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/ghci.html\n" ++
435 "\n"
436
437 findEditor :: IO String
438 findEditor = do
439 getEnv "VISUAL" <|> getEnv "EDITOR" <|> defaultEditor
440 where
441 defaultEditor = do
442 #if defined(mingw32_HOST_OS)
443 win <- System.Win32.getWindowsDirectory
444 return (win </> "notepad.exe")
445 #else
446 return ""
447 #endif
448
449 default_progname, default_stop :: String
450 default_progname = "<interactive>"
451 default_stop = ""
452
453 default_prompt, default_prompt_cont :: PromptFunction
454 default_prompt = generatePromptFunctionFromString "ghci> "
455 default_prompt_cont = generatePromptFunctionFromString "ghci| "
456
457 default_args :: [String]
458 default_args = []
459
460 interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]
461 -> Ghc ()
462 interactiveUI config srcs maybe_exprs = do
463 -- HACK! If we happen to get into an infinite loop (eg the user
464 -- types 'let x=x in x' at the prompt), then the thread will block
465 -- on a blackhole, and become unreachable during GC. The GC will
466 -- detect that it is unreachable and send it the NonTermination
467 -- exception. However, since the thread is unreachable, everything
468 -- it refers to might be finalized, including the standard Handles.
469 -- This sounds like a bug, but we don't have a good solution right
470 -- now.
471 _ <- liftIO $ newStablePtr stdin
472 _ <- liftIO $ newStablePtr stdout
473 _ <- liftIO $ newStablePtr stderr
474
475 -- Initialise buffering for the *interpreted* I/O system
476 (nobuffering, flush) <- runInternal initInterpBuffering
477
478 -- The initial set of DynFlags used for interactive evaluation is the same
479 -- as the global DynFlags, plus -XExtendedDefaultRules and
480 -- -XNoMonomorphismRestriction.
481 -- See note [Changing language extensions for interactive evaluation] #10857
482 dflags <- getDynFlags
483 let dflags' = (xopt_set_unlessExplSpec
484 LangExt.ExtendedDefaultRules xopt_set)
485 . (xopt_set_unlessExplSpec
486 LangExt.MonomorphismRestriction xopt_unset)
487 $ dflags
488 GHC.setInteractiveDynFlags dflags'
489 _ <- GHC.setProgramDynFlags
490 -- Set Opt_KeepGoing so that :reload loads as much as
491 -- possible
492 (gopt_set dflags Opt_KeepGoing)
493
494 -- Update the LogAction. Ensure we don't override the user's log action lest
495 -- we break -ddump-json (#14078)
496 lastErrLocationsRef <- liftIO $ newIORef []
497 pushLogHookM (ghciLogAction lastErrLocationsRef)
498
499 when (isNothing maybe_exprs) $ do
500 -- Only for GHCi (not runghc and ghc -e):
501
502 -- Turn buffering off for the compiled program's stdout/stderr
503 turnOffBuffering_ nobuffering
504 -- Turn buffering off for GHCi's stdout
505 liftIO $ hFlush stdout
506 liftIO $ hSetBuffering stdout NoBuffering
507 -- We don't want the cmd line to buffer any input that might be
508 -- intended for the program, so unbuffer stdin.
509 liftIO $ hSetBuffering stdin NoBuffering
510 liftIO $ hSetBuffering stderr NoBuffering
511 #if defined(mingw32_HOST_OS)
512 -- On Unix, stdin will use the locale encoding. The IO library
513 -- doesn't do this on Windows (yet), so for now we use UTF-8,
514 -- for consistency with GHC 6.10 and to make the tests work.
515 liftIO $ hSetEncoding stdin utf8
516 #endif
517
518 default_editor <- liftIO $ findEditor
519 eval_wrapper <- mkEvalWrapper default_progname default_args
520 let prelude_import = simpleImportDecl preludeModuleName
521 startGHCi (runGHCi srcs maybe_exprs)
522 GHCiState{ progname = default_progname,
523 args = default_args,
524 evalWrapper = eval_wrapper,
525 prompt = defPrompt config,
526 prompt_cont = defPromptCont config,
527 stop = default_stop,
528 editor = default_editor,
529 options = [],
530 localConfig = SourceLocalConfig,
531 -- We initialize line number as 0, not 1, because we use
532 -- current line number while reporting errors which is
533 -- incremented after reading a line.
534 line_number = 0,
535 break_ctr = 0,
536 breaks = IntMap.empty,
537 tickarrays = emptyModuleEnv,
538 ghci_commands = availableCommands config,
539 ghci_macros = [],
540 last_command = Nothing,
541 cmd_wrapper = (cmdSuccess =<<),
542 cmdqueue = [],
543 remembered_ctx = [],
544 transient_ctx = [],
545 extra_imports = [],
546 prelude_imports = [prelude_import],
547 ghc_e = isJust maybe_exprs,
548 short_help = shortHelpText config,
549 long_help = fullHelpText config,
550 lastErrorLocations = lastErrLocationsRef,
551 mod_infos = M.empty,
552 flushStdHandles = flush,
553 noBuffering = nobuffering,
554 hmiCache = []
555 }
556
557 return ()
558
559 {-
560 Note [Changing language extensions for interactive evaluation]
561 --------------------------------------------------------------
562 GHCi maintains two sets of options:
563
564 - The "loading options" apply when loading modules
565 - The "interactive options" apply when evaluating expressions and commands
566 typed at the GHCi prompt.
567
568 The loading options are mostly created in ghc/Main.hs:main' from the command
569 line flags. In the function ghc/GHCi/UI.hs:interactiveUI the loading options
570 are copied to the interactive options.
571
572 These interactive options (but not the loading options!) are supplemented
573 unconditionally by setting ExtendedDefaultRules ON and
574 MonomorphismRestriction OFF. The unconditional setting of these options
575 eventually overwrite settings already specified at the command line.
576
577 Therefore instead of unconditionally setting ExtendedDefaultRules and
578 NoMonomorphismRestriction for the interactive options, we use the function
579 'xopt_set_unlessExplSpec' to first check whether the extension has already
580 specified at the command line.
581
582 The ghci config file has not yet been processed.
583 -}
584
585 resetLastErrorLocations :: GhciMonad m => m ()
586 resetLastErrorLocations = do
587 st <- getGHCiState
588 liftIO $ writeIORef (lastErrorLocations st) []
589
590 ghciLogAction :: IORef [(FastString, Int)] -> LogAction -> LogAction
591 ghciLogAction lastErrLocations old_log_action
592 dflags msg_class srcSpan msg = do
593 old_log_action dflags msg_class srcSpan msg
594 case msg_class of
595 MCDiagnostic SevError _reason -> case srcSpan of
596 RealSrcSpan rsp _ -> modifyIORef lastErrLocations
597 (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])
598 _ -> return ()
599 _ -> return ()
600
601 withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
602 withGhcAppData right left = do
603 either_dir <- tryIO (getXdgDirectory XdgData "ghc")
604 case either_dir of
605 Right dir ->
606 do createDirectoryIfMissing False dir `catchIO` \_ -> return ()
607 right dir
608 _ -> left
609
610 withGhcConfig :: (FilePath -> IO a) -> IO a -> IO a
611 withGhcConfig right left = do
612 old_path <- getAppUserDataDirectory "ghc"
613 use_old_path <- doesPathExist old_path
614 let path = (if use_old_path
615 then getAppUserDataDirectory "ghc"
616 else getXdgDirectory XdgConfig "ghc")
617 either_dir <- tryIO (path)
618 case either_dir of
619 Right dir ->
620 do createDirectoryIfMissing False dir `catchIO` \_ -> return ()
621 right dir
622 _ -> left
623
624 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
625 runGHCi paths maybe_exprs = do
626 dflags <- getDynFlags
627 let
628 ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags
629
630 app_user_dir = liftIO $ withGhcConfig
631 (\dir -> return (Just (dir </> "ghci.conf")))
632 (return Nothing)
633
634 home_dir = do
635 either_dir <- liftIO $ tryIO (getEnv "HOME")
636 case either_dir of
637 Right home -> return (Just (home </> ".ghci"))
638 _ -> return Nothing
639
640 canonicalizePath' :: FilePath -> IO (Maybe FilePath)
641 canonicalizePath' fp = liftM Just (canonicalizePath fp)
642 `catchIO` \_ -> return Nothing
643
644 sourceConfigFile :: FilePath -> GHCi ()
645 sourceConfigFile file = do
646 exists <- liftIO $ doesFileExist file
647 when exists $ do
648 either_hdl <- liftIO $ tryIO (openFile file ReadMode)
649 case either_hdl of
650 Left _e -> return ()
651 -- NOTE: this assumes that runInputT won't affect the terminal;
652 -- can we assume this will always be the case?
653 -- This would be a good place for runFileInputT.
654 Right hdl ->
655 do runInputTWithPrefs defaultPrefs defaultSettings $
656 runCommands $ fileLoop hdl
657 liftIO (hClose hdl `catchIO` \_ -> return ())
658 -- Don't print a message if this is really ghc -e (#11478).
659 -- Also, let the user silence the message with -v0
660 -- (the default verbosity in GHCi is 1).
661 when (isNothing maybe_exprs && verbosity dflags > 0) $
662 liftIO $ putStrLn ("Loaded GHCi configuration from " ++ file)
663
664 --
665
666 setGHCContextFromGHCiState
667
668 processedCfgs <- if ignore_dot_ghci
669 then pure []
670 else do
671 userCfgs <- do
672 paths <- catMaybes <$> sequence [ app_user_dir, home_dir ]
673 checkedPaths <- liftIO $ filterM checkFileAndDirPerms paths
674 liftIO . fmap (nub . catMaybes) $ mapM canonicalizePath' checkedPaths
675
676 localCfg <- do
677 let path = ".ghci"
678 ok <- liftIO $ checkFileAndDirPerms path
679 if ok then liftIO $ canonicalizePath' path else pure Nothing
680
681 mapM_ sourceConfigFile userCfgs
682 -- Process the global and user .ghci
683 -- (but not $CWD/.ghci or CLI args, yet)
684
685 behaviour <- localConfig <$> getGHCiState
686
687 processedLocalCfg <- case localCfg of
688 Just path | path `notElem` userCfgs ->
689 -- don't read .ghci twice if CWD is $HOME
690 case behaviour of
691 SourceLocalConfig -> localCfg <$ sourceConfigFile path
692 IgnoreLocalConfig -> pure Nothing
693 _ -> pure Nothing
694
695 pure $ maybe id (:) processedLocalCfg userCfgs
696
697 let arg_cfgs = reverse $ ghciScripts dflags
698 -- -ghci-script are collected in reverse order
699 -- We don't require that a script explicitly added by -ghci-script
700 -- is owned by the current user. (#6017)
701
702 mapM_ sourceConfigFile $ nub arg_cfgs \\ processedCfgs
703 -- Dedup, and remove any configs we already processed.
704 -- Importantly, if $PWD/.ghci was ignored due to configuration,
705 -- explicitly specifying it does cause it to be processed.
706
707 -- Perform a :load for files given on the GHCi command line
708 -- When in -e mode, if the load fails then we want to stop
709 -- immediately rather than going on to evaluate the expression.
710 when (not (null paths)) $ do
711 ok <- ghciHandle (\e -> do showException e; return Failed) $
712 -- TODO: this is a hack.
713 runInputTWithPrefs defaultPrefs defaultSettings $
714 loadModule paths
715 when (isJust maybe_exprs && failed ok) $
716 liftIO (exitWith (ExitFailure 1))
717
718 installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)
719
720 -- if verbosity is greater than 0, or we are connected to a
721 -- terminal, display the prompt in the interactive loop.
722 is_tty <- liftIO (hIsTerminalDevice stdin)
723 let show_prompt = verbosity dflags > 0 || is_tty
724
725 -- reset line number
726 modifyGHCiState $ \st -> st{line_number=0}
727
728 case maybe_exprs of
729 Nothing ->
730 do
731 -- enter the interactive loop
732 runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
733 Just exprs -> do
734 -- just evaluate the expression we were given
735 enqueueCommands exprs
736 let hdle e = do st <- getGHCiState
737 -- flush the interpreter's stdout/stderr on exit (#3890)
738 flushInterpBuffers
739 -- Jump through some hoops to get the
740 -- current progname in the exception text:
741 -- <progname>: <exception>
742 liftIO $ withProgName (progname st)
743 $ topHandler e
744 -- this used to be topHandlerFastExit, see #2228
745 runInputTWithPrefs defaultPrefs defaultSettings $ do
746 -- make `ghc -e` exit nonzero on invalid input, see #7962
747 _ <- runCommands' hdle
748 (Just $ hdle (toException $ ExitFailure 1) >> return ())
749 (return Nothing)
750 return ()
751
752 -- and finally, exit
753 liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
754
755 runGHCiInput :: InputT GHCi a -> GHCi a
756 runGHCiInput f = do
757 dflags <- getDynFlags
758 let ghciHistory = gopt Opt_GhciHistory dflags
759 let localGhciHistory = gopt Opt_LocalGhciHistory dflags
760 currentDirectory <- liftIO $ getCurrentDirectory
761
762 histFile <- case (ghciHistory, localGhciHistory) of
763 (True, True) -> return (Just (currentDirectory </> ".ghci_history"))
764 (True, _) -> liftIO $ withGhcAppData
765 (\dir -> return (Just (dir </> "ghci_history"))) (return Nothing)
766 _ -> return Nothing
767
768 runInputT
769 (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})
770 f
771
772 -- | How to get the next input line from the user
773 nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
774 nextInputLine show_prompt is_tty
775 | is_tty = do
776 prmpt <- if show_prompt then lift mkPrompt else return ""
777 r <- getInputLine prmpt
778 incrementLineNo
779 return r
780 | otherwise = do
781 when show_prompt $ lift mkPrompt >>= liftIO . putStr
782 fileLoop stdin
783
784 -- NOTE: We only read .ghci files if they are owned by the current user,
785 -- and aren't world writable (files owned by root are ok, see #9324).
786 -- Otherwise, we could be accidentally running code planted by
787 -- a malicious third party.
788
789 -- Furthermore, We only read ./.ghci if . is owned by the current user
790 -- and isn't writable by anyone else. I think this is sufficient: we
791 -- don't need to check .. and ../.. etc. because "." always refers to
792 -- the same directory while a process is running.
793
794 checkFileAndDirPerms :: FilePath -> IO Bool
795 checkFileAndDirPerms file = do
796 file_ok <- checkPerms file
797 -- Do not check dir perms when .ghci doesn't exist, otherwise GHCi will
798 -- print some confusing and useless warnings in some cases (e.g. in
799 -- travis). Note that we can't add a test for this, as all ghci tests should
800 -- run with -ignore-dot-ghci, which means we never get here.
801 if file_ok then checkPerms (getDirectory file) else return False
802 where
803 getDirectory f = case takeDirectory f of
804 "" -> "."
805 d -> d
806
807 checkPerms :: FilePath -> IO Bool
808 #if defined(mingw32_HOST_OS)
809 checkPerms _ = return True
810 #else
811 checkPerms file =
812 handleIO (\_ -> return False) $ do
813 st <- getFileStatus file
814 me <- getRealUserID
815 let mode = System.Posix.fileMode st
816 ok = (fileOwner st == me || fileOwner st == 0) &&
817 groupWriteMode /= mode `intersectFileModes` groupWriteMode &&
818 otherWriteMode /= mode `intersectFileModes` otherWriteMode
819 unless ok $
820 -- #8248: Improving warning to include a possible fix.
821 putStrLn $ "*** WARNING: " ++ file ++
822 " is writable by someone else, IGNORING!" ++
823 "\nSuggested fix: execute 'chmod go-w " ++ file ++ "'"
824 return ok
825 #endif
826
827 incrementLineNo :: GhciMonad m => m ()
828 incrementLineNo = modifyGHCiState incLineNo
829 where
830 incLineNo st = st { line_number = line_number st + 1 }
831
832 fileLoop :: GhciMonad m => Handle -> m (Maybe String)
833 fileLoop hdl = do
834 l <- liftIO $ tryIO $ hGetLine hdl
835 case l of
836 Left e | isEOFError e -> return Nothing
837 | -- as we share stdin with the program, the program
838 -- might have already closed it, so we might get a
839 -- handle-closed exception. We therefore catch that
840 -- too.
841 isIllegalOperation e -> return Nothing
842 | InvalidArgument <- etype -> return Nothing
843 | otherwise -> liftIO $ ioError e
844 where etype = ioeGetErrorType e
845 -- treat InvalidArgument in the same way as EOF:
846 -- this can happen if the user closed stdin, or
847 -- perhaps did getContents which closes stdin at
848 -- EOF.
849 Right l' -> do
850 incrementLineNo
851 return (Just l')
852
853 formatCurrentTime :: String -> IO String
854 formatCurrentTime format =
855 getZonedTime >>= return . (formatTime defaultTimeLocale format)
856
857 getUserName :: IO String
858 getUserName = do
859 #if defined(mingw32_HOST_OS)
860 getEnv "USERNAME"
861 `catchIO` \e -> do
862 putStrLn $ show e
863 return ""
864 #else
865 getLoginName
866 #endif
867
868 getInfoForPrompt :: GhciMonad m => m (SDoc, [String], Int)
869 getInfoForPrompt = do
870 st <- getGHCiState
871 imports <- GHC.getContext
872 resumes <- GHC.getResumeContext
873
874 context_bit <-
875 case resumes of
876 [] -> return empty
877 r:_ -> do
878 let ix = GHC.resumeHistoryIx r
879 if ix == 0
880 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
881 else do
882 let hist = GHC.resumeHistory r !! (ix-1)
883 pan <- GHC.getHistorySpan hist
884 return (brackets (ppr (negate ix) <> char ':'
885 <+> ppr pan) <> space)
886
887 let
888 dots | _:rs <- resumes, not (null rs) = text "... "
889 | otherwise = empty
890
891 rev_imports = reverse imports -- rightmost are the most recent
892
893 myIdeclName d | Just m <- ideclAs d = unLoc m
894 | otherwise = unLoc (ideclName d)
895
896 modules_names =
897 ['*':(moduleNameString m) | IIModule m <- rev_imports] ++
898 [moduleNameString (myIdeclName d) | IIDecl d <- rev_imports]
899 line = 1 + line_number st
900
901 return (dots <> context_bit, modules_names, line)
902
903 parseCallEscape :: String -> (String, String)
904 parseCallEscape s
905 | not (all isSpace beforeOpen) = ("", "")
906 | null sinceOpen = ("", "")
907 | null sinceClosed = ("", "")
908 | null cmd = ("", "")
909 | otherwise = (cmd, tail sinceClosed)
910 where
911 (beforeOpen, sinceOpen) = span (/='(') s
912 (cmd, sinceClosed) = span (/=')') (tail sinceOpen)
913
914 checkPromptStringForErrors :: String -> Maybe String
915 checkPromptStringForErrors ('%':'c':'a':'l':'l':xs) =
916 case parseCallEscape xs of
917 ("", "") -> Just ("Incorrect %call syntax. " ++
918 "Should be %call(a command and arguments).")
919 (_, afterClosed) -> checkPromptStringForErrors afterClosed
920 checkPromptStringForErrors ('%':'%':xs) = checkPromptStringForErrors xs
921 checkPromptStringForErrors (_:xs) = checkPromptStringForErrors xs
922 checkPromptStringForErrors "" = Nothing
923
924 generatePromptFunctionFromString :: String -> PromptFunction
925 generatePromptFunctionFromString promptS modules_names line =
926 processString promptS
927 where
928 processString :: String -> GHCi SDoc
929 processString ('%':'s':xs) =
930 liftM2 (<>) (return modules_list) (processString xs)
931 where
932 modules_list = hsep . map text . ordNub $ modules_names
933 processString ('%':'l':xs) =
934 liftM2 (<>) (return $ ppr line) (processString xs)
935 processString ('%':'d':xs) =
936 liftM2 (<>) (liftM text formatted_time) (processString xs)
937 where
938 formatted_time = liftIO $ formatCurrentTime "%a %b %d"
939 processString ('%':'t':xs) =
940 liftM2 (<>) (liftM text formatted_time) (processString xs)
941 where
942 formatted_time = liftIO $ formatCurrentTime "%H:%M:%S"
943 processString ('%':'T':xs) = do
944 liftM2 (<>) (liftM text formatted_time) (processString xs)
945 where
946 formatted_time = liftIO $ formatCurrentTime "%I:%M:%S"
947 processString ('%':'@':xs) = do
948 liftM2 (<>) (liftM text formatted_time) (processString xs)
949 where
950 formatted_time = liftIO $ formatCurrentTime "%I:%M %P"
951 processString ('%':'A':xs) = do
952 liftM2 (<>) (liftM text formatted_time) (processString xs)
953 where
954 formatted_time = liftIO $ formatCurrentTime "%H:%M"
955 processString ('%':'u':xs) =
956 liftM2 (<>) (liftM text user_name) (processString xs)
957 where
958 user_name = liftIO $ getUserName
959 processString ('%':'w':xs) =
960 liftM2 (<>) (liftM text current_directory) (processString xs)
961 where
962 current_directory = liftIO $ getCurrentDirectory
963 processString ('%':'o':xs) =
964 liftM ((text os) <>) (processString xs)
965 processString ('%':'a':xs) =
966 liftM ((text arch) <>) (processString xs)
967 processString ('%':'N':xs) =
968 liftM ((text compilerName) <>) (processString xs)
969 processString ('%':'V':xs) =
970 liftM ((text $ showVersion compilerVersion) <>) (processString xs)
971 processString ('%':'c':'a':'l':'l':xs) = do
972 respond <- liftIO $ do
973 (code, out, err) <-
974 readProcessWithExitCode
975 (head list_words) (tail list_words) ""
976 `catchIO` \e -> return (ExitFailure 1, "", show e)
977 case code of
978 ExitSuccess -> return out
979 _ -> do
980 hPutStrLn stderr err
981 return ""
982 liftM ((text respond) <>) (processString afterClosed)
983 where
984 (cmd, afterClosed) = parseCallEscape xs
985 list_words = words cmd
986 processString ('%':'%':xs) =
987 liftM ((char '%') <>) (processString xs)
988 processString (x:xs) =
989 liftM (char x <>) (processString xs)
990 processString "" =
991 return empty
992
993 mkPrompt :: GHCi String
994 mkPrompt = do
995 st <- getGHCiState
996 dflags <- getDynFlags
997 (context, modules_names, line) <- getInfoForPrompt
998
999 prompt_string <- (prompt st) modules_names line
1000 let prompt_doc = context <> prompt_string
1001
1002 return (showSDoc dflags prompt_doc)
1003
1004 queryQueue :: GhciMonad m => m (Maybe String)
1005 queryQueue = do
1006 st <- getGHCiState
1007 case cmdqueue st of
1008 [] -> return Nothing
1009 c:cs -> do setGHCiState st{ cmdqueue = cs }
1010 return (Just c)
1011
1012 -- Reconfigurable pretty-printing Ticket #5461
1013 installInteractivePrint :: GHC.GhcMonad m => Maybe String -> Bool -> m ()
1014 installInteractivePrint Nothing _ = return ()
1015 installInteractivePrint (Just ipFun) exprmode = do
1016 ok <- trySuccess $ do
1017 names <- GHC.parseName ipFun
1018 let name = case names of
1019 name':_ -> name'
1020 [] -> panic "installInteractivePrint"
1021 modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name
1022 in he{hsc_IC = new_ic})
1023 return Succeeded
1024
1025 when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1))
1026
1027 -- | The main read-eval-print loop
1028 runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
1029 runCommands gCmd = runCommands' handler Nothing gCmd >> return ()
1030
1031 runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler
1032 -> Maybe (GHCi ()) -- ^ Source error handler
1033 -> InputT GHCi (Maybe String)
1034 -> InputT GHCi ()
1035 runCommands' eh sourceErrorHandler gCmd = mask $ \unmask -> do
1036 b <- handle (\e -> case fromException e of
1037 Just UserInterrupt -> return $ Just False
1038 _ -> case fromException e of
1039 Just ghce ->
1040 do liftIO (print (ghce :: GhcException))
1041 return Nothing
1042 _other ->
1043 liftIO (Exception.throwIO e))
1044 (unmask $ runOneCommand eh gCmd)
1045 case b of
1046 Nothing -> return ()
1047 Just success -> do
1048 unless success $ maybe (return ()) lift sourceErrorHandler
1049 unmask $ runCommands' eh sourceErrorHandler gCmd
1050
1051 -- | Evaluate a single line of user input (either :<command> or Haskell code).
1052 -- A result of Nothing means there was no more input to process.
1053 -- Otherwise the result is Just b where b is True if the command succeeded;
1054 -- this is relevant only to ghc -e, which will exit with status 1
1055 -- if the command was unsuccessful. GHCi will continue in either case.
1056 runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
1057 -> InputT GHCi (Maybe Bool)
1058 runOneCommand eh gCmd = do
1059 -- run a previously queued command if there is one, otherwise get new
1060 -- input from user
1061 mb_cmd0 <- noSpace (lift queryQueue)
1062 mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0
1063 case mb_cmd1 of
1064 Nothing -> return Nothing
1065 Just c -> do
1066 st <- getGHCiState
1067 ghciHandle (\e -> lift $ eh e >>= return . Just) $
1068 handleSourceError printErrorAndFail $
1069 cmd_wrapper st $ doCommand c
1070 -- source error's are handled by runStmt
1071 -- is the handler necessary here?
1072 where
1073 printErrorAndFail err = do
1074 GHC.printException err
1075 return $ Just False -- Exit ghc -e, but not GHCi
1076
1077 noSpace q = q >>= maybe (return Nothing)
1078 (\c -> case removeSpaces c of
1079 "" -> noSpace q
1080 ":{" -> multiLineCmd q
1081 _ -> return (Just c) )
1082 multiLineCmd q = do
1083 st <- getGHCiState
1084 let p = prompt st
1085 setGHCiState st{ prompt = prompt_cont st }
1086 mb_cmd <- collectCommand q "" `MC.finally`
1087 modifyGHCiState (\st' -> st' { prompt = p })
1088 return mb_cmd
1089 -- we can't use removeSpaces for the sublines here, so
1090 -- multiline commands are somewhat more brittle against
1091 -- fileformat errors (such as \r in dos input on unix),
1092 -- we get rid of any extra spaces for the ":}" test;
1093 -- we also avoid silent failure if ":}" is not found;
1094 -- and since there is no (?) valid occurrence of \r (as
1095 -- opposed to its String representation, "\r") inside a
1096 -- ghci command, we replace any such with ' ' (argh:-(
1097 collectCommand q c = q >>=
1098 maybe (liftIO (ioError collectError))
1099 (\l->if removeSpaces l == ":}"
1100 then return (Just c)
1101 else collectCommand q (c ++ "\n" ++ map normSpace l))
1102 where normSpace '\r' = ' '
1103 normSpace x = x
1104 -- SDM (2007-11-07): is userError the one to use here?
1105 collectError = userError "unterminated multiline command :{ .. :}"
1106
1107 -- | Handle a line of input
1108 doCommand :: String -> InputT GHCi CommandResult
1109
1110 -- command
1111 doCommand stmt | stmt'@(':' : cmd) <- removeSpaces stmt = do
1112 (stats, result) <- runWithStats (const Nothing) $ specialCommand cmd
1113 let processResult True = Nothing
1114 processResult False = Just True
1115 return $ CommandComplete stmt' (processResult <$> result) stats
1116
1117 -- haskell
1118 doCommand stmt = do
1119 -- if 'stmt' was entered via ':{' it will contain '\n's
1120 let stmt_nl_cnt = length [ () | '\n' <- stmt ]
1121 ml <- lift $ isOptionSet Multiline
1122 if ml && stmt_nl_cnt == 0 -- don't trigger automatic multi-line mode for ':{'-multiline input
1123 then do
1124 fst_line_num <- line_number <$> getGHCiState
1125 mb_stmt <- checkInputForLayout stmt gCmd
1126 case mb_stmt of
1127 Nothing -> return CommandIncomplete
1128 Just ml_stmt -> do
1129 -- temporarily compensate line-number for multi-line input
1130 (stats, result) <- runAndPrintStats runAllocs $ lift $
1131 runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion
1132 return $
1133 CommandComplete ml_stmt (Just . runSuccess <$> result) stats
1134 else do -- single line input and :{ - multiline input
1135 last_line_num <- line_number <$> getGHCiState
1136 -- reconstruct first line num from last line num and stmt
1137 let fst_line_num | stmt_nl_cnt > 0 = last_line_num - (stmt_nl_cnt2 + 1)
1138 | otherwise = last_line_num -- single line input
1139 stmt_nl_cnt2 = length [ () | '\n' <- stmt' ]
1140 stmt' = dropLeadingWhiteLines stmt -- runStmt doesn't like leading empty lines
1141 -- temporarily compensate line-number for multi-line input
1142 (stats, result) <- runAndPrintStats runAllocs $ lift $
1143 runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion
1144 return $ CommandComplete stmt' (Just . runSuccess <$> result) stats
1145
1146 -- runStmt wrapper for temporarily overridden line-number
1147 runStmtWithLineNum :: Int -> String -> SingleStep
1148 -> GHCi (Maybe GHC.ExecResult)
1149 runStmtWithLineNum lnum stmt step = do
1150 st0 <- getGHCiState
1151 setGHCiState st0 { line_number = lnum }
1152 result <- runStmt stmt step
1153 -- restore original line_number
1154 getGHCiState >>= \st -> setGHCiState st { line_number = line_number st0 }
1155 return result
1156
1157 -- note: this is subtly different from 'unlines . dropWhile (all isSpace) . lines'
1158 dropLeadingWhiteLines s | (l0,'\n':r) <- break (=='\n') s
1159 , all isSpace l0 = dropLeadingWhiteLines r
1160 | otherwise = s
1161
1162
1163 -- #4316
1164 -- lex the input. If there is an unclosed layout context, request input
1165 checkInputForLayout
1166 :: GhciMonad m => String -> m (Maybe String) -> m (Maybe String)
1167 checkInputForLayout stmt getStmt = do
1168 dflags' <- getDynFlags
1169 let dflags = xopt_set dflags' LangExt.AlternativeLayoutRule
1170 st0 <- getGHCiState
1171 let buf' = stringToStringBuffer stmt
1172 loc = mkRealSrcLoc (fsLit (progname st0)) (line_number st0) 1
1173 pstate = Lexer.initParserState (initParserOpts dflags) buf' loc
1174 case Lexer.unP goToEnd pstate of
1175 (Lexer.POk _ False) -> return $ Just stmt
1176 _other -> do
1177 st1 <- getGHCiState
1178 let p = prompt st1
1179 setGHCiState st1{ prompt = prompt_cont st1 }
1180 mb_stmt <- ghciHandle (\ex -> case fromException ex of
1181 Just UserInterrupt -> return Nothing
1182 _ -> case fromException ex of
1183 Just ghce ->
1184 do liftIO (print (ghce :: GhcException))
1185 return Nothing
1186 _other -> liftIO (Exception.throwIO ex))
1187 getStmt
1188 modifyGHCiState (\st' -> st' { prompt = p })
1189 -- the recursive call does not recycle parser state
1190 -- as we use a new string buffer
1191 case mb_stmt of
1192 Nothing -> return Nothing
1193 Just str -> if str == ""
1194 then return $ Just stmt
1195 else do
1196 checkInputForLayout (stmt++"\n"++str) getStmt
1197 where goToEnd = do
1198 eof <- Lexer.nextIsEOF
1199 if eof
1200 then Lexer.activeContext
1201 else Lexer.lexer False return >> goToEnd
1202
1203 enqueueCommands :: GhciMonad m => [String] -> m ()
1204 enqueueCommands cmds = do
1205 -- make sure we force any exceptions in the commands while we're
1206 -- still inside the exception handler, otherwise bad things will
1207 -- happen (see #10501)
1208 cmds `deepseq` return ()
1209 modifyGHCiState $ \st -> st{ cmdqueue = cmds ++ cmdqueue st }
1210
1211 -- | Entry point to execute some haskell code from user.
1212 -- The return value True indicates success, as in `runOneCommand`.
1213 runStmt :: GhciMonad m => String -> SingleStep -> m (Maybe GHC.ExecResult)
1214 runStmt input step = do
1215 pflags <- initParserOpts <$> GHC.getInteractiveDynFlags
1216 -- In GHCi, we disable `-fdefer-type-errors`, as well as `-fdefer-type-holes`
1217 -- and `-fdefer-out-of-scope-variables` for **naked expressions**. The
1218 -- declarations and statements are not affected.
1219 -- See Note [Deferred type errors in GHCi] in GHC.Tc.Module
1220 st <- getGHCiState
1221 let source = progname st
1222 let line = line_number st
1223
1224 if | GHC.isStmt pflags input -> do
1225 hsc_env <- GHC.getSession
1226 mb_stmt <- liftIO (runInteractiveHsc hsc_env (hscParseStmtWithLocation source line input))
1227 case mb_stmt of
1228 Nothing ->
1229 -- empty statement / comment
1230 return (Just exec_complete)
1231 Just stmt ->
1232 run_stmt stmt
1233
1234 | GHC.isImport pflags input -> run_import
1235
1236 -- Every import declaration should be handled by `run_import`. As GHCi
1237 -- in general only accepts one command at a time, we simply throw an
1238 -- exception when the input contains multiple commands of which at least
1239 -- one is an import command (see #10663).
1240 | GHC.hasImport pflags input -> throwGhcException
1241 (CmdLineError "error: expecting a single import declaration")
1242
1243 -- Otherwise assume a declaration (or a list of declarations)
1244 -- Note: `GHC.isDecl` returns False on input like
1245 -- `data Infix a b = a :@: b; infixl 4 :@:`
1246 -- and should therefore not be used here.
1247 | otherwise -> do
1248 hsc_env <- GHC.getSession
1249 let !ic = hsc_IC hsc_env -- Bang-pattern to avoid space leaks
1250 setDumpFilePrefix ic
1251 -- `-ddump-to-file` must work for normal GHCi compilations /
1252 -- evaluations. (#17500)
1253 decls <- liftIO (hscParseDeclsWithLocation hsc_env source line input)
1254 run_decls decls
1255 where
1256 exec_complete = GHC.ExecComplete (Right []) 0
1257
1258 run_import = do
1259 addImportToContext input
1260 return (Just exec_complete)
1261
1262 run_stmt :: GhciMonad m => GhciLStmt GhcPs -> m (Maybe GHC.ExecResult)
1263 run_stmt stmt = do
1264 m_result <- GhciMonad.runStmt stmt input step
1265 case m_result of
1266 Nothing -> return Nothing
1267 Just result -> Just <$> afterRunStmt (const True) result
1268
1269 -- `x = y` (a declaration) should be treated as `let x = y` (a statement).
1270 -- The reason is because GHCi wasn't designed to support `x = y`, but then
1271 -- b98ff3 (#7253) added support for it, except it did not do a good job and
1272 -- caused problems like:
1273 --
1274 -- - not adding the binders defined this way in the necessary places caused
1275 -- `x = y` to not work in some cases (#12091).
1276 -- - some GHCi command crashed after `x = y` (#15721)
1277 -- - warning generation did not work for `x = y` (#11606)
1278 -- - because `x = y` is a declaration (instead of a statement) differences
1279 -- in generated code caused confusion (#16089)
1280 --
1281 -- Instead of dealing with all these problems individually here we fix this
1282 -- mess by just treating `x = y` as `let x = y`.
1283 run_decls :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe GHC.ExecResult)
1284 -- Only turn `FunBind` and `VarBind` into statements, other bindings
1285 -- (e.g. `PatBind`) need to stay as decls.
1286 run_decls [L l (ValD _ bind@FunBind{})] = run_stmt (mk_stmt (locA l) bind)
1287 run_decls [L l (ValD _ bind@VarBind{})] = run_stmt (mk_stmt (locA l) bind)
1288 -- Note that any `x = y` declarations below will be run as declarations
1289 -- instead of statements (e.g. `...; x = y; ...`)
1290 run_decls decls = do
1291 -- In the new IO library, read handles buffer data even if the Handle
1292 -- is set to NoBuffering. This causes problems for GHCi where there
1293 -- are really two stdin Handles. So we flush any bufferred data in
1294 -- GHCi's stdin Handle here (only relevant if stdin is attached to
1295 -- a file, otherwise the read buffer can't be flushed).
1296 _ <- liftIO $ tryIO $ hFlushAll stdin
1297 m_result <- GhciMonad.runDecls' decls
1298 forM m_result $ \result ->
1299 afterRunStmt (const True) (GHC.ExecComplete (Right result) 0)
1300
1301 mk_stmt :: SrcSpan -> HsBind GhcPs -> GhciLStmt GhcPs
1302 mk_stmt loc bind =
1303 let
1304 la = L (noAnnSrcSpan loc)
1305 la' = L (noAnnSrcSpan loc)
1306 in la (LetStmt noAnn (HsValBinds noAnn (ValBinds NoAnnSortKey (unitBag (la' bind)) [])))
1307
1308 setDumpFilePrefix :: GHC.GhcMonad m => InteractiveContext -> m () -- #17500
1309 setDumpFilePrefix ic = do
1310 dflags <- GHC.getInteractiveDynFlags
1311 GHC.setInteractiveDynFlags dflags { dumpPrefix = Just (modStr ++ ".") }
1312 where
1313 modStr = moduleNameString $ moduleName $ icInteractiveModule $ ic
1314
1315 -- | Clean up the GHCi environment after a statement has run
1316 afterRunStmt :: GhciMonad m
1317 => (SrcSpan -> Bool) -> GHC.ExecResult -> m GHC.ExecResult
1318 afterRunStmt step_here run_result = do
1319 resumes <- GHC.getResumeContext
1320 case run_result of
1321 GHC.ExecComplete{..} ->
1322 case execResult of
1323 Left ex -> liftIO $ Exception.throwIO ex
1324 Right names -> do
1325 show_types <- isOptionSet ShowType
1326 when show_types $ printTypeOfNames names
1327 GHC.ExecBreak names mb_info
1328 | isNothing mb_info ||
1329 step_here (GHC.resumeSpan $ head resumes) -> do
1330 mb_id_loc <- toBreakIdAndLocation mb_info
1331 let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
1332 if (null bCmd)
1333 then printStoppedAtBreakInfo (head resumes) names
1334 else enqueueCommands [bCmd]
1335 -- run the command set with ":set stop <cmd>"
1336 st <- getGHCiState
1337 enqueueCommands [stop st]
1338 return ()
1339 | otherwise -> resume step_here GHC.SingleStep Nothing >>=
1340 afterRunStmt step_here >> return ()
1341
1342 flushInterpBuffers
1343 withSignalHandlers $ do
1344 b <- isOptionSet RevertCAFs
1345 when b revertCAFs
1346
1347 return run_result
1348
1349 runSuccess :: Maybe GHC.ExecResult -> Bool
1350 runSuccess run_result
1351 | Just (GHC.ExecComplete { execResult = Right _ }) <- run_result = True
1352 | otherwise = False
1353
1354 runAllocs :: Maybe GHC.ExecResult -> Maybe Integer
1355 runAllocs m = do
1356 res <- m
1357 case res of
1358 GHC.ExecComplete{..} -> Just (fromIntegral execAllocation)
1359 _ -> Nothing
1360
1361 toBreakIdAndLocation :: GhciMonad m
1362 => Maybe GHC.BreakInfo -> m (Maybe (Int, BreakLocation))
1363 toBreakIdAndLocation Nothing = return Nothing
1364 toBreakIdAndLocation (Just inf) = do
1365 let md = GHC.breakInfo_module inf
1366 nm = GHC.breakInfo_number inf
1367 st <- getGHCiState
1368 return $ listToMaybe [ id_loc | id_loc@(_,loc) <- IntMap.assocs (breaks st),
1369 breakModule loc == md,
1370 breakTick loc == nm ]
1371
1372 printStoppedAtBreakInfo :: GHC.GhcMonad m => Resume -> [Name] -> m ()
1373 printStoppedAtBreakInfo res names = do
1374 printForUser $ pprStopped res
1375 -- printTypeOfNames session names
1376 let namesSorted = sortBy compareNames names
1377 tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
1378 docs <- mapM pprTypeAndContents [i | AnId i <- tythings]
1379 printForUserPartWay $ vcat docs
1380
1381 printTypeOfNames :: GHC.GhcMonad m => [Name] -> m ()
1382 printTypeOfNames names
1383 = mapM_ (printTypeOfName ) $ sortBy compareNames names
1384
1385 compareNames :: Name -> Name -> Ordering
1386 n1 `compareNames` n2 =
1387 (compare `on` getOccString) n1 n2 `thenCmp`
1388 (SrcLoc.leftmost_smallest `on` getSrcSpan) n1 n2
1389
1390 printTypeOfName :: GHC.GhcMonad m => Name -> m ()
1391 printTypeOfName n
1392 = do maybe_tything <- GHC.lookupName n
1393 case maybe_tything of
1394 Nothing -> return ()
1395 Just thing -> printTyThing thing
1396
1397
1398 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
1399
1400 -- | Entry point for execution a ':<command>' input from user
1401 specialCommand :: String -> InputT GHCi Bool
1402 specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
1403 specialCommand str = do
1404 let (cmd,rest) = break isSpace str
1405 maybe_cmd <- lookupCommand cmd
1406 htxt <- short_help <$> getGHCiState
1407 case maybe_cmd of
1408 GotCommand cmd -> (cmdAction cmd) (dropWhile isSpace rest)
1409 BadCommand ->
1410 do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
1411 ++ htxt)
1412 return False
1413 NoLastCommand ->
1414 do liftIO $ hPutStr stdout ("there is no last command to perform\n"
1415 ++ htxt)
1416 return False
1417
1418 shellEscape :: MonadIO m => String -> m Bool
1419 shellEscape str = liftIO (system str >> return False)
1420
1421 lookupCommand :: GhciMonad m => String -> m (MaybeCommand)
1422 lookupCommand "" = do
1423 st <- getGHCiState
1424 case last_command st of
1425 Just c -> return $ GotCommand c
1426 Nothing -> return NoLastCommand
1427 lookupCommand str = do
1428 mc <- lookupCommand' str
1429 modifyGHCiState (\st -> st { last_command = mc })
1430 return $ case mc of
1431 Just c -> GotCommand c
1432 Nothing -> BadCommand
1433
1434 lookupCommand' :: GhciMonad m => String -> m (Maybe Command)
1435 lookupCommand' ":" = return Nothing
1436 lookupCommand' str' = do
1437 macros <- ghci_macros <$> getGHCiState
1438 ghci_cmds <- ghci_commands <$> getGHCiState
1439
1440 let ghci_cmds_nohide = filter (not . cmdHidden) ghci_cmds
1441
1442 let (str, xcmds) = case str' of
1443 ':' : rest -> (rest, []) -- "::" selects a builtin command
1444 _ -> (str', macros) -- otherwise include macros in lookup
1445
1446 lookupExact s = find $ (s ==) . cmdName
1447 lookupPrefix s = find $ (s `isPrefixOptOf`) . cmdName
1448
1449 -- hidden commands can only be matched exact
1450 builtinPfxMatch = lookupPrefix str ghci_cmds_nohide
1451
1452 -- first, look for exact match (while preferring macros); then, look
1453 -- for first prefix match (preferring builtins), *unless* a macro
1454 -- overrides the builtin; see #8305 for motivation
1455 return $ lookupExact str xcmds <|>
1456 lookupExact str ghci_cmds <|>
1457 (builtinPfxMatch >>= \c -> lookupExact (cmdName c) xcmds) <|>
1458 builtinPfxMatch <|>
1459 lookupPrefix str xcmds
1460
1461 -- This predicate is for prefix match with a command-body and
1462 -- suffix match with an option, such as `!`.
1463 -- The current implementation assumes only the `!` character
1464 -- as the option delimiter.
1465 -- See also #17345
1466 isPrefixOptOf :: String -> String -> Bool
1467 isPrefixOptOf s x = let (body, opt) = break (== '!') s
1468 in (body `isPrefixOf` x) && (opt `isSuffixOf` x)
1469
1470 getCurrentBreakSpan :: GHC.GhcMonad m => m (Maybe SrcSpan)
1471 getCurrentBreakSpan = do
1472 resumes <- GHC.getResumeContext
1473 case resumes of
1474 [] -> return Nothing
1475 (r:_) -> do
1476 let ix = GHC.resumeHistoryIx r
1477 if ix == 0
1478 then return (Just (GHC.resumeSpan r))
1479 else do
1480 let hist = GHC.resumeHistory r !! (ix-1)
1481 pan <- GHC.getHistorySpan hist
1482 return (Just pan)
1483
1484 getCallStackAtCurrentBreakpoint :: GHC.GhcMonad m => m (Maybe [String])
1485 getCallStackAtCurrentBreakpoint = do
1486 resumes <- GHC.getResumeContext
1487 case resumes of
1488 [] -> return Nothing
1489 (r:_) -> do
1490 interp <- hscInterp <$> GHC.getSession
1491 Just <$> liftIO (costCentreStackInfo interp (GHC.resumeCCS r))
1492
1493 getCurrentBreakModule :: GHC.GhcMonad m => m (Maybe Module)
1494 getCurrentBreakModule = do
1495 resumes <- GHC.getResumeContext
1496 case resumes of
1497 [] -> return Nothing
1498 (r:_) -> do
1499 let ix = GHC.resumeHistoryIx r
1500 if ix == 0
1501 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
1502 else do
1503 let hist = GHC.resumeHistory r !! (ix-1)
1504 return $ Just $ GHC.getHistoryModule hist
1505
1506 -----------------------------------------------------------------------------
1507 --
1508 -- Commands
1509 --
1510 -----------------------------------------------------------------------------
1511
1512 noArgs :: MonadIO m => m () -> String -> m ()
1513 noArgs m "" = m
1514 noArgs _ _ = liftIO $ putStrLn "This command takes no arguments"
1515
1516 withSandboxOnly :: GHC.GhcMonad m => String -> m () -> m ()
1517 withSandboxOnly cmd this = do
1518 dflags <- getDynFlags
1519 if not (gopt Opt_GhciSandbox dflags)
1520 then printForUser (text cmd <+>
1521 text "is not supported with -fno-ghci-sandbox")
1522 else this
1523
1524 -----------------------------------------------------------------------------
1525 -- :help
1526
1527 help :: GhciMonad m => String -> m ()
1528 help _ = do
1529 txt <- long_help `fmap` getGHCiState
1530 liftIO $ putStr txt
1531
1532 -----------------------------------------------------------------------------
1533 -- :info
1534
1535 info :: GHC.GhcMonad m => Bool -> String -> m ()
1536 info _ "" = throwGhcException (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
1537 info allInfo s = handleSourceError GHC.printException $ do
1538 unqual <- GHC.getPrintUnqual
1539 dflags <- getDynFlags
1540 sdocs <- mapM (infoThing allInfo) (words s)
1541 unit_state <- hsc_units <$> GHC.getSession
1542 mapM_ (liftIO . putStrLn . showSDocForUser dflags unit_state unqual) sdocs
1543
1544 infoThing :: GHC.GhcMonad m => Bool -> String -> m SDoc
1545 infoThing allInfo str = do
1546 names <- GHC.parseName str
1547 mb_stuffs <- mapM (GHC.getInfo allInfo) names
1548 let filtered = filterOutChildren (\(t,_f,_ci,_fi,_sd) -> t)
1549 (catMaybes mb_stuffs)
1550 return $ vcat (intersperse (text "") $ map pprInfo filtered)
1551
1552 -- Filter out names whose parent is also there. Good
1553 -- example is '[]', which is both a type and data
1554 -- constructor in the same type
1555 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
1556 filterOutChildren get_thing xs
1557 = filterOut has_parent xs
1558 where
1559 all_names = mkNameSet (map (getName . get_thing) xs)
1560 has_parent x = case tyThingParent_maybe (get_thing x) of
1561 Just p -> getName p `elemNameSet` all_names
1562 Nothing -> False
1563
1564 pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc
1565 pprInfo (thing, fixity, cls_insts, fam_insts, docs)
1566 = docs
1567 $$ pprTyThingInContextLoc thing
1568 $$ showFixity thing fixity
1569 $$ vcat (map GHC.pprInstance cls_insts)
1570 $$ vcat (map GHC.pprFamInst fam_insts)
1571
1572 -----------------------------------------------------------------------------
1573 -- :main
1574
1575 runMain :: GhciMonad m => String -> m ()
1576 runMain s = case toArgsNoLoc s of
1577 Left err -> liftIO (hPutStrLn stderr err)
1578 Right args ->
1579 do dflags <- getDynFlags
1580 let main = fromMaybe "main" (mainFunIs dflags)
1581 -- Wrap the main function in 'void' to discard its value instead
1582 -- of printing it (#9086). See Haskell 2010 report Chapter 5.
1583 doWithArgs args $ "Control.Monad.void (" ++ main ++ ")"
1584
1585 -----------------------------------------------------------------------------
1586 -- :run
1587
1588 runRun :: GhciMonad m => String -> m ()
1589 runRun s = case toCmdArgs s of
1590 Left err -> liftIO (hPutStrLn stderr err)
1591 Right (cmd, args) -> doWithArgs args cmd
1592
1593 doWithArgs :: GhciMonad m => [String] -> String -> m ()
1594 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
1595 show args ++ " (" ++ cmd ++ ")"]
1596
1597 {-
1598 Akin to @Prelude.words@, but acts like the Bourne shell, treating
1599 quoted strings as Haskell Strings, and also parses Haskell [String]
1600 syntax.
1601 -}
1602
1603 getCmd :: String -> Either String -- Error
1604 (String, String) -- (Cmd, Rest)
1605 getCmd s = case break isSpace $ dropWhile isSpace s of
1606 ([], _) -> Left ("Couldn't find command in " ++ show s)
1607 res -> Right res
1608
1609 toCmdArgs :: String -> Either String -- Error
1610 (String, [String]) -- (Cmd, Args)
1611 toCmdArgs s = case getCmd s of
1612 Left err -> Left err
1613 Right (cmd, s') -> case toArgsNoLoc s' of
1614 Left err -> Left err
1615 Right args -> Right (cmd, args)
1616
1617 -- wrapper around GHC.Parser.Header.toArgs, but without locations
1618 toArgsNoLoc :: String -> Either String [String]
1619 toArgsNoLoc str = map unLoc <$> toArgs fake_loc str
1620 where
1621 fake_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
1622 -- this should never be seen, because it's discarded with the `map unLoc`
1623
1624 -----------------------------------------------------------------------------
1625 -- :cd
1626
1627 changeDirectory :: GhciMonad m => String -> m ()
1628 changeDirectory "" = do
1629 -- :cd on its own changes to the user's home directory
1630 either_dir <- liftIO $ tryIO getHomeDirectory
1631 case either_dir of
1632 Left _e -> return ()
1633 Right dir -> changeDirectory dir
1634 changeDirectory dir = do
1635 graph <- GHC.getModuleGraph
1636 when (not (null $ GHC.mgModSummaries graph)) $
1637 liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."
1638 -- delete targets and all eventually defined breakpoints (#1620)
1639 clearAllTargets
1640 setContextAfterLoad False []
1641 GHC.workingDirectoryChanged
1642 dir' <- expandPath dir
1643 liftIO $ setCurrentDirectory dir'
1644 -- With -fexternal-interpreter, we have to change the directory of the subprocess too.
1645 -- (this gives consistent behaviour with and without -fexternal-interpreter)
1646 interp <- hscInterp <$> GHC.getSession
1647 case interpInstance interp of
1648 ExternalInterp {} -> do
1649 fhv <- compileGHCiExpr $
1650 "System.Directory.setCurrentDirectory " ++ show dir'
1651 liftIO $ evalIO interp fhv
1652 _ -> pure ()
1653
1654 trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
1655 trySuccess act =
1656 handleSourceError (\e -> do GHC.printException e
1657 return Failed) $ do
1658 act
1659
1660 trySuccessWithRes :: (Monoid a, GHC.GhcMonad m) => m (SuccessFlag, a) -> m (SuccessFlag, a)
1661 trySuccessWithRes act =
1662 handleSourceError (\e -> do GHC.printException e
1663 return (Failed, mempty))
1664 act
1665
1666 -----------------------------------------------------------------------------
1667 -- :edit
1668
1669 editFile :: GhciMonad m => String -> m ()
1670 editFile str =
1671 do file <- if null str then chooseEditFile else expandPath str
1672 st <- getGHCiState
1673 errs <- liftIO $ readIORef $ lastErrorLocations st
1674 let cmd = editor st
1675 when (null cmd)
1676 $ throwGhcException (CmdLineError "editor not set, use :set editor")
1677 lineOpt <- liftIO $ do
1678 let sameFile p1 p2 = liftA2 (==) (canonicalizePath p1) (canonicalizePath p2)
1679 `catchIO` (\_ -> return False)
1680
1681 curFileErrs <- filterM (\(f, _) -> unpackFS f `sameFile` file) errs
1682 return $ case curFileErrs of
1683 (_, line):_ -> " +" ++ show line
1684 _ -> ""
1685 let cmdArgs = ' ':(file ++ lineOpt)
1686 code <- liftIO $ system (cmd ++ cmdArgs)
1687
1688 when (code == ExitSuccess)
1689 $ reloadModule ""
1690
1691 -- The user didn't specify a file so we pick one for them.
1692 -- Our strategy is to pick the first module that failed to load,
1693 -- or otherwise the first target.
1694 --
1695 -- XXX: Can we figure out what happened if the depndecy analysis fails
1696 -- (e.g., because the porgrammeer mistyped the name of a module)?
1697 -- XXX: Can we figure out the location of an error to pass to the editor?
1698 -- XXX: if we could figure out the list of errors that occurred during the
1699 -- last load/reaload, then we could start the editor focused on the first
1700 -- of those.
1701 chooseEditFile :: GHC.GhcMonad m => m String
1702 chooseEditFile =
1703 do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
1704
1705 graph <- GHC.getModuleGraph
1706 failed_graph <-
1707 GHC.mkModuleGraph . fmap extendModSummaryNoDeps <$> filterM hasFailed (GHC.mgModSummaries graph)
1708 let order g = flattenSCCs $ filterToposortToModules $
1709 GHC.topSortModuleGraph True g Nothing
1710 pick xs = case xs of
1711 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
1712 _ -> Nothing
1713
1714 case pick (order failed_graph) of
1715 Just file -> return file
1716 Nothing ->
1717 do targets <- GHC.getTargets
1718 case msum (map fromTarget targets) of
1719 Just file -> return file
1720 Nothing -> throwGhcException (CmdLineError "No files to edit.")
1721
1722 where fromTarget GHC.Target { targetId = GHC.TargetFile f _ } = Just f
1723 fromTarget _ = Nothing -- when would we get a module target?
1724
1725
1726 -----------------------------------------------------------------------------
1727 -- :def
1728
1729 defineMacro :: GhciMonad m => Bool{-overwrite-} -> String -> m ()
1730 defineMacro _ (':':_) = liftIO $ putStrLn
1731 "macro name cannot start with a colon"
1732 defineMacro _ ('!':_) = liftIO $ putStrLn
1733 "macro name cannot start with an exclamation mark"
1734 -- little code duplication allows to grep error msg
1735 defineMacro overwrite s = do
1736 let (macro_name, definition) = break isSpace s
1737 macros <- ghci_macros <$> getGHCiState
1738 let defined = map cmdName macros
1739 if null macro_name
1740 then if null defined
1741 then liftIO $ putStrLn "no macros defined"
1742 else liftIO $ putStr ("the following macros are defined:\n" ++
1743 unlines defined)
1744 else do
1745 isCommand <- isJust <$> lookupCommand' macro_name
1746 let check_newname
1747 | macro_name `elem` defined = throwGhcException (CmdLineError
1748 ("macro '" ++ macro_name ++ "' is already defined. " ++ hint))
1749 | isCommand = throwGhcException (CmdLineError
1750 ("macro '" ++ macro_name ++ "' overwrites builtin command. " ++ hint))
1751 | otherwise = return ()
1752 hint = " Use ':def!' to overwrite."
1753
1754 unless overwrite check_newname
1755 -- compile the expression
1756 handleSourceError GHC.printException $ do
1757 step <- getGhciStepIO
1758 expr <- GHC.parseExpr definition
1759 -- > ghciStepIO . definition :: String -> IO String
1760 let stringTy :: LHsType GhcPs
1761 stringTy = nlHsTyVar stringTyCon_RDR
1762 ioM :: LHsType GhcPs -- AZ
1763 ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy
1764 body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)
1765 `mkHsApp` (nlHsPar expr)
1766 tySig = mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType $
1767 nlHsFunTy stringTy ioM
1768 new_expr = L (getLoc expr) $ ExprWithTySig noAnn body tySig
1769 hv <- GHC.compileParsedExprRemote new_expr
1770
1771 let newCmd = Command { cmdName = macro_name
1772 , cmdAction = lift . runMacro hv
1773 , cmdHidden = False
1774 , cmdCompletionFunc = noCompletion
1775 }
1776
1777 -- later defined macros have precedence
1778 modifyGHCiState $ \s ->
1779 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
1780 in s { ghci_macros = newCmd : filtered }
1781
1782 runMacro
1783 :: GhciMonad m
1784 => GHC.ForeignHValue -- String -> IO String
1785 -> String
1786 -> m Bool
1787 runMacro fun s = do
1788 interp <- hscInterp <$> GHC.getSession
1789 str <- liftIO $ evalStringToIOString interp fun s
1790 enqueueCommands (lines str)
1791 return False
1792
1793
1794 -----------------------------------------------------------------------------
1795 -- :undef
1796
1797 undefineMacro :: GhciMonad m => String -> m ()
1798 undefineMacro str = mapM_ undef (words str)
1799 where undef macro_name = do
1800 cmds <- ghci_macros <$> getGHCiState
1801 if (macro_name `notElem` map cmdName cmds)
1802 then throwGhcException (CmdLineError
1803 ("macro '" ++ macro_name ++ "' is not defined"))
1804 else do
1805 -- This is a tad racy but really, it's a shell
1806 modifyGHCiState $ \s ->
1807 s { ghci_macros = filter ((/= macro_name) . cmdName)
1808 (ghci_macros s) }
1809
1810
1811 -----------------------------------------------------------------------------
1812 -- :cmd
1813
1814 cmdCmd :: GhciMonad m => String -> m ()
1815 cmdCmd str = handleSourceError GHC.printException $ do
1816 step <- getGhciStepIO
1817 expr <- GHC.parseExpr str
1818 -- > ghciStepIO str :: IO String
1819 let new_expr = step `mkHsApp` expr
1820 hv <- GHC.compileParsedExprRemote new_expr
1821
1822 interp <- hscInterp <$> GHC.getSession
1823 cmds <- liftIO $ evalString interp hv
1824 enqueueCommands (lines cmds)
1825
1826 -- | Generate a typed ghciStepIO expression
1827 -- @ghciStepIO :: Ty String -> IO String@.
1828 getGhciStepIO :: GHC.GhcMonad m => m (LHsExpr GhcPs)
1829 getGhciStepIO = do
1830 ghciTyConName <- GHC.getGHCiMonad
1831 let stringTy = nlHsTyVar stringTyCon_RDR
1832 ghciM = nlHsTyVar (getRdrName ghciTyConName) `nlHsAppTy` stringTy
1833 ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy
1834 body = nlHsVar (getRdrName ghciStepIoMName)
1835 tySig = mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType $
1836 nlHsFunTy ghciM ioM
1837 return $ noLocA $ ExprWithTySig noAnn body tySig
1838
1839 -----------------------------------------------------------------------------
1840 -- :check
1841
1842 checkModule :: GhciMonad m => String -> m ()
1843 checkModule m = do
1844 let modl = GHC.mkModuleName m
1845 ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do
1846 r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
1847 dflags <- getDynFlags
1848 liftIO $ putStrLn $ showSDoc dflags $
1849 case GHC.moduleInfo r of
1850 cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1851 let
1852 (loc, glob) = assert (all isExternalName scope) $
1853 partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1854 in
1855 (text "global names: " <+> ppr glob) $$
1856 (text "local names: " <+> ppr loc)
1857 _ -> empty
1858 return True
1859 afterLoad (successIf ok) False
1860
1861 -----------------------------------------------------------------------------
1862 -- :doc
1863
1864 docCmd :: GHC.GhcMonad m => String -> m ()
1865 docCmd "" =
1866 throwGhcException (CmdLineError "syntax: ':doc <thing-you-want-docs-for>'")
1867 docCmd s = do
1868 -- TODO: Maybe also get module headers for module names
1869 names <- GHC.parseName s
1870
1871 docs <- traverse (buildDocComponents s) names
1872
1873 let sdocs = pprDocs docs
1874 sdocs' = vcat (intersperse (text "") sdocs)
1875 unqual <- GHC.getPrintUnqual
1876 dflags <- getDynFlags
1877 unit_state <- hsc_units <$> GHC.getSession
1878 (liftIO . putStrLn . showSDocForUser dflags unit_state unqual) sdocs'
1879
1880 data DocComponents =
1881 DocComponents
1882 { docs :: Maybe HsDocString -- ^ subject's haddocks
1883 , sigAndLoc :: Maybe SDoc -- ^ type signature + category + location
1884 , argDocs :: IntMap HsDocString -- ^ haddocks for arguments
1885 }
1886
1887 buildDocComponents :: GHC.GhcMonad m => String -> Name -> m DocComponents
1888 buildDocComponents str name = do
1889 mbThing <- GHC.lookupName name
1890 let sigAndLoc = sigAndLocDoc str <$> mbThing
1891 (docs, argDocs)
1892 <- either handleGetDocsFailure pure
1893 =<< GHC.getDocs name
1894
1895 pure DocComponents{..}
1896
1897 -- | Produce output containing the type/kind signature, category, and definition
1898 -- location of a TyThing.
1899 sigAndLocDoc :: String -> TyThing -> SDoc
1900 sigAndLocDoc str tyThing =
1901 let tyThingTyDoc :: TyThing -> SDoc
1902 tyThingTyDoc = \case
1903 AnId i -> pprSigmaType $ varType i
1904 AConLike (RealDataCon dc) -> pprSigmaType $ dataConDisplayType False dc
1905 AConLike (PatSynCon patSyn) -> pprPatSynType patSyn
1906 ATyCon tyCon -> pprSigmaType $ GHC.tyConKind tyCon
1907 ACoAxiom _ -> empty
1908
1909 tyDoc = tyThingTyDoc tyThing
1910 sigDoc = text str <+> nest 2 (dcolon <+> tyDoc)
1911 comment =
1912 hsep [ char '\t' <> text "--"
1913 , pprTyThingCategory tyThing
1914 , text "defined" <+> pprNameDefnLoc (getName tyThing)
1915 ]
1916 in hang sigDoc 2 comment
1917
1918 pprDocs :: [DocComponents] -> [SDoc]
1919 pprDocs docs
1920 | null nonEmptyDocs = pprDoc <$> take 1 docs
1921 -- elide <has no documentation> if there's at least one non-empty doc (#15784)
1922 | otherwise = pprDoc <$> nonEmptyDocs
1923 where
1924 empty DocComponents{docs = mb_decl_docs, argDocs = arg_docs}
1925 = isNothing mb_decl_docs && null arg_docs
1926 nonEmptyDocs = filter (not . empty) docs
1927
1928 -- TODO: also print arg docs.
1929 pprDoc :: DocComponents -> SDoc
1930 pprDoc DocComponents{sigAndLoc = mb_sig_loc, docs = mb_decl_docs} =
1931 maybe
1932 (text "<has no documentation>")
1933 formatDoc
1934 mb_decl_docs
1935 where
1936 formatDoc doc =
1937 vcat [ fromMaybe empty mb_sig_loc -- print contextual info (#19055)
1938 , text $ unpackHDS doc
1939 ]
1940
1941 handleGetDocsFailure :: GHC.GhcMonad m => GetDocsFailure -> m a
1942 handleGetDocsFailure no_docs = do
1943 dflags <- getDynFlags
1944 let msg = showPpr dflags no_docs
1945 throwGhcException $ case no_docs of
1946 NameHasNoModule {} -> Sorry msg
1947 NoDocsInIface {} -> InstallationError msg
1948 InteractiveName -> ProgramError msg
1949
1950 -----------------------------------------------------------------------------
1951 -- :instances
1952
1953 instancesCmd :: String -> InputT GHCi ()
1954 instancesCmd "" =
1955 throwGhcException (CmdLineError "syntax: ':instances <type-you-want-instances-for>'")
1956 instancesCmd s = do
1957 handleSourceError GHC.printException $ do
1958 ty <- GHC.parseInstanceHead s
1959 res <- GHC.getInstancesForType ty
1960
1961 printForUser $ vcat $ map ppr res
1962
1963 -----------------------------------------------------------------------------
1964 -- :load, :add, :reload
1965
1966 -- | Sets '-fdefer-type-errors' if 'defer' is true, executes 'load' and unsets
1967 -- '-fdefer-type-errors' again if it has not been set before.
1968 wrapDeferTypeErrors :: GHC.GhcMonad m => m a -> m a
1969 wrapDeferTypeErrors load =
1970 MC.bracket
1971 (do
1972 -- Force originalFlags to avoid leaking the associated HscEnv
1973 !originalFlags <- getDynFlags
1974 void $ GHC.setProgramDynFlags $
1975 setGeneralFlag' Opt_DeferTypeErrors originalFlags
1976 return originalFlags)
1977 (\originalFlags -> void $ GHC.setProgramDynFlags originalFlags)
1978 (\_ -> load)
1979
1980 loadModule :: GhciMonad m => [(FilePath, Maybe Phase)] -> m SuccessFlag
1981 loadModule fs = do
1982 (_, result) <- runAndPrintStats (const Nothing) (loadModule' fs)
1983 either (liftIO . Exception.throwIO) return result
1984
1985 -- | @:load@ command
1986 loadModule_ :: GhciMonad m => [FilePath] -> m ()
1987 loadModule_ fs = void $ loadModule (zip fs (repeat Nothing))
1988
1989 loadModuleDefer :: GhciMonad m => [FilePath] -> m ()
1990 loadModuleDefer = wrapDeferTypeErrors . loadModule_
1991
1992 loadModule' :: GhciMonad m => [(FilePath, Maybe Phase)] -> m SuccessFlag
1993 loadModule' files = do
1994 let (filenames, phases) = unzip files
1995 exp_filenames <- mapM expandPath filenames
1996 let files' = zip exp_filenames phases
1997 targets <- mapM (\(file, phase) -> GHC.guessTarget file Nothing phase) files'
1998
1999 -- NOTE: we used to do the dependency anal first, so that if it
2000 -- fails we didn't throw away the current set of modules. This would
2001 -- require some re-working of the GHC interface, so we'll leave it
2002 -- as a ToDo for now.
2003
2004 hsc_env <- GHC.getSession
2005 let !dflags = hsc_dflags hsc_env
2006
2007 let load_module = do
2008 -- unload first
2009 _ <- GHC.abandonAll
2010 clearAllTargets
2011
2012 GHC.setTargets targets
2013 doLoadAndCollectInfo False LoadAllTargets
2014
2015 if gopt Opt_GhciLeakCheck dflags
2016 then do
2017 -- Grab references to the currently loaded modules so that we can see if
2018 -- they leak.
2019 leak_indicators <- liftIO $ getLeakIndicators hsc_env
2020 success <- load_module
2021 liftIO $ checkLeakIndicators dflags leak_indicators
2022 return success
2023 else
2024 load_module
2025
2026 -- | @:add@ command
2027 addModule :: GhciMonad m => [FilePath] -> m ()
2028 addModule files = do
2029 revertCAFs -- always revert CAFs on load/add.
2030 files' <- mapM expandPath files
2031 targets <- mapM (\m -> GHC.guessTarget m Nothing Nothing) files'
2032 targets' <- filterM checkTarget targets
2033 -- remove old targets with the same id; e.g. for :add *M
2034 mapM_ GHC.removeTarget [ tid | Target { targetId = tid } <- targets' ]
2035 mapM_ GHC.addTarget targets'
2036 _ <- doLoadAndCollectInfo False LoadAllTargets
2037 return ()
2038 where
2039 checkTarget :: GHC.GhcMonad m => Target -> m Bool
2040 checkTarget Target { targetId = TargetModule m } = checkTargetModule m
2041 checkTarget Target { targetId = TargetFile f _ } = liftIO $ checkTargetFile f
2042
2043 checkTargetModule :: GHC.GhcMonad m => ModuleName -> m Bool
2044 checkTargetModule m = do
2045 hsc_env <- GHC.getSession
2046 let fc = hsc_FC hsc_env
2047 let home_unit = hsc_home_unit hsc_env
2048 let units = hsc_units hsc_env
2049 let dflags = hsc_dflags hsc_env
2050 let fopts = initFinderOpts dflags
2051 result <- liftIO $
2052 Finder.findImportedModule fc fopts units home_unit m (ThisPkg (homeUnitId home_unit))
2053 case result of
2054 Found _ _ -> return True
2055 _ -> (liftIO $ putStrLn $
2056 "Module " ++ moduleNameString m ++ " not found") >> return False
2057
2058 checkTargetFile :: String -> IO Bool
2059 checkTargetFile f = do
2060 exists <- (doesFileExist f) :: IO Bool
2061 unless exists $ putStrLn $ "File " ++ f ++ " not found"
2062 return exists
2063
2064 -- | @:unadd@ command
2065 unAddModule :: GhciMonad m => [FilePath] -> m ()
2066 unAddModule files = do
2067 files' <- mapM expandPath files
2068 targets <- mapM (\m -> GHC.guessTarget m Nothing Nothing) files'
2069 mapM_ GHC.removeTarget [ tid | Target { targetId = tid } <- targets ]
2070 _ <- doLoadAndCollectInfo False LoadAllTargets
2071 return ()
2072
2073 -- | @:reload@ command
2074 reloadModule :: GhciMonad m => String -> m ()
2075 reloadModule m = void $ doLoadAndCollectInfo True loadTargets
2076 where
2077 loadTargets | null m = LoadAllTargets
2078 | otherwise = LoadUpTo (GHC.mkModuleName m)
2079
2080 reloadModuleDefer :: GhciMonad m => String -> m ()
2081 reloadModuleDefer = wrapDeferTypeErrors . reloadModule
2082
2083 -- | Load/compile targets and (optionally) collect module-info
2084 --
2085 -- This collects the necessary SrcSpan annotated type information (via
2086 -- 'collectInfo') required by the @:all-types@, @:loc-at@, @:type-at@,
2087 -- and @:uses@ commands.
2088 --
2089 -- Meta-info collection is not enabled by default and needs to be
2090 -- enabled explicitly via @:set +c@. The reason is that collecting
2091 -- the type-information for all sub-spans can be quite expensive, and
2092 -- since those commands are designed to be used by editors and
2093 -- tooling, it's useless to collect this data for normal GHCi
2094 -- sessions.
2095 doLoadAndCollectInfo :: GhciMonad m => Bool -> LoadHowMuch -> m SuccessFlag
2096 doLoadAndCollectInfo retain_context howmuch = do
2097 doCollectInfo <- isOptionSet CollectInfo
2098
2099 doLoad retain_context howmuch >>= \case
2100 Succeeded | doCollectInfo -> do
2101 mod_summaries <- GHC.mgModSummaries <$> getModuleGraph
2102 loaded <- filterM GHC.isLoaded $ map GHC.ms_mod_name mod_summaries
2103 v <- mod_infos <$> getGHCiState
2104 !newInfos <- collectInfo v loaded
2105 modifyGHCiState (\st -> st { mod_infos = newInfos })
2106 return Succeeded
2107 flag -> return flag
2108
2109 doLoad :: GhciMonad m => Bool -> LoadHowMuch -> m SuccessFlag
2110 doLoad retain_context howmuch = do
2111 -- turn off breakpoints before we load: we can't turn them off later, because
2112 -- the ModBreaks will have gone away.
2113 discardActiveBreakPoints
2114
2115 resetLastErrorLocations
2116 -- Enable buffering stdout and stderr as we're compiling. Keeping these
2117 -- handles unbuffered will just slow the compilation down, especially when
2118 -- compiling in parallel.
2119 MC.bracket (liftIO $ do hSetBuffering stdout LineBuffering
2120 hSetBuffering stderr LineBuffering)
2121 (\_ ->
2122 liftIO $ do hSetBuffering stdout NoBuffering
2123 hSetBuffering stderr NoBuffering) $ \_ -> do
2124 hmis <- hmiCache <$> getGHCiState
2125 modifyGHCiState (\ghci -> ghci { hmiCache = [] })
2126 (ok, new_cache) <- trySuccessWithRes $ GHC.loadWithCache hmis howmuch
2127 modifyGHCiState (\ghci -> ghci { hmiCache = new_cache })
2128 afterLoad ok retain_context
2129 return ok
2130
2131
2132 afterLoad
2133 :: GhciMonad m
2134 => SuccessFlag
2135 -> Bool -- keep the remembered_ctx, as far as possible (:reload)
2136 -> m ()
2137 afterLoad ok retain_context = do
2138 revertCAFs -- always revert CAFs on load.
2139 discardTickArrays
2140 loaded_mods <- getLoadedModules
2141 modulesLoadedMsg ok loaded_mods
2142 setContextAfterLoad retain_context loaded_mods
2143
2144 setContextAfterLoad :: GhciMonad m => Bool -> [GHC.ModSummary] -> m ()
2145 setContextAfterLoad keep_ctxt [] = do
2146 setContextKeepingPackageModules keep_ctxt []
2147 setContextAfterLoad keep_ctxt ms = do
2148 -- load a target if one is available, otherwise load the topmost module.
2149 targets <- GHC.getTargets
2150 case [ m | Just m <- map (findTarget ms) targets ] of
2151 [] ->
2152 let graph = GHC.mkModuleGraph $ extendModSummaryNoDeps <$> ms
2153 graph' = flattenSCCs $ filterToposortToModules $
2154 GHC.topSortModuleGraph True graph Nothing
2155 in load_this (last graph')
2156 (m:_) ->
2157 load_this m
2158 where
2159 findTarget mds t
2160 = case filter (`matches` t) mds of
2161 [] -> Nothing
2162 (m:_) -> Just m
2163
2164 summary `matches` Target { targetId = TargetModule m }
2165 = GHC.ms_mod_name summary == m
2166 summary `matches` Target { targetId = TargetFile f _ }
2167 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
2168 _ `matches` _
2169 = False
2170
2171 load_this summary | m <- GHC.ms_mod summary = do
2172 is_interp <- GHC.moduleIsInterpreted m
2173 dflags <- getDynFlags
2174 let star_ok = is_interp && not (safeLanguageOn dflags)
2175 -- We import the module with a * iff
2176 -- - it is interpreted, and
2177 -- - -XSafe is off (it doesn't allow *-imports)
2178 let new_ctx | star_ok = [mkIIModule (GHC.moduleName m)]
2179 | otherwise = [mkIIDecl (GHC.moduleName m)]
2180 setContextKeepingPackageModules keep_ctxt new_ctx
2181
2182
2183 -- | Keep any package modules (except Prelude) when changing the context.
2184 setContextKeepingPackageModules
2185 :: GhciMonad m
2186 => Bool -- True <=> keep all of remembered_ctx
2187 -- False <=> just keep package imports
2188 -> [InteractiveImport] -- new context
2189 -> m ()
2190 setContextKeepingPackageModules keep_ctx trans_ctx = do
2191
2192 st <- getGHCiState
2193 let rem_ctx = remembered_ctx st
2194 new_rem_ctx <- if keep_ctx then return rem_ctx
2195 else keepPackageImports rem_ctx
2196 setGHCiState st{ remembered_ctx = new_rem_ctx,
2197 transient_ctx = filterSubsumed new_rem_ctx trans_ctx }
2198 setGHCContextFromGHCiState
2199
2200 -- | Filters a list of 'InteractiveImport', clearing out any home package
2201 -- imports so only imports from external packages are preserved. ('IIModule'
2202 -- counts as a home package import, because we are only able to bring a
2203 -- full top-level into scope when the source is available.)
2204 keepPackageImports
2205 :: GHC.GhcMonad m => [InteractiveImport] -> m [InteractiveImport]
2206 keepPackageImports = filterM is_pkg_import
2207 where
2208 is_pkg_import :: GHC.GhcMonad m => InteractiveImport -> m Bool
2209 is_pkg_import (IIModule _) = return False
2210 is_pkg_import (IIDecl d)
2211 = do pkgqual <- GHC.renameRawPkgQualM (ideclPkgQual d)
2212 e <- MC.try $ GHC.findQualifiedModule pkgqual mod_name
2213 case e :: Either SomeException Module of
2214 Left _ -> return False
2215 Right m -> return (not (isMainUnitModule m))
2216 where
2217 mod_name = unLoc (ideclName d)
2218
2219
2220
2221 modulesLoadedMsg :: GHC.GhcMonad m => SuccessFlag -> [GHC.ModSummary] -> m ()
2222 modulesLoadedMsg ok mods = do
2223 dflags <- getDynFlags
2224 unit_state <- hsc_units <$> GHC.getSession
2225 unqual <- GHC.getPrintUnqual
2226
2227 msg <- if gopt Opt_ShowLoadedModules dflags
2228 then do
2229 mod_names <- mapM mod_name mods
2230 let mod_commas
2231 | null mods = text "none."
2232 | otherwise = hsep (punctuate comma mod_names) <> text "."
2233 return $ status <> text ", modules loaded:" <+> mod_commas
2234 else do
2235 return $ status <> text ","
2236 <+> speakNOf (length mods) (text "module") <+> "loaded."
2237
2238 when (verbosity dflags > 0) $
2239 liftIO $ putStrLn $ showSDocForUser dflags unit_state unqual msg
2240 where
2241 status = case ok of
2242 Failed -> text "Failed"
2243 Succeeded -> text "Ok"
2244
2245 mod_name mod = do
2246 is_interpreted <- GHC.moduleIsBootOrNotObjectLinkable mod
2247 return $ if is_interpreted
2248 then ppr (GHC.ms_mod mod)
2249 else ppr (GHC.ms_mod mod)
2250 <+> parens (text $ normalise $ msObjFilePath mod)
2251 -- Fix #9887
2252
2253 -- | Run an 'ExceptT' wrapped 'GhcMonad' while handling source errors
2254 -- and printing 'throwE' strings to 'stderr'
2255 runExceptGhcMonad :: GHC.GhcMonad m => ExceptT SDoc m () -> m ()
2256 runExceptGhcMonad act = handleSourceError GHC.printException $
2257 either handleErr pure =<<
2258 runExceptT act
2259 where
2260 handleErr sdoc = do
2261 dflags <- getDynFlags
2262 unit_state <- hsc_units <$> GHC.getSession
2263 liftIO . hPutStrLn stderr . showSDocForUser dflags unit_state alwaysQualify $ sdoc
2264
2265 -- | Inverse of 'runExceptT' for \"pure\" computations
2266 -- (c.f. 'except' for 'Except')
2267 exceptT :: Applicative m => Either e a -> ExceptT e m a
2268 exceptT = ExceptT . pure
2269
2270 -----------------------------------------------------------------------------
2271 -- | @:type@ command. See also Note [TcRnExprMode] in GHC.Tc.Module.
2272
2273 typeOfExpr :: GHC.GhcMonad m => String -> m ()
2274 typeOfExpr str = handleSourceError GHC.printException $
2275 case break isSpace str of
2276 ("+v", _) -> printForUser (text "`:type +v' has gone; use `:type' instead")
2277 ("+d", rest) -> do_it GHC.TM_Default (dropWhile isSpace rest)
2278 _ -> do_it GHC.TM_Inst str
2279 where
2280 do_it mode expr_str
2281 = do { ty <- GHC.exprType mode expr_str
2282 ; printForUser $ sep [ text expr_str
2283 , nest 2 (dcolon <+> pprSigmaType ty)] }
2284
2285 -----------------------------------------------------------------------------
2286 -- | @:type-at@ command
2287
2288 typeAtCmd :: GhciMonad m => String -> m ()
2289 typeAtCmd str = runExceptGhcMonad $ do
2290 (span',sample) <- exceptT $ parseSpanArg str
2291 infos <- lift $ mod_infos <$> getGHCiState
2292 (info, ty) <- findType infos span' sample
2293 lift $ printForUserModInfo (modinfoInfo info)
2294 (sep [text sample,nest 2 (dcolon <+> ppr ty)])
2295
2296 -----------------------------------------------------------------------------
2297 -- | @:uses@ command
2298
2299 usesCmd :: GhciMonad m => String -> m ()
2300 usesCmd str = runExceptGhcMonad $ do
2301 (span',sample) <- exceptT $ parseSpanArg str
2302 infos <- lift $ mod_infos <$> getGHCiState
2303 uses <- findNameUses infos span' sample
2304 forM_ uses (liftIO . putStrLn . showSrcSpan)
2305
2306 -----------------------------------------------------------------------------
2307 -- | @:loc-at@ command
2308
2309 locAtCmd :: GhciMonad m => String -> m ()
2310 locAtCmd str = runExceptGhcMonad $ do
2311 (span',sample) <- exceptT $ parseSpanArg str
2312 infos <- lift $ mod_infos <$> getGHCiState
2313 (_,_,sp) <- findLoc infos span' sample
2314 liftIO . putStrLn . showSrcSpan $ sp
2315
2316 -----------------------------------------------------------------------------
2317 -- | @:all-types@ command
2318
2319 allTypesCmd :: GhciMonad m => String -> m ()
2320 allTypesCmd _ = runExceptGhcMonad $ do
2321 infos <- lift $ mod_infos <$> getGHCiState
2322 forM_ (M.elems infos) $ \mi ->
2323 forM_ (modinfoSpans mi) (lift . printSpan)
2324 where
2325 printSpan span'
2326 | Just ty <- spaninfoType span' = do
2327 hsc_env <- GHC.getSession
2328 let tyInfo = unwords . words $
2329 showSDocForUser (hsc_dflags hsc_env)
2330 (hsc_units hsc_env)
2331 alwaysQualify (pprSigmaType ty)
2332 liftIO . putStrLn $
2333 showRealSrcSpan (spaninfoSrcSpan span') ++ ": " ++ tyInfo
2334 | otherwise = return ()
2335
2336 -----------------------------------------------------------------------------
2337 -- Helpers for locAtCmd/typeAtCmd/usesCmd
2338
2339 -- | Parse a span: <module-name/filepath> <sl> <sc> <el> <ec> <string>
2340 parseSpanArg :: String -> Either SDoc (RealSrcSpan,String)
2341 parseSpanArg s = do
2342 (fp,s0) <- readAsString (skipWs s)
2343 s0' <- skipWs1 s0
2344 (sl,s1) <- readAsInt s0'
2345 s1' <- skipWs1 s1
2346 (sc,s2) <- readAsInt s1'
2347 s2' <- skipWs1 s2
2348 (el,s3) <- readAsInt s2'
2349 s3' <- skipWs1 s3
2350 (ec,s4) <- readAsInt s3'
2351
2352 trailer <- case s4 of
2353 [] -> Right ""
2354 _ -> skipWs1 s4
2355
2356 let fs = mkFastString fp
2357 span' = mkRealSrcSpan (mkRealSrcLoc fs sl sc)
2358 -- End column of RealSrcSpan is the column
2359 -- after the end of the span.
2360 (mkRealSrcLoc fs el (ec + 1))
2361
2362 return (span',trailer)
2363 where
2364 readAsInt :: String -> Either SDoc (Int,String)
2365 readAsInt "" = Left "Premature end of string while expecting Int"
2366 readAsInt s0 = case reads s0 of
2367 [s_rest] -> Right s_rest
2368 _ -> Left ("Couldn't read" <+> text (show s0) <+> "as Int")
2369
2370 readAsString :: String -> Either SDoc (String,String)
2371 readAsString s0
2372 | '"':_ <- s0 = case reads s0 of
2373 [s_rest] -> Right s_rest
2374 _ -> leftRes
2375 | s_rest@(_:_,_) <- breakWs s0 = Right s_rest
2376 | otherwise = leftRes
2377 where
2378 leftRes = Left ("Couldn't read" <+> text (show s0) <+> "as String")
2379
2380 skipWs1 :: String -> Either SDoc String
2381 skipWs1 (c:cs) | isWs c = Right (skipWs cs)
2382 skipWs1 s0 = Left ("Expected whitespace in" <+> text (show s0))
2383
2384 isWs = (`elem` [' ','\t'])
2385 skipWs = dropWhile isWs
2386 breakWs = break isWs
2387
2388
2389 -- | Pretty-print \"real\" 'SrcSpan's as
2390 -- @<filename>:(<line>,<col>)-(<line-end>,<col-end>)@
2391 -- while simply unpacking 'UnhelpfulSpan's
2392 showSrcSpan :: SrcSpan -> String
2393 showSrcSpan (UnhelpfulSpan s) = unpackFS (unhelpfulSpanFS s)
2394 showSrcSpan (RealSrcSpan spn _) = showRealSrcSpan spn
2395
2396 -- | Variant of 'showSrcSpan' for 'RealSrcSpan's
2397 showRealSrcSpan :: RealSrcSpan -> String
2398 showRealSrcSpan spn = concat [ fp, ":(", show sl, ",", show sc
2399 , ")-(", show el, ",", show ec, ")"
2400 ]
2401 where
2402 fp = unpackFS (srcSpanFile spn)
2403 sl = srcSpanStartLine spn
2404 sc = srcSpanStartCol spn
2405 el = srcSpanEndLine spn
2406 -- The end column is the column after the end of the span see the
2407 -- RealSrcSpan module
2408 ec = let ec' = srcSpanEndCol spn in if ec' == 0 then 0 else ec' - 1
2409
2410 -----------------------------------------------------------------------------
2411 -- | @:kind@ command
2412
2413 kindOfType :: GHC.GhcMonad m => Bool -> String -> m ()
2414 kindOfType norm str = handleSourceError GHC.printException $ do
2415 (ty, kind) <- GHC.typeKind norm str
2416 printForUser $ vcat [ text str <+> dcolon <+> pprSigmaType kind
2417 , ppWhen norm $ equals <+> pprSigmaType ty ]
2418
2419 -----------------------------------------------------------------------------
2420 -- :quit
2421
2422 quit :: Monad m => String -> m Bool
2423 quit _ = return True
2424
2425
2426 -----------------------------------------------------------------------------
2427 -- :script
2428
2429 -- running a script file #1363
2430
2431 scriptCmd :: String -> InputT GHCi ()
2432 scriptCmd ws = do
2433 case words' ws of
2434 [s] -> runScript s
2435 _ -> throwGhcException (CmdLineError "syntax: :script <filename>")
2436
2437 -- | A version of 'words' that treats sequences enclosed in double quotes as
2438 -- single words and that does not break on backslash-escaped spaces.
2439 -- E.g., 'words\' "\"lorem ipsum\" dolor"' and 'words\' "lorem\\ ipsum dolor"'
2440 -- yield '["lorem ipsum", "dolor"]'.
2441 -- Used to scan for file paths in 'scriptCmd'.
2442 words' :: String -> [String]
2443 words' s = case dropWhile isSpace s of
2444 "" -> []
2445 s'@('\"' : _) | [(w, s'')] <- reads s' -> w : words' s''
2446 s' -> go id s'
2447 where
2448 go acc [] = [acc []]
2449 go acc ('\\' : c : cs) | isSpace c = go (acc . (c :)) cs
2450 go acc (c : cs) | isSpace c = acc [] : words' cs
2451 | otherwise = go (acc . (c :)) cs
2452
2453 runScript :: String -- ^ filename
2454 -> InputT GHCi ()
2455 runScript filename = do
2456 filename' <- expandPath filename
2457 either_script <- liftIO $ tryIO (openFile filename' ReadMode)
2458 case either_script of
2459 Left _err -> throwGhcException (CmdLineError $ "IO error: \""++filename++"\" "
2460 ++(ioeGetErrorString _err))
2461 Right script -> do
2462 st <- getGHCiState
2463 let prog = progname st
2464 line = line_number st
2465 setGHCiState st{progname=filename',line_number=0}
2466 scriptLoop script
2467 liftIO $ hClose script
2468 new_st <- getGHCiState
2469 setGHCiState new_st{progname=prog,line_number=line}
2470 where scriptLoop script = do
2471 res <- runOneCommand handler $ fileLoop script
2472 case res of
2473 Nothing -> return ()
2474 Just s -> if s
2475 then scriptLoop script
2476 else return ()
2477
2478 -----------------------------------------------------------------------------
2479 -- :issafe
2480
2481 -- Displaying Safe Haskell properties of a module
2482
2483 isSafeCmd :: GHC.GhcMonad m => String -> m ()
2484 isSafeCmd m =
2485 case words m of
2486 [s] | looksLikeModuleName s -> do
2487 md <- lookupModule s
2488 isSafeModule md
2489 [] -> do md <- guessCurrentModule "issafe"
2490 isSafeModule md
2491 _ -> throwGhcException (CmdLineError "syntax: :issafe <module>")
2492
2493 isSafeModule :: GHC.GhcMonad m => Module -> m ()
2494 isSafeModule m = do
2495 mb_mod_info <- GHC.getModuleInfo m
2496 when (isNothing mb_mod_info)
2497 (throwGhcException $ CmdLineError $ "unknown module: " ++ mname)
2498
2499 dflags <- getDynFlags
2500 hsc_env <- GHC.getSession
2501 let iface = GHC.modInfoIface $ fromJust mb_mod_info
2502 when (isNothing iface)
2503 (throwGhcException $ CmdLineError $ "can't load interface file for module: " ++
2504 (GHC.moduleNameString $ GHC.moduleName m))
2505
2506 (msafe, pkgs) <- GHC.moduleTrustReqs m
2507 let trust = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface
2508 pkg = if packageTrusted hsc_env m then "trusted" else "untrusted"
2509 (good, bad) = tallyPkgs hsc_env pkgs
2510
2511 -- print info to user...
2512 liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")"
2513 liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off")
2514 when (not $ S.null good)
2515 (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++
2516 (intercalate ", " $ map (showPpr dflags) (S.toList good)))
2517 case msafe && S.null bad of
2518 True -> liftIO $ putStrLn $ mname ++ " is trusted!"
2519 False -> do
2520 when (not $ null bad)
2521 (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "
2522 ++ (intercalate ", " $ map (showPpr dflags) (S.toList bad)))
2523 liftIO $ putStrLn $ mname ++ " is NOT trusted!"
2524
2525 where
2526 mname = GHC.moduleNameString $ GHC.moduleName m
2527
2528 packageTrusted hsc_env md
2529 | isHomeModule (hsc_home_unit hsc_env) md = True
2530 | otherwise = unitIsTrusted $ unsafeLookupUnit (hsc_units hsc_env) (moduleUnit md)
2531
2532 tallyPkgs hsc_env deps | not (packageTrustOn dflags) = (S.empty, S.empty)
2533 | otherwise = S.partition part deps
2534 where part pkg = unitIsTrusted $ unsafeLookupUnitId unit_state pkg
2535 unit_state = hsc_units hsc_env
2536 dflags = hsc_dflags hsc_env
2537
2538 -----------------------------------------------------------------------------
2539 -- :browse
2540
2541 -- Browsing a module's contents
2542
2543 browseCmd :: GHC.GhcMonad m => Bool -> String -> m ()
2544 browseCmd bang m =
2545 case words m of
2546 ['*':s] | looksLikeModuleName s -> do
2547 md <- wantInterpretedModule s
2548 browseModule bang md False
2549 [s] | looksLikeModuleName s -> do
2550 md <- lookupModule s
2551 browseModule bang md True
2552 [] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "")
2553 browseModule bang md True
2554 _ -> throwGhcException (CmdLineError "syntax: :browse <module>")
2555
2556 guessCurrentModule :: GHC.GhcMonad m => String -> m Module
2557 -- Guess which module the user wants to browse. Pick
2558 -- modules that are interpreted first. The most
2559 -- recently-added module occurs last, it seems.
2560 guessCurrentModule cmd
2561 = do imports <- GHC.getContext
2562 when (null imports) $ throwGhcException $
2563 CmdLineError (':' : cmd ++ ": no current module")
2564 case (head imports) of
2565 IIModule m -> GHC.findQualifiedModule NoPkgQual m
2566 IIDecl d -> do
2567 pkgqual <- GHC.renameRawPkgQualM (ideclPkgQual d)
2568 GHC.findQualifiedModule pkgqual (unLoc (ideclName d))
2569
2570 -- without bang, show items in context of their parents and omit children
2571 -- with bang, show class methods and data constructors separately, and
2572 -- indicate import modules, to aid qualifying unqualified names
2573 -- with sorted, sort items alphabetically
2574 browseModule :: GHC.GhcMonad m => Bool -> Module -> Bool -> m ()
2575 browseModule bang modl exports_only = do
2576 -- :browse reports qualifiers wrt current context
2577 unqual <- GHC.getPrintUnqual
2578
2579 mb_mod_info <- GHC.getModuleInfo modl
2580 case mb_mod_info of
2581 Nothing -> throwGhcException (CmdLineError ("unknown module: " ++
2582 GHC.moduleNameString (GHC.moduleName modl)))
2583 Just mod_info -> do
2584 dflags <- getDynFlags
2585 let names
2586 | exports_only = GHC.modInfoExports mod_info
2587 | otherwise = GHC.modInfoTopLevelScope mod_info
2588 `orElse` []
2589
2590 -- sort alphabetically name, but putting locally-defined
2591 -- identifiers first. We would like to improve this; see #1799.
2592 sorted_names = loc_sort local ++ occ_sort external
2593 where
2594 (local,external) = assert (all isExternalName names) $
2595 partition ((==modl) . nameModule) names
2596 occ_sort = sortBy (compare `on` nameOccName)
2597 -- try to sort by src location. If the first name in our list
2598 -- has a good source location, then they all should.
2599 loc_sort ns
2600 | n:_ <- ns, isGoodSrcSpan (nameSrcSpan n)
2601 = sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) ns
2602 | otherwise
2603 = occ_sort ns
2604
2605 mb_things <- mapM GHC.lookupName sorted_names
2606 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
2607
2608 rdr_env <- GHC.getGRE
2609
2610 let things | bang = catMaybes mb_things
2611 | otherwise = filtered_things
2612 pretty | bang = pprTyThing showToHeader
2613 | otherwise = pprTyThingInContext showToHeader
2614
2615 labels [] = text "-- not currently imported"
2616 labels l = text $ intercalate "\n" $ map qualifier l
2617
2618 qualifier :: Maybe [ModuleName] -> String
2619 qualifier = maybe "-- defined locally"
2620 (("-- imported via "++) . intercalate ", "
2621 . map GHC.moduleNameString)
2622 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
2623
2624 modNames :: [[Maybe [ModuleName]]]
2625 modNames = map (importInfo . GHC.getName) things
2626
2627 -- annotate groups of imports with their import modules
2628 -- the default ordering is somewhat arbitrary, so we group
2629 -- by header and sort groups; the names themselves should
2630 -- really come in order of source appearance.. (trac #1799)
2631 annotate mts = concatMap (\(m,ts)->labels m:ts)
2632 $ sortBy cmpQualifiers $ grp mts
2633 where cmpQualifiers =
2634 compare `on` (map (fmap (map (unpackFS . moduleNameFS))) . fst)
2635 grp [] = []
2636 grp mts@((m,_):_) = (m,map snd g) : grp ng
2637 where (g,ng) = partition ((==m).fst) mts
2638
2639 let prettyThings, prettyThings' :: [SDoc]
2640 prettyThings = map pretty things
2641 prettyThings' | bang = annotate $ zip modNames prettyThings
2642 | otherwise = prettyThings
2643 unit_state <- hsc_units <$> GHC.getSession
2644 liftIO $ putStrLn $ showSDocForUser dflags unit_state unqual (vcat prettyThings')
2645 -- ToDo: modInfoInstances currently throws an exception for
2646 -- package modules. When it works, we can do this:
2647 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
2648
2649
2650 -----------------------------------------------------------------------------
2651 -- :module
2652
2653 -- Setting the module context. For details on context handling see
2654 -- "remembered_ctx" and "transient_ctx" in GhciMonad.
2655
2656 moduleCmd :: GhciMonad m => String -> m ()
2657 moduleCmd str
2658 | all sensible strs = cmd
2659 | otherwise = throwGhcException (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
2660 where
2661 (cmd, strs) =
2662 case str of
2663 '+':stuff -> rest addModulesToContext stuff
2664 '-':stuff -> rest remModulesFromContext stuff
2665 stuff -> rest setContext stuff
2666
2667 rest op stuff = (op as bs, stuffs)
2668 where (as,bs) = partitionWith starred stuffs
2669 stuffs = words stuff
2670
2671 sensible ('*':m) = looksLikeModuleName m
2672 sensible m = looksLikeModuleName m
2673
2674 starred ('*':m) = Left (GHC.mkModuleName m)
2675 starred m = Right (GHC.mkModuleName m)
2676
2677
2678 -- -----------------------------------------------------------------------------
2679 -- Four ways to manipulate the context:
2680 -- (a) :module +<stuff>: addModulesToContext
2681 -- (b) :module -<stuff>: remModulesFromContext
2682 -- (c) :module <stuff>: setContext
2683 -- (d) import <module>...: addImportToContext
2684
2685 addModulesToContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()
2686 addModulesToContext starred unstarred = restoreContextOnFailure $ do
2687 addModulesToContext_ starred unstarred
2688
2689 addModulesToContext_ :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()
2690 addModulesToContext_ starred unstarred = do
2691 mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)
2692 setGHCContextFromGHCiState
2693
2694 remModulesFromContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()
2695 remModulesFromContext starred unstarred = do
2696 -- we do *not* call restoreContextOnFailure here. If the user
2697 -- is trying to fix up a context that contains errors by removing
2698 -- modules, we don't want GHC to silently put them back in again.
2699 mapM_ rm (starred ++ unstarred)
2700 setGHCContextFromGHCiState
2701 where
2702 rm :: GhciMonad m => ModuleName -> m ()
2703 rm str = do
2704 m <- moduleName <$> lookupModuleName str
2705 let filt = filter ((/=) m . iiModuleName)
2706 modifyGHCiState $ \st ->
2707 st { remembered_ctx = filt (remembered_ctx st)
2708 , transient_ctx = filt (transient_ctx st) }
2709
2710 setContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()
2711 setContext starred unstarred = restoreContextOnFailure $ do
2712 modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] }
2713 -- delete the transient context
2714 addModulesToContext_ starred unstarred
2715
2716 addImportToContext :: GhciMonad m => String -> m ()
2717 addImportToContext str = restoreContextOnFailure $ do
2718 idecl <- GHC.parseImportDecl str
2719 addII (IIDecl idecl) -- #5836
2720 setGHCContextFromGHCiState
2721
2722 -- Util used by addImportToContext and addModulesToContext
2723 addII :: GhciMonad m => InteractiveImport -> m ()
2724 addII iidecl = do
2725 checkAdd iidecl
2726 modifyGHCiState $ \st ->
2727 st { remembered_ctx = addNotSubsumed iidecl (remembered_ctx st)
2728 , transient_ctx = filter (not . (iidecl `iiSubsumes`))
2729 (transient_ctx st)
2730 }
2731
2732 -- Sometimes we can't tell whether an import is valid or not until
2733 -- we finally call 'GHC.setContext'. e.g.
2734 --
2735 -- import System.IO (foo)
2736 --
2737 -- will fail because System.IO does not export foo. In this case we
2738 -- don't want to store the import in the context permanently, so we
2739 -- catch the failure from 'setGHCContextFromGHCiState' and set the
2740 -- context back to what it was.
2741 --
2742 -- See #6007
2743 --
2744 restoreContextOnFailure :: GhciMonad m => m a -> m a
2745 restoreContextOnFailure do_this = do
2746 st <- getGHCiState
2747 let rc = remembered_ctx st; tc = transient_ctx st
2748 do_this `MC.onException` (modifyGHCiState $ \st' ->
2749 st' { remembered_ctx = rc, transient_ctx = tc })
2750
2751 -- -----------------------------------------------------------------------------
2752 -- Validate a module that we want to add to the context
2753
2754 checkAdd :: GHC.GhcMonad m => InteractiveImport -> m ()
2755 checkAdd ii = do
2756 dflags <- getDynFlags
2757 let safe = safeLanguageOn dflags
2758 case ii of
2759 IIModule modname
2760 | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell"
2761 | otherwise -> wantInterpretedModuleName modname >> return ()
2762
2763 IIDecl d -> do
2764 let modname = unLoc (ideclName d)
2765 pkgqual <- GHC.renameRawPkgQualM (ideclPkgQual d)
2766 m <- GHC.lookupQualifiedModule pkgqual modname
2767 when safe $ do
2768 t <- GHC.isModuleTrusted m
2769 when (not t) $ throwGhcException $ ProgramError $ ""
2770
2771 -- -----------------------------------------------------------------------------
2772 -- Update the GHC API's view of the context
2773
2774 -- | Sets the GHC context from the GHCi state. The GHC context is
2775 -- always set this way, we never modify it incrementally.
2776 --
2777 -- We ignore any imports for which the ModuleName does not currently
2778 -- exist. This is so that the remembered_ctx can contain imports for
2779 -- modules that are not currently loaded, perhaps because we just did
2780 -- a :reload and encountered errors.
2781 --
2782 -- Prelude is added if not already present in the list. Therefore to
2783 -- override the implicit Prelude import you can say 'import Prelude ()'
2784 -- at the prompt, just as in Haskell source.
2785 --
2786 setGHCContextFromGHCiState :: GhciMonad m => m ()
2787 setGHCContextFromGHCiState = do
2788 st <- getGHCiState
2789 -- re-use checkAdd to check whether the module is valid. If the
2790 -- module does not exist, we do *not* want to print an error
2791 -- here, we just want to silently keep the module in the context
2792 -- until such time as the module reappears again. So we ignore
2793 -- the actual exception thrown by checkAdd, using tryBool to
2794 -- turn it into a Bool.
2795 iidecls <- filterM (tryBool.checkAdd) (transient_ctx st ++ remembered_ctx st)
2796
2797 prel_iidecls <- getImplicitPreludeImports iidecls
2798 valid_prel_iidecls <- filterM (tryBool . checkAdd) prel_iidecls
2799
2800 extra_imports <- filterM (tryBool . checkAdd) (map IIDecl (extra_imports st))
2801
2802 GHC.setContext $ iidecls ++ extra_imports ++ valid_prel_iidecls
2803
2804
2805 getImplicitPreludeImports :: GhciMonad m
2806 => [InteractiveImport] -> m [InteractiveImport]
2807 getImplicitPreludeImports iidecls = do
2808 dflags <- GHC.getInteractiveDynFlags
2809 -- allow :seti to override -XNoImplicitPrelude
2810 st <- getGHCiState
2811
2812 -- We add the prelude imports if there are no *-imports, and we also
2813 -- allow each prelude import to be subsumed by another explicit import
2814 -- of the same module. This means that you can override the prelude import
2815 -- with "import Prelude hiding (map)", for example.
2816 let prel_iidecls =
2817 if xopt LangExt.ImplicitPrelude dflags && not (any isIIModule iidecls)
2818 then [ IIDecl imp
2819 | imp <- prelude_imports st
2820 , not (any (sameImpModule imp) iidecls) ]
2821 else []
2822
2823 return prel_iidecls
2824
2825 -- -----------------------------------------------------------------------------
2826 -- Utils on InteractiveImport
2827
2828 mkIIModule :: ModuleName -> InteractiveImport
2829 mkIIModule = IIModule
2830
2831 mkIIDecl :: ModuleName -> InteractiveImport
2832 mkIIDecl = IIDecl . simpleImportDecl
2833
2834 iiModules :: [InteractiveImport] -> [ModuleName]
2835 iiModules is = [m | IIModule m <- is]
2836
2837 isIIModule :: InteractiveImport -> Bool
2838 isIIModule (IIModule _) = True
2839 isIIModule _ = False
2840
2841 iiModuleName :: InteractiveImport -> ModuleName
2842 iiModuleName (IIModule m) = m
2843 iiModuleName (IIDecl d) = unLoc (ideclName d)
2844
2845 preludeModuleName :: ModuleName
2846 preludeModuleName = GHC.mkModuleName "Prelude"
2847
2848 sameImpModule :: ImportDecl GhcPs -> InteractiveImport -> Bool
2849 sameImpModule _ (IIModule _) = False -- we only care about imports here
2850 sameImpModule imp (IIDecl d) = unLoc (ideclName d) == unLoc (ideclName imp)
2851
2852 addNotSubsumed :: InteractiveImport
2853 -> [InteractiveImport] -> [InteractiveImport]
2854 addNotSubsumed i is
2855 | any (`iiSubsumes` i) is = is
2856 | otherwise = i : filter (not . (i `iiSubsumes`)) is
2857
2858 -- | @filterSubsumed is js@ returns the elements of @js@ not subsumed
2859 -- by any of @is@.
2860 filterSubsumed :: [InteractiveImport] -> [InteractiveImport]
2861 -> [InteractiveImport]
2862 filterSubsumed is js = filter (\j -> not (any (`iiSubsumes` j) is)) js
2863
2864 -- | Returns True if the left import subsumes the right one. Doesn't
2865 -- need to be 100% accurate, conservatively returning False is fine.
2866 -- (EXCEPT: (IIModule m) *must* subsume itself, otherwise a panic in
2867 -- plusProv will ensue (#5904))
2868 --
2869 -- Note that an IIModule does not necessarily subsume an IIDecl,
2870 -- because e.g. a module might export a name that is only available
2871 -- qualified within the module itself.
2872 --
2873 -- Note that 'import M' does not necessarily subsume 'import M(foo)',
2874 -- because M might not export foo and we want an error to be produced
2875 -- in that case.
2876 --
2877 iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool
2878 iiSubsumes (IIModule m1) (IIModule m2) = m1==m2
2879 iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude
2880 = unLoc (ideclName d1) == unLoc (ideclName d2)
2881 && ideclAs d1 == ideclAs d2
2882 && (not (isImportDeclQualified (ideclQualified d1)) || isImportDeclQualified (ideclQualified d2))
2883 && (ideclHiding d1 `hidingSubsumes` ideclHiding d2)
2884 where
2885 _ `hidingSubsumes` Just (False,L _ []) = True
2886 Just (False, L _ xs) `hidingSubsumes` Just (False,L _ ys)
2887 = all (`elem` xs) ys
2888 h1 `hidingSubsumes` h2 = h1 == h2
2889 iiSubsumes _ _ = False
2890
2891
2892 ----------------------------------------------------------------------------
2893 -- :set
2894
2895 -- set options in the interpreter. Syntax is exactly the same as the
2896 -- ghc command line, except that certain options aren't available (-C,
2897 -- -E etc.)
2898 --
2899 -- This is pretty fragile: most options won't work as expected. ToDo:
2900 -- figure out which ones & disallow them.
2901
2902 setCmd :: GhciMonad m => String -> m ()
2903 setCmd "" = showOptions False
2904 setCmd "-a" = showOptions True
2905 setCmd str
2906 = case getCmd str of
2907 Right ("args", rest) ->
2908 case toArgsNoLoc rest of
2909 Left err -> liftIO (hPutStrLn stderr err)
2910 Right args -> setArgs args
2911 Right ("prog", rest) ->
2912 case toArgsNoLoc rest of
2913 Right [prog] -> setProg prog
2914 _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")
2915
2916 Right ("prompt", rest) ->
2917 setPromptString setPrompt (dropWhile isSpace rest)
2918 "syntax: set prompt <string>"
2919 Right ("prompt-function", rest) ->
2920 setPromptFunc setPrompt $ dropWhile isSpace rest
2921 Right ("prompt-cont", rest) ->
2922 setPromptString setPromptCont (dropWhile isSpace rest)
2923 "syntax: :set prompt-cont <string>"
2924 Right ("prompt-cont-function", rest) ->
2925 setPromptFunc setPromptCont $ dropWhile isSpace rest
2926
2927 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
2928 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
2929 Right ("local-config", rest) ->
2930 setLocalConfigBehaviour $ dropWhile isSpace rest
2931 _ -> case toArgsNoLoc str of
2932 Left err -> liftIO (hPutStrLn stderr err)
2933 Right wds -> setOptions wds
2934
2935 setiCmd :: GhciMonad m => String -> m ()
2936 setiCmd "" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False
2937 setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True
2938 setiCmd str =
2939 case toArgsNoLoc str of
2940 Left err -> liftIO (hPutStrLn stderr err)
2941 Right wds -> newDynFlags True wds
2942
2943 showOptions :: GhciMonad m => Bool -> m ()
2944 showOptions show_all
2945 = do st <- getGHCiState
2946 dflags <- getDynFlags
2947 let opts = options st
2948 liftIO $ putStrLn (showSDoc dflags (
2949 text "options currently set: " <>
2950 if null opts
2951 then text "none."
2952 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
2953 ))
2954 getDynFlags >>= liftIO . showDynFlags show_all
2955
2956
2957 showDynFlags :: Bool -> DynFlags -> IO ()
2958 showDynFlags show_all dflags = do
2959 showLanguages' show_all dflags
2960 putStrLn $ showSDoc dflags $
2961 text "GHCi-specific dynamic flag settings:" $$
2962 nest 2 (vcat (map (setting "-f" "-fno-" gopt) ghciFlags))
2963 putStrLn $ showSDoc dflags $
2964 text "other dynamic, non-language, flag settings:" $$
2965 nest 2 (vcat (map (setting "-f" "-fno-" gopt) others))
2966 putStrLn $ showSDoc dflags $
2967 text "warning settings:" $$
2968 nest 2 (vcat (map (setting "-W" "-Wno-" wopt) DynFlags.wWarningFlags))
2969 where
2970 setting :: String -> String -> (flag -> DynFlags -> Bool) -> FlagSpec flag -> SDoc
2971 setting prefix noPrefix test flag
2972 | quiet = empty
2973 | is_on = text prefix <> text name
2974 | otherwise = text noPrefix <> text name
2975 where name = flagSpecName flag
2976 f = flagSpecFlag flag
2977 is_on = test f dflags
2978 quiet = not show_all && test f default_dflags == is_on
2979
2980 default_dflags = defaultDynFlags (settings dflags) (llvmConfig dflags)
2981
2982 (ghciFlags,others) = partition (\f -> flagSpecFlag f `elem` flgs)
2983 DynFlags.fFlags
2984 flgs = [ Opt_PrintExplicitForalls
2985 , Opt_PrintExplicitKinds
2986 , Opt_PrintUnicodeSyntax
2987 , Opt_PrintBindResult
2988 , Opt_BreakOnException
2989 , Opt_BreakOnError
2990 , Opt_PrintEvldWithShow
2991 ]
2992
2993 setArgs, setOptions :: GhciMonad m => [String] -> m ()
2994 setProg, setEditor, setStop :: GhciMonad m => String -> m ()
2995 setLocalConfigBehaviour :: GhciMonad m => String -> m ()
2996
2997 setArgs args = do
2998 st <- getGHCiState
2999 wrapper <- mkEvalWrapper (progname st) args
3000 setGHCiState st { GhciMonad.args = args, evalWrapper = wrapper }
3001
3002 setProg prog = do
3003 st <- getGHCiState
3004 wrapper <- mkEvalWrapper prog (GhciMonad.args st)
3005 setGHCiState st { progname = prog, evalWrapper = wrapper }
3006
3007 setEditor cmd = modifyGHCiState (\st -> st { editor = cmd })
3008
3009 setLocalConfigBehaviour s
3010 | s == "source" =
3011 modifyGHCiState (\st -> st { localConfig = SourceLocalConfig })
3012 | s == "ignore" =
3013 modifyGHCiState (\st -> st { localConfig = IgnoreLocalConfig })
3014 | otherwise = throwGhcException
3015 (CmdLineError "syntax: :set local-config { source | ignore }")
3016
3017 setStop str@(c:_) | isDigit c
3018 = do let (nm_str,rest) = break (not.isDigit) str
3019 nm = read nm_str
3020 st <- getGHCiState
3021 let old_breaks = breaks st
3022 case IntMap.lookup nm old_breaks of
3023 Nothing -> printForUser (text "Breakpoint" <+> ppr nm <+>
3024 text "does not exist")
3025 Just loc -> do
3026 let new_breaks = IntMap.insert nm
3027 loc { onBreakCmd = dropWhile isSpace rest }
3028 old_breaks
3029 setGHCiState st{ breaks = new_breaks }
3030 setStop cmd = modifyGHCiState (\st -> st { stop = cmd })
3031
3032 setPrompt :: GhciMonad m => PromptFunction -> m ()
3033 setPrompt v = modifyGHCiState (\st -> st {prompt = v})
3034
3035 setPromptCont :: GhciMonad m => PromptFunction -> m ()
3036 setPromptCont v = modifyGHCiState (\st -> st {prompt_cont = v})
3037
3038 setPromptFunc :: GHC.GhcMonad m => (PromptFunction -> m ()) -> String -> m ()
3039 setPromptFunc fSetPrompt s = do
3040 -- We explicitly annotate the type of the expression to ensure
3041 -- that unsafeCoerce# is passed the exact type necessary rather
3042 -- than a more general one
3043 let exprStr = "(" ++ s ++ ") :: [String] -> Int -> IO String"
3044 (HValue funValue) <- GHC.compileExpr exprStr
3045 fSetPrompt (convertToPromptFunction $ unsafeCoerce funValue)
3046 where
3047 convertToPromptFunction :: ([String] -> Int -> IO String)
3048 -> PromptFunction
3049 convertToPromptFunction func = (\mods line -> liftIO $
3050 liftM text (func mods line))
3051
3052 setPromptString :: MonadIO m
3053 => (PromptFunction -> m ()) -> String -> String -> m ()
3054 setPromptString fSetPrompt value err = do
3055 if null value
3056 then liftIO $ hPutStrLn stderr $ err
3057 else case value of
3058 ('\"':_) ->
3059 case reads value of
3060 [(value', xs)] | all isSpace xs ->
3061 setParsedPromptString fSetPrompt value'
3062 _ -> liftIO $ hPutStrLn stderr
3063 "Can't parse prompt string. Use Haskell syntax."
3064 _ ->
3065 setParsedPromptString fSetPrompt value
3066
3067 setParsedPromptString :: MonadIO m
3068 => (PromptFunction -> m ()) -> String -> m ()
3069 setParsedPromptString fSetPrompt s = do
3070 case (checkPromptStringForErrors s) of
3071 Just err ->
3072 liftIO $ hPutStrLn stderr err
3073 Nothing ->
3074 fSetPrompt $ generatePromptFunctionFromString s
3075
3076 setOptions wds =
3077 do -- first, deal with the GHCi opts (+s, +t, etc.)
3078 let (plus_opts, minus_opts) = partitionWith isPlus wds
3079 mapM_ setOpt plus_opts
3080 -- then, dynamic flags
3081 when (not (null minus_opts)) $ newDynFlags False minus_opts
3082
3083 -- | newDynFlags will *not* read package environment files, therefore we
3084 -- use 'parseDynamicFlagsCmdLine' rather than 'parseDynamicFlags'. This
3085 -- function is called very often and results in repeatedly loading
3086 -- environment files (see #19650)
3087 newDynFlags :: GhciMonad m => Bool -> [String] -> m ()
3088 newDynFlags interactive_only minus_opts = do
3089 let lopts = map noLoc minus_opts
3090
3091 logger <- getLogger
3092 idflags0 <- GHC.getInteractiveDynFlags
3093 (idflags1, leftovers, warns) <- DynFlags.parseDynamicFlagsCmdLine idflags0 lopts
3094
3095 liftIO $ handleFlagWarnings logger (initDiagOpts idflags1) warns
3096 when (not $ null leftovers)
3097 (throwGhcException . CmdLineError
3098 $ "Some flags have not been recognized: "
3099 ++ (concat . intersperse ", " $ map unLoc leftovers))
3100
3101 when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do
3102 liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"
3103 GHC.setInteractiveDynFlags idflags1
3104 installInteractivePrint (interactivePrint idflags1) False
3105
3106 dflags0 <- getDynFlags
3107
3108 when (not interactive_only) $ do
3109 (dflags1, _, _) <- liftIO $ DynFlags.parseDynamicFlagsCmdLine dflags0 lopts
3110 must_reload <- GHC.setProgramDynFlags dflags1
3111
3112 -- if the package flags changed, reset the context and link
3113 -- the new packages.
3114 hsc_env <- GHC.getSession
3115 let dflags2 = hsc_dflags hsc_env
3116 let interp = hscInterp hsc_env
3117 when (packageFlagsChanged dflags2 dflags0) $ do
3118 when (verbosity dflags2 > 0) $
3119 liftIO . putStrLn $
3120 "package flags have changed, resetting and loading new packages..."
3121 -- delete targets and all eventually defined breakpoints. (#1620)
3122 clearAllTargets
3123 when must_reload $ do
3124 let units = preloadUnits (hsc_units hsc_env)
3125 liftIO $ Loader.loadPackages interp hsc_env units
3126 -- package flags changed, we can't re-use any of the old context
3127 setContextAfterLoad False []
3128 -- and copy the package flags to the interactive DynFlags
3129 idflags <- GHC.getInteractiveDynFlags
3130 GHC.setInteractiveDynFlags
3131 idflags{ packageFlags = packageFlags dflags2 }
3132
3133 let ld0length = length $ ldInputs dflags0
3134 fmrk0length = length $ cmdlineFrameworks dflags0
3135
3136 newLdInputs = drop ld0length (ldInputs dflags2)
3137 newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2)
3138
3139 dflags' = dflags2 { ldInputs = newLdInputs
3140 , cmdlineFrameworks = newCLFrameworks
3141 }
3142 hsc_env' = hscSetFlags dflags' hsc_env
3143
3144 when (not (null newLdInputs && null newCLFrameworks)) $
3145 liftIO $ Loader.loadCmdLineLibs (hscInterp hsc_env') hsc_env'
3146
3147 return ()
3148
3149
3150 unsetOptions :: GhciMonad m => String -> m ()
3151 unsetOptions str
3152 = -- first, deal with the GHCi opts (+s, +t, etc.)
3153 let opts = words str
3154 (minus_opts, rest1) = partition isMinus opts
3155 (plus_opts, rest2) = partitionWith isPlus rest1
3156 (other_opts, rest3) = partition (`elem` map fst defaulters) rest2
3157
3158 defaulters =
3159 [ ("args" , setArgs default_args)
3160 , ("prog" , setProg default_progname)
3161 , ("prompt" , setPrompt default_prompt)
3162 , ("prompt-cont", setPromptCont default_prompt_cont)
3163 , ("editor" , liftIO findEditor >>= setEditor)
3164 , ("stop" , setStop default_stop)
3165 ]
3166
3167 no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
3168 no_flag ('-':'X':rest) = return ("-XNo" ++ rest)
3169 no_flag f = throwGhcException (ProgramError ("don't know how to reverse " ++ f))
3170
3171 in if (not (null rest3))
3172 then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))
3173 else do
3174 mapM_ (fromJust.flip lookup defaulters) other_opts
3175
3176 mapM_ unsetOpt plus_opts
3177
3178 no_flags <- mapM no_flag minus_opts
3179 when (not (null no_flags)) $ newDynFlags False no_flags
3180
3181 isMinus :: String -> Bool
3182 isMinus ('-':_) = True
3183 isMinus _ = False
3184
3185 isPlus :: String -> Either String String
3186 isPlus ('+':opt) = Left opt
3187 isPlus other = Right other
3188
3189 setOpt, unsetOpt :: GhciMonad m => String -> m ()
3190
3191 setOpt str
3192 = case strToGHCiOpt str of
3193 Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
3194 Just o -> setOption o
3195
3196 unsetOpt str
3197 = case strToGHCiOpt str of
3198 Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
3199 Just o -> unsetOption o
3200
3201 strToGHCiOpt :: String -> (Maybe GHCiOption)
3202 strToGHCiOpt "m" = Just Multiline
3203 strToGHCiOpt "s" = Just ShowTiming
3204 strToGHCiOpt "t" = Just ShowType
3205 strToGHCiOpt "r" = Just RevertCAFs
3206 strToGHCiOpt "c" = Just CollectInfo
3207 strToGHCiOpt _ = Nothing
3208
3209 optToStr :: GHCiOption -> String
3210 optToStr Multiline = "m"
3211 optToStr ShowTiming = "s"
3212 optToStr ShowType = "t"
3213 optToStr RevertCAFs = "r"
3214 optToStr CollectInfo = "c"
3215
3216
3217 -- ---------------------------------------------------------------------------
3218 -- :show
3219
3220 showCmd :: forall m. GhciMonad m => String -> m ()
3221 showCmd "" = showOptions False
3222 showCmd "-a" = showOptions True
3223 showCmd str = do
3224 st <- getGHCiState
3225 dflags <- getDynFlags
3226 hsc_env <- GHC.getSession
3227
3228 let lookupCmd :: String -> Maybe (m ())
3229 lookupCmd name = lookup name $ map (\(_,b,c) -> (b,c)) cmds
3230
3231 -- (show in help?, command name, action)
3232 action :: String -> m () -> (Bool, String, m ())
3233 action name m = (True, name, m)
3234
3235 hidden :: String -> m () -> (Bool, String, m ())
3236 hidden name m = (False, name, m)
3237
3238 cmds =
3239 [ action "args" $ liftIO $ putStrLn (show (GhciMonad.args st))
3240 , action "prog" $ liftIO $ putStrLn (show (progname st))
3241 , action "editor" $ liftIO $ putStrLn (show (editor st))
3242 , action "stop" $ liftIO $ putStrLn (show (stop st))
3243 , action "imports" $ showImports
3244 , action "modules" $ showModules
3245 , action "bindings" $ showBindings
3246 , action "linker" $ do
3247 msg <- liftIO $ Loader.showLoaderState (hscInterp hsc_env)
3248 putLogMsgM MCDump noSrcSpan msg
3249 , action "breaks" $ showBkptTable
3250 , action "context" $ showContext
3251 , action "packages" $ showUnits
3252 , action "paths" $ showPaths
3253 , action "language" $ showLanguages
3254 , hidden "languages" $ showLanguages -- backwards compat
3255 , hidden "lang" $ showLanguages -- useful abbreviation
3256 , action "targets" $ showTargets
3257 ]
3258
3259 case words str of
3260 [w] | Just action <- lookupCmd w -> action
3261
3262 _ -> let helpCmds = [ text name | (True, name, _) <- cmds ]
3263 in throwGhcException $ CmdLineError $ showSDoc dflags
3264 $ hang (text "syntax:") 4
3265 $ hang (text ":show") 6
3266 $ brackets (fsep $ punctuate (text " |") helpCmds)
3267
3268 showiCmd :: GHC.GhcMonad m => String -> m ()
3269 showiCmd str = do
3270 case words str of
3271 ["languages"] -> showiLanguages -- backwards compat
3272 ["language"] -> showiLanguages
3273 ["lang"] -> showiLanguages -- useful abbreviation
3274 _ -> throwGhcException (CmdLineError ("syntax: :showi language"))
3275
3276 showImports :: GhciMonad m => m ()
3277 showImports = do
3278 st <- getGHCiState
3279 dflags <- getDynFlags
3280 let rem_ctx = reverse (remembered_ctx st)
3281 trans_ctx = transient_ctx st
3282
3283 show_one (IIModule star_m)
3284 = ":module +*" ++ moduleNameString star_m
3285 show_one (IIDecl imp) = showPpr dflags imp
3286
3287 prel_iidecls <- getImplicitPreludeImports (rem_ctx ++ trans_ctx)
3288
3289 let show_prel p = show_one p ++ " -- implicit"
3290 show_extra p = show_one (IIDecl p) ++ " -- fixed"
3291
3292 trans_comment s = s ++ " -- added automatically" :: String
3293 --
3294 liftIO $ mapM_ putStrLn (map show_one rem_ctx ++
3295 map (trans_comment . show_one) trans_ctx ++
3296 map show_prel prel_iidecls ++
3297 map show_extra (extra_imports st))
3298
3299 showModules :: GHC.GhcMonad m => m ()
3300 showModules = do
3301 loaded_mods <- getLoadedModules
3302 -- we want *loaded* modules only, see #1734
3303 let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)
3304 mapM_ show_one loaded_mods
3305
3306 getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
3307 getLoadedModules = do
3308 graph <- GHC.getModuleGraph
3309 filterM (GHC.isLoaded . GHC.ms_mod_name) (GHC.mgModSummaries graph)
3310
3311 showBindings :: GHC.GhcMonad m => m ()
3312 showBindings = do
3313 bindings <- GHC.getBindings
3314 (insts, finsts) <- GHC.getInsts
3315 let idocs = map GHC.pprInstanceHdr insts
3316 fidocs = map GHC.pprFamInst finsts
3317 binds = filter (not . isDerivedOccName . getOccName) bindings -- #12525
3318 -- See Note [Filter bindings]
3319 docs <- mapM makeDoc (reverse binds)
3320 -- reverse so the new ones come last
3321 mapM_ printForUserPartWay (docs ++ idocs ++ fidocs)
3322 where
3323 makeDoc (AnId i) = pprTypeAndContents i
3324 makeDoc tt = do
3325 mb_stuff <- GHC.getInfo False (getName tt)
3326 return $ maybe (text "") pprTT mb_stuff
3327
3328 pprTT :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc
3329 pprTT (thing, fixity, _cls_insts, _fam_insts, _docs)
3330 = pprTyThing showToHeader thing
3331 $$ showFixity thing fixity
3332
3333
3334 printTyThing :: GHC.GhcMonad m => TyThing -> m ()
3335 printTyThing tyth = printForUser (pprTyThing showToHeader tyth)
3336
3337 {-
3338 Note [Filter bindings]
3339 ~~~~~~~~~~~~~~~~~~~~~~
3340
3341 If we don't filter the bindings returned by the function GHC.getBindings,
3342 then the :show bindings command will also show unwanted bound names,
3343 internally generated by GHC, eg:
3344 $tcFoo :: GHC.Types.TyCon = _
3345 $trModule :: GHC.Unit.Module = _ .
3346
3347 The filter was introduced as a fix for #12525 [1]. Comment:1 [2] to this
3348 ticket contains an analysis of the situation and suggests the solution
3349 implemented above.
3350
3351 The same filter was also implemented to fix #11051 [3]. See the
3352 Note [What to show to users] in GHC.Runtime.Eval
3353
3354 [1] https://gitlab.haskell.org/ghc/ghc/issues/12525
3355 [2] https://gitlab.haskell.org/ghc/ghc/issues/12525#note_123489
3356 [3] https://gitlab.haskell.org/ghc/ghc/issues/11051
3357 -}
3358
3359
3360 showBkptTable :: GhciMonad m => m ()
3361 showBkptTable = do
3362 st <- getGHCiState
3363 printForUser $ prettyLocations (breaks st)
3364
3365 showContext :: GHC.GhcMonad m => m ()
3366 showContext = do
3367 resumes <- GHC.getResumeContext
3368 printForUser $ vcat (map pp_resume (reverse resumes))
3369 where
3370 pp_resume res =
3371 text "--> " <> text (GHC.resumeStmt res)
3372 $$ nest 2 (pprStopped res)
3373
3374 pprStopped :: GHC.Resume -> SDoc
3375 pprStopped res =
3376 text "Stopped in"
3377 <+> ((case mb_mod_name of
3378 Nothing -> empty
3379 Just mod_name -> text (moduleNameString mod_name) <> char '.')
3380 <> text (GHC.resumeDecl res))
3381 <> char ',' <+> ppr (GHC.resumeSpan res)
3382 where
3383 mb_mod_name = moduleName <$> GHC.breakInfo_module <$> GHC.resumeBreakInfo res
3384
3385 showUnits :: GHC.GhcMonad m => m ()
3386 showUnits = do
3387 dflags <- getDynFlags
3388 let pkg_flags = packageFlags dflags
3389 liftIO $ putStrLn $ showSDoc dflags $
3390 text ("active package flags:"++if null pkg_flags then " none" else "") $$
3391 nest 2 (vcat (map pprFlag pkg_flags))
3392
3393 showPaths :: GHC.GhcMonad m => m ()
3394 showPaths = do
3395 dflags <- getDynFlags
3396 liftIO $ do
3397 cwd <- getCurrentDirectory
3398 putStrLn $ showSDoc dflags $
3399 text "current working directory: " $$
3400 nest 2 (text cwd)
3401 let ipaths = importPaths dflags
3402 putStrLn $ showSDoc dflags $
3403 text ("module import search paths:"++if null ipaths then " none" else "") $$
3404 nest 2 (vcat (map text ipaths))
3405
3406 showLanguages :: GHC.GhcMonad m => m ()
3407 showLanguages = getDynFlags >>= liftIO . showLanguages' False
3408
3409 showiLanguages :: GHC.GhcMonad m => m ()
3410 showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False
3411
3412 showLanguages' :: Bool -> DynFlags -> IO ()
3413 showLanguages' show_all dflags =
3414 putStrLn $ showSDoc dflags $ vcat
3415 [ text "base language is: " <>
3416 case lang of
3417 Haskell98 -> text "Haskell98"
3418 Haskell2010 -> text "Haskell2010"
3419 GHC2021 -> text "GHC2021"
3420 , (if show_all then text "all active language options:"
3421 else text "with the following modifiers:") $$
3422 nest 2 (vcat (map (setting xopt) DynFlags.xFlags))
3423 ]
3424 where
3425 setting test flag
3426 | quiet = empty
3427 | is_on = text "-X" <> text name
3428 | otherwise = text "-XNo" <> text name
3429 where name = flagSpecName flag
3430 f = flagSpecFlag flag
3431 is_on = test f dflags
3432 quiet = not show_all && test f default_dflags == is_on
3433
3434 default_dflags =
3435 defaultDynFlags (settings dflags) (llvmConfig dflags) `lang_set` Just lang
3436
3437 lang = fromMaybe GHC2021 (language dflags)
3438
3439
3440 showTargets :: GHC.GhcMonad m => m ()
3441 showTargets = mapM_ showTarget =<< GHC.getTargets
3442 where
3443 showTarget :: GHC.GhcMonad m => Target -> m ()
3444 showTarget Target { targetId = TargetFile f _ } = liftIO (putStrLn f)
3445 showTarget Target { targetId = TargetModule m } =
3446 liftIO (putStrLn $ moduleNameString m)
3447
3448 -- -----------------------------------------------------------------------------
3449 -- Completion
3450
3451 completeCmd :: String -> GHCi ()
3452 completeCmd argLine0 = case parseLine argLine0 of
3453 Just ("repl", resultRange, left) -> do
3454 (unusedLine,compls) <- ghciCompleteWord (reverse left,"")
3455 let compls' = takeRange resultRange compls
3456 liftIO . putStrLn $ unwords [ show (length compls'), show (length compls), show (reverse unusedLine) ]
3457 forM_ (takeRange resultRange compls) $ \(Completion r _ _) -> do
3458 liftIO $ print r
3459 _ -> throwGhcException (CmdLineError "Syntax: :complete repl [<range>] <quoted-string-to-complete>")
3460 where
3461 parseLine argLine
3462 | null argLine = Nothing
3463 | null rest1 = Nothing
3464 | otherwise = (,,) dom <$> resRange <*> s
3465 where
3466 (dom, rest1) = breakSpace argLine
3467 (rng, rest2) = breakSpace rest1
3468 resRange | head rest1 == '"' = parseRange ""
3469 | otherwise = parseRange rng
3470 s | head rest1 == '"' = readMaybe rest1 :: Maybe String
3471 | otherwise = readMaybe rest2
3472 breakSpace = fmap (dropWhile isSpace) . break isSpace
3473
3474 takeRange (lb,ub) = maybe id (drop . pred) lb . maybe id take ub
3475
3476 -- syntax: [n-][m] with semantics "drop (n-1) . take m"
3477 parseRange :: String -> Maybe (Maybe Int,Maybe Int)
3478 parseRange s = case span isDigit s of
3479 (_, "") ->
3480 -- upper limit only
3481 Just (Nothing, bndRead s)
3482 (s1, '-' : s2)
3483 | all isDigit s2 ->
3484 Just (bndRead s1, bndRead s2)
3485 _ ->
3486 Nothing
3487 where
3488 bndRead x = if null x then Nothing else Just (read x)
3489
3490
3491
3492 completeGhciCommand, completeMacro, completeIdentifier, completeModule,
3493 completeSetModule, completeSeti, completeShowiOptions,
3494 completeHomeModule, completeSetOptions, completeShowOptions,
3495 completeHomeModuleOrFile, completeExpression, completeBreakpoint
3496 :: GhciMonad m => CompletionFunc m
3497
3498 -- | Provide completions for last word in a given string.
3499 --
3500 -- Takes a tuple of two strings. First string is a reversed line to be
3501 -- completed. Second string is likely unused, 'completeCmd' always passes an
3502 -- empty string as second item in tuple.
3503 ghciCompleteWord :: CompletionFunc GHCi
3504 ghciCompleteWord line@(left,_) = case firstWord of
3505 -- If given string starts with `:` colon, and there is only one following
3506 -- word then provide REPL command completions. If there is more than one
3507 -- word complete either filename or builtin ghci commands or macros.
3508 ':':cmd | null rest -> completeGhciCommand line
3509 | otherwise -> do
3510 completion <- lookupCompletion cmd
3511 completion line
3512 -- If given string starts with `import` keyword provide module name
3513 -- completions
3514 "import" -> completeModule line
3515 -- otherwise provide identifier completions
3516 _ -> completeExpression line
3517 where
3518 (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
3519 lookupCompletion ('!':_) = return completeFilename
3520 lookupCompletion c = do
3521 maybe_cmd <- lookupCommand' c
3522 case maybe_cmd of
3523 Just cmd -> return (cmdCompletionFunc cmd)
3524 Nothing -> return completeFilename
3525
3526 completeGhciCommand = wrapCompleter " " $ \w -> do
3527 macros <- ghci_macros <$> getGHCiState
3528 cmds <- ghci_commands `fmap` getGHCiState
3529 let macro_names = map (':':) . map cmdName $ macros
3530 let command_names = map (':':) . map cmdName $ filter (not . cmdHidden) cmds
3531 let{ candidates = case w of
3532 ':' : ':' : _ -> map (':':) command_names
3533 _ -> nub $ macro_names ++ command_names }
3534 return $ filter (w `isPrefixOptOf`) candidates
3535
3536 completeMacro = wrapIdentCompleter $ \w -> do
3537 cmds <- ghci_macros <$> getGHCiState
3538 return (filter (w `isPrefixOf`) (map cmdName cmds))
3539
3540 completeIdentifier line@(left, _) =
3541 -- Note: `left` is a reversed input
3542 case left of
3543 ('.':_) -> wrapCompleter (specials ++ spaces) complete line
3544 -- operator or qualification
3545 (x:_) | isSymbolChar x -> wrapCompleter' (\c -> c `elem` (specials ++ spaces) || not (isSymbolChar c))
3546 complete line -- operator
3547 _ -> wrapIdentCompleter complete line
3548 where
3549 complete w = do
3550 rdrs <- GHC.getRdrNamesInScope
3551 dflags <- GHC.getSessionDynFlags
3552 return (filter (w `isPrefixOf`) (map (showPpr dflags) rdrs))
3553
3554 -- TAB-completion for the :break command.
3555 -- Build and return a list of breakpoint identifiers with a given prefix.
3556 -- See Note [Tab-completion for :break]
3557 completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000
3558 -- bid ~ breakpoint identifier = a name of a function that is
3559 -- eligible to set a breakpoint.
3560 let (mod_str, _, _) = splitIdent w
3561 bids_mod_breaks <- bidsFromModBreaks mod_str
3562 bids_inscopes <- bidsFromInscopes
3563 pure $ nub $ filter (isPrefixOf w) $ bids_mod_breaks ++ bids_inscopes
3564 where
3565 -- Extract all bids from ModBreaks for a given module name prefix
3566 bidsFromModBreaks :: GhciMonad m => String -> m [String]
3567 bidsFromModBreaks mod_pref = do
3568 imods <- interpretedHomeMods
3569 let pmods = filter ((isPrefixOf mod_pref) . showModule) imods
3570 nonquals <- case null mod_pref of
3571 -- If the prefix is empty, then for functions declared in a module
3572 -- in scope, don't qualify the function name.
3573 -- (eg: `main` instead of `Main.main`)
3574 True -> do
3575 imports <- GHC.getContext
3576 pure [ m | IIModule m <- imports]
3577 False -> return []
3578 bidss <- mapM (bidsByModule nonquals) pmods
3579 pure $ concat bidss
3580
3581 -- Return a list of interpreted home modules
3582 interpretedHomeMods :: GhciMonad m => m [Module]
3583 interpretedHomeMods = do
3584 graph <- GHC.getModuleGraph
3585 let hmods = ms_mod <$> GHC.mgModSummaries graph
3586 filterM GHC.moduleIsInterpreted hmods
3587
3588 -- Return all possible bids for a given Module
3589 bidsByModule :: GhciMonad m => [ModuleName] -> Module -> m [String]
3590 bidsByModule nonquals mod = do
3591 (_, decls) <- getModBreak mod
3592 let bids = nub $ declPath <$> elems decls
3593 pure $ case (moduleName mod) `elem` nonquals of
3594 True -> bids
3595 False -> (combineModIdent (showModule mod)) <$> bids
3596
3597 -- Extract all bids from all top-level identifiers in scope.
3598 bidsFromInscopes :: GhciMonad m => m [String]
3599 bidsFromInscopes = do
3600 dflags <- getDynFlags
3601 rdrs <- GHC.getRdrNamesInScope
3602 inscopess <- mapM createInscope $ (showSDoc dflags . ppr) <$> rdrs
3603 imods <- interpretedHomeMods
3604 let topLevels = filter ((`elem` imods) . snd) $ concat inscopess
3605 bidss <- mapM (addNestedDecls) topLevels
3606 pure $ concat bidss
3607
3608 -- Return a list of (bid,module) for a single top-level in-scope identifier
3609 createInscope :: GhciMonad m => String -> m [(String, Module)]
3610 createInscope str_rdr = do
3611 names <- GHC.parseName str_rdr
3612 pure $ zip (repeat str_rdr) $ GHC.nameModule <$> names
3613
3614 -- For every top-level identifier in scope, add the bids of the nested
3615 -- declarations. See Note [ModBreaks.decls] in GHC.ByteCode.Types
3616 addNestedDecls :: GhciMonad m => (String, Module) -> m [String]
3617 addNestedDecls (ident, mod) = do
3618 (_, decls) <- getModBreak mod
3619 let (mod_str, topLvl, _) = splitIdent ident
3620 ident_decls = filter ((topLvl ==) . head) $ elems decls
3621 bids = nub $ declPath <$> ident_decls
3622 pure $ map (combineModIdent mod_str) bids
3623
3624 completeModule = wrapIdentCompleterMod $ \w -> do
3625 hsc_env <- GHC.getSession
3626 let pkg_mods = allVisibleModules (hsc_units hsc_env)
3627 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
3628 return $ filter (w `isPrefixOf`)
3629 $ map (showPpr (hsc_dflags hsc_env)) $ loaded_mods ++ pkg_mods
3630
3631 completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
3632 hsc_env <- GHC.getSession
3633 modules <- case m of
3634 Just '-' -> do
3635 imports <- GHC.getContext
3636 return $ map iiModuleName imports
3637 _ -> do
3638 let pkg_mods = allVisibleModules (hsc_units hsc_env)
3639 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
3640 return $ loaded_mods ++ pkg_mods
3641 return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules
3642
3643 completeHomeModule = wrapIdentCompleterMod listHomeModules
3644
3645 listHomeModules :: GHC.GhcMonad m => String -> m [String]
3646 listHomeModules w = do
3647 g <- GHC.getModuleGraph
3648 let home_mods = map GHC.ms_mod_name (GHC.mgModSummaries g)
3649 dflags <- getDynFlags
3650 return $ sort $ filter (w `isPrefixOf`)
3651 $ map (showPpr dflags) home_mods
3652
3653 completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
3654 return (filter (w `isPrefixOf`) opts)
3655 where opts = "args":"prog":"prompt":"prompt-cont":"prompt-function":
3656 "prompt-cont-function":"editor":"stop":flagList
3657 flagList = map head $ group $ sort allNonDeprecatedFlags
3658
3659 completeSeti = wrapCompleter flagWordBreakChars $ \w -> do
3660 return (filter (w `isPrefixOf`) flagList)
3661 where flagList = map head $ group $ sort allNonDeprecatedFlags
3662
3663 completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
3664 return (filter (w `isPrefixOf`) opts)
3665 where opts = ["args", "prog", "editor", "stop",
3666 "modules", "bindings", "linker", "breaks",
3667 "context", "packages", "paths", "language", "imports"]
3668
3669 completeShowiOptions = wrapCompleter flagWordBreakChars $ \w -> do
3670 return (filter (w `isPrefixOf`) ["language"])
3671
3672 completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
3673 $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
3674 listFiles
3675
3676 unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
3677 unionComplete f1 f2 line = do
3678 cs1 <- f1 line
3679 cs2 <- f2 line
3680 return (cs1 ++ cs2)
3681
3682 wrapCompleter :: Monad m => String -> (String -> m [String]) -> CompletionFunc m
3683 wrapCompleter breakChars = wrapCompleter' (`elem` breakChars)
3684
3685 wrapCompleter' :: Monad m => (Char -> Bool) -> (String -> m [String]) -> CompletionFunc m
3686 wrapCompleter' breakPred fun = completeWord' Nothing breakPred
3687 $ fmap (map simpleCompletion . nubSort) . fun
3688
3689 wrapIdentCompleter :: Monad m => (String -> m [String]) -> CompletionFunc m
3690 wrapIdentCompleter = wrapCompleter' word_break_chars_pred
3691
3692 wrapIdentCompleterMod :: Monad m => (String -> m [String]) -> CompletionFunc m
3693 wrapIdentCompleterMod = wrapCompleter' go
3694 where
3695 go '.' = False -- Treated specially since it is a seperator for module qualifiers
3696 go c = word_break_chars_pred c
3697
3698 wrapIdentCompleterWithModifier
3699 :: Monad m
3700 => String -> (Maybe Char -> String -> m [String]) -> CompletionFunc m
3701 wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars
3702 $ \rest -> fmap (map simpleCompletion . nubSort) . fun (getModifier rest)
3703 where
3704 getModifier = find (`elem` modifChars)
3705
3706 -- | Return a list of visible module names for autocompletion.
3707 -- (NB: exposed != visible)
3708 allVisibleModules :: UnitState -> [ModuleName]
3709 allVisibleModules unit_state = listVisibleModuleNames unit_state
3710
3711 completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
3712 completeIdentifier
3713
3714
3715 {-
3716 Note [Tab-completion for :break]
3717 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3718 In tab-completion for the `:break` command, only those
3719 identifiers should be shown, that are accepted in the
3720 `:break` command. Hence these identifiers must be
3721
3722 - defined in an interpreted module
3723 - listed in a `ModBreaks` value as a possible breakpoint.
3724
3725 The identifiers may be qualified or unqualified.
3726
3727 To get all possible top-level breakpoints for tab-completion
3728 with the correct qualification do:
3729
3730 1. Build a list called `bids_mod_breaks` of identifier names eligible
3731 for setting breakpoints: For every interpreted module with the
3732 correct module prefix read all identifier names from the `decls` field
3733 of the `ModBreaks` array.
3734
3735 2. Build a list called `bids_inscopess` of identifiers in scope:
3736 Take all RdrNames in scope, and filter by interpreted modules.
3737 Fore each of these top-level identifiers add from the `ModBreaks`
3738 arrays the available identifiers of the nested functions.
3739
3740 3.) Combine both lists, filter by the given prefix, and remove duplicates.
3741 -}
3742
3743 -- -----------------------------------------------------------------------------
3744 -- commands for debugger
3745
3746 sprintCmd, printCmd, forceCmd :: GHC.GhcMonad m => String -> m ()
3747 sprintCmd = pprintClosureCommand False False
3748 printCmd = pprintClosureCommand True False
3749 forceCmd = pprintClosureCommand False True
3750
3751 stepCmd :: GhciMonad m => String -> m ()
3752 stepCmd arg = withSandboxOnly ":step" $ step arg
3753 where
3754 step [] = doContinue (const True) GHC.SingleStep
3755 step expression = runStmt expression GHC.SingleStep >> return ()
3756
3757 stepLocalCmd :: GhciMonad m => String -> m ()
3758 stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg
3759 where
3760 step expr
3761 | not (null expr) = stepCmd expr
3762 | otherwise = do
3763 mb_span <- getCurrentBreakSpan
3764 case mb_span of
3765 Nothing -> stepCmd []
3766 Just (UnhelpfulSpan _) -> liftIO $ putStrLn ( -- #14690
3767 ":steplocal is not possible." ++
3768 "\nCannot determine current top-level binding after " ++
3769 "a break on error / exception.\nUse :stepmodule.")
3770 Just loc -> do
3771 md <- fromMaybe (panic "stepLocalCmd") <$> getCurrentBreakModule
3772 current_toplevel_decl <- enclosingTickSpan md loc
3773 doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl Strict.Nothing) GHC.SingleStep
3774
3775 stepModuleCmd :: GhciMonad m => String -> m ()
3776 stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg
3777 where
3778 step expr
3779 | not (null expr) = stepCmd expr
3780 | otherwise = do
3781 mb_span <- getCurrentBreakSpan
3782 case mb_span of
3783 Nothing -> stepCmd []
3784 Just pan -> do
3785 let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span
3786 doContinue f GHC.SingleStep
3787
3788 -- | Returns the span of the largest tick containing the srcspan given
3789 enclosingTickSpan :: GhciMonad m => Module -> SrcSpan -> m RealSrcSpan
3790 enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
3791 enclosingTickSpan md (RealSrcSpan src _) = do
3792 ticks <- getTickArray md
3793 let line = srcSpanStartLine src
3794 massert (inRange (bounds ticks) line)
3795 let enclosing_spans = [ pan | (_,pan) <- ticks ! line
3796 , realSrcSpanEnd pan >= realSrcSpanEnd src]
3797 return . head . sortBy leftmostLargestRealSrcSpan $ enclosing_spans
3798 where
3799
3800 leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering
3801 leftmostLargestRealSrcSpan a b =
3802 (realSrcSpanStart a `compare` realSrcSpanStart b)
3803 `thenCmp`
3804 (realSrcSpanEnd b `compare` realSrcSpanEnd a)
3805
3806 traceCmd :: GhciMonad m => String -> m ()
3807 traceCmd arg
3808 = withSandboxOnly ":trace" $ tr arg
3809 where
3810 tr [] = doContinue (const True) GHC.RunAndLogSteps
3811 tr expression = runStmt expression GHC.RunAndLogSteps >> return ()
3812
3813 continueCmd :: GhciMonad m => String -> m () -- #19157
3814 continueCmd argLine = withSandboxOnly ":continue" $
3815 case contSwitch (words argLine) of
3816 Left sdoc -> printForUser sdoc
3817 Right mbCnt -> doContinue' (const True) GHC.RunToCompletion mbCnt
3818 where
3819 contSwitch :: [String] -> Either SDoc (Maybe Int)
3820 contSwitch [ ] = Right Nothing
3821 contSwitch [x] = getIgnoreCount x
3822 contSwitch _ = Left $
3823 text "After ':continue' only one ignore count is allowed"
3824
3825 doContinue :: GhciMonad m => (SrcSpan -> Bool) -> SingleStep -> m ()
3826 doContinue pre step = doContinue' pre step Nothing
3827
3828 doContinue' :: GhciMonad m => (SrcSpan -> Bool) -> SingleStep -> Maybe Int -> m ()
3829 doContinue' pre step mbCnt= do
3830 runResult <- resume pre step mbCnt
3831 _ <- afterRunStmt pre runResult
3832 return ()
3833
3834 abandonCmd :: GhciMonad m => String -> m ()
3835 abandonCmd = noArgs $ withSandboxOnly ":abandon" $ do
3836 b <- GHC.abandon -- the prompt will change to indicate the new context
3837 when (not b) $ liftIO $ putStrLn "There is no computation running."
3838
3839 deleteCmd :: GhciMonad m => String -> m ()
3840 deleteCmd argLine = withSandboxOnly ":delete" $ do
3841 deleteSwitch $ words argLine
3842 where
3843 deleteSwitch :: GhciMonad m => [String] -> m ()
3844 deleteSwitch [] =
3845 liftIO $ putStrLn "The delete command requires at least one argument."
3846 -- delete all break points
3847 deleteSwitch ("*":_rest) = discardActiveBreakPoints
3848 deleteSwitch idents = do
3849 mapM_ deleteOneBreak idents
3850 where
3851 deleteOneBreak :: GhciMonad m => String -> m ()
3852 deleteOneBreak str
3853 | all isDigit str = deleteBreak (read str)
3854 | otherwise = return ()
3855
3856 enableCmd :: GhciMonad m => String -> m ()
3857 enableCmd argLine = withSandboxOnly ":enable" $ do
3858 enaDisaSwitch True $ words argLine
3859
3860 disableCmd :: GhciMonad m => String -> m ()
3861 disableCmd argLine = withSandboxOnly ":disable" $ do
3862 enaDisaSwitch False $ words argLine
3863
3864 enaDisaSwitch :: GhciMonad m => Bool -> [String] -> m ()
3865 enaDisaSwitch enaDisa [] =
3866 printForUser (text "The" <+> text strCmd <+>
3867 text "command requires at least one argument.")
3868 where
3869 strCmd = if enaDisa then ":enable" else ":disable"
3870 enaDisaSwitch enaDisa ("*" : _) = enaDisaAllBreaks enaDisa
3871 enaDisaSwitch enaDisa idents = do
3872 mapM_ (enaDisaOneBreak enaDisa) idents
3873 where
3874 enaDisaOneBreak :: GhciMonad m => Bool -> String -> m ()
3875 enaDisaOneBreak enaDisa strId = do
3876 sdoc_loc <- checkEnaDisa enaDisa strId
3877 case sdoc_loc of
3878 Left sdoc -> printForUser sdoc
3879 Right loc -> enaDisaAssoc enaDisa (read strId, loc)
3880
3881 checkEnaDisa :: GhciMonad m => Bool -> String -> m (Either SDoc BreakLocation)
3882 checkEnaDisa enaDisa strId = do
3883 sdoc_loc <- getBreakLoc strId
3884 pure $ sdoc_loc >>= checkEnaDisaState enaDisa strId
3885
3886 getBreakLoc :: GhciMonad m => String -> m (Either SDoc BreakLocation)
3887 getBreakLoc strId = do
3888 st <- getGHCiState
3889 case readMaybe strId >>= flip IntMap.lookup (breaks st) of
3890 Nothing -> return $ Left (text "Breakpoint" <+> text strId <+>
3891 text "not found")
3892 Just loc -> return $ Right loc
3893
3894 checkEnaDisaState :: Bool -> String -> BreakLocation -> Either SDoc BreakLocation
3895 checkEnaDisaState enaDisa strId loc = do
3896 if breakEnabled loc == enaDisa
3897 then Left $
3898 text "Breakpoint" <+> text strId <+> text "already in desired state"
3899 else Right loc
3900
3901 enaDisaAssoc :: GhciMonad m => Bool -> (Int, BreakLocation) -> m ()
3902 enaDisaAssoc enaDisa (intId, loc) = do
3903 st <- getGHCiState
3904 newLoc <- turnBreakOnOff enaDisa loc
3905 let new_breaks = IntMap.insert intId newLoc (breaks st)
3906 setGHCiState $ st { breaks = new_breaks }
3907
3908 enaDisaAllBreaks :: GhciMonad m => Bool -> m()
3909 enaDisaAllBreaks enaDisa = do
3910 st <- getGHCiState
3911 mapM_ (enaDisaAssoc enaDisa) $ IntMap.assocs $ breaks st
3912
3913 historyCmd :: GHC.GhcMonad m => String -> m ()
3914 historyCmd arg
3915 | null arg = history 20
3916 | all isDigit arg = history (read arg)
3917 | otherwise = liftIO $ putStrLn "Syntax: :history [num]"
3918 where
3919 history num = do
3920 resumes <- GHC.getResumeContext
3921 case resumes of
3922 [] -> liftIO $ putStrLn "Not stopped at a breakpoint"
3923 (r:_) -> do
3924 let hist = GHC.resumeHistory r
3925 (took,rest) = splitAt num hist
3926 case hist of
3927 [] -> liftIO $ putStrLn $
3928 "Empty history. Perhaps you forgot to use :trace?"
3929 _ -> do
3930 pans <- mapM GHC.getHistorySpan took
3931 let nums = map (printf "-%-3d:") [(1::Int)..]
3932 names = map GHC.historyEnclosingDecls took
3933 printForUser (vcat(zipWith3
3934 (\x y z -> x <+> y <+> z)
3935 (map text nums)
3936 (map (bold . hcat . punctuate colon . map text) names)
3937 (map (parens . ppr) pans)))
3938 liftIO $ putStrLn $ if null rest then "<end of history>" else "..."
3939
3940 bold :: SDoc -> SDoc
3941 bold c | do_bold = text start_bold <> c <> text end_bold
3942 | otherwise = c
3943
3944 ignoreCmd :: GhciMonad m => String -> m () -- #19157
3945 ignoreCmd argLine = withSandboxOnly ":ignore" $ do
3946 result <- ignoreSwitch (words argLine)
3947 case result of
3948 Left sdoc -> printForUser sdoc
3949 Right (loc, mbCount) -> do
3950 let breakInfo = GHC.BreakInfo (breakModule loc) (breakTick loc)
3951 count = fromMaybe 0 mbCount
3952 setupBreakpoint breakInfo count
3953
3954 ignoreSwitch :: GhciMonad m => [String] -> m (Either SDoc (BreakLocation, Maybe Int))
3955 ignoreSwitch [break, count] = do
3956 sdoc_loc <- getBreakLoc break
3957 pure $ (,) <$> sdoc_loc <*> getIgnoreCount count
3958 ignoreSwitch _ = pure $ Left $ text "Syntax: :ignore <breaknum> <count>"
3959
3960 getIgnoreCount :: String -> Either SDoc (Maybe Int)
3961 getIgnoreCount str =
3962 let checkJust :: Maybe Int -> Either SDoc (Maybe Int)
3963 checkJust mbCnt
3964 | (isJust mbCnt) = Right mbCnt
3965 | otherwise = Left $ sdocIgnore <+> text "is not numeric"
3966 checkPositive :: Maybe Int -> Either SDoc (Maybe Int)
3967 checkPositive mbCnt
3968 | isJust mbCnt && fromJust mbCnt >= 0 = Right mbCnt
3969 | otherwise = Left $ sdocIgnore <+> text "must be >= 0"
3970 mbCnt :: Maybe Int = readMaybe str
3971 sdocIgnore = (text "Ignore count") <+> quotes (text str)
3972 in Right mbCnt >>= checkJust >>= checkPositive
3973
3974 setupBreakpoint :: GhciMonad m => GHC.BreakInfo -> Int -> m()
3975 setupBreakpoint loc count = do
3976 hsc_env <- GHC.getSession
3977 GHC.setupBreakpoint hsc_env loc count
3978
3979 backCmd :: GhciMonad m => String -> m ()
3980 backCmd arg
3981 | null arg = back 1
3982 | all isDigit arg = back (read arg)
3983 | otherwise = liftIO $ putStrLn "Syntax: :back [num]"
3984 where
3985 back num = withSandboxOnly ":back" $ do
3986 (names, _, pan, _) <- GHC.back num
3987 printForUser $ text "Logged breakpoint at" <+> ppr pan
3988 printTypeOfNames names
3989 -- run the command set with ":set stop <cmd>"
3990 st <- getGHCiState
3991 enqueueCommands [stop st]
3992
3993 forwardCmd :: GhciMonad m => String -> m ()
3994 forwardCmd arg
3995 | null arg = forward 1
3996 | all isDigit arg = forward (read arg)
3997 | otherwise = liftIO $ putStrLn "Syntax: :forward [num]"
3998 where
3999 forward num = withSandboxOnly ":forward" $ do
4000 (names, ix, pan, _) <- GHC.forward num
4001 printForUser $ (if (ix == 0)
4002 then text "Stopped at"
4003 else text "Logged breakpoint at") <+> ppr pan
4004 printTypeOfNames names
4005 -- run the command set with ":set stop <cmd>"
4006 st <- getGHCiState
4007 enqueueCommands [stop st]
4008
4009 -- handle the "break" command
4010 breakCmd :: GhciMonad m => String -> m ()
4011 breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine
4012
4013 breakSwitch :: GhciMonad m => [String] -> m ()
4014 breakSwitch [] = do
4015 liftIO $ putStrLn "The break command requires at least one argument."
4016 breakSwitch (arg1:rest)
4017 | looksLikeModuleName arg1 && not (null rest) = do
4018 md <- wantInterpretedModule arg1
4019 breakByModule md rest
4020 | all isDigit arg1 = do
4021 imports <- GHC.getContext
4022 case iiModules imports of
4023 (mn : _) -> do
4024 md <- lookupModuleName mn
4025 breakByModuleLine md (read arg1) rest
4026 [] -> do
4027 liftIO $ putStrLn "No modules are loaded with debugging support."
4028 | otherwise = do -- try parsing it as an identifier
4029 breakById arg1
4030
4031 breakByModule :: GhciMonad m => Module -> [String] -> m ()
4032 breakByModule md (arg1:rest)
4033 | all isDigit arg1 = do -- looks like a line number
4034 breakByModuleLine md (read arg1) rest
4035 breakByModule _ _
4036 = breakSyntax
4037
4038 breakByModuleLine :: GhciMonad m => Module -> Int -> [String] -> m ()
4039 breakByModuleLine md line args
4040 | [] <- args = findBreakAndSet md $ maybeToList . findBreakByLine line
4041 | [col] <- args, all isDigit col =
4042 findBreakAndSet md $ maybeToList . findBreakByCoord Nothing (line, read col)
4043 | otherwise = breakSyntax
4044
4045 -- Set a breakpoint for an identifier
4046 -- See Note [Setting Breakpoints by Id]
4047 breakById :: GhciMonad m => String -> m () -- #3000
4048 breakById inp = do
4049 let (mod_str, top_level, fun_str) = splitIdent inp
4050 mod_top_lvl = combineModIdent mod_str top_level
4051 mb_mod <- catch (lookupModuleInscope mod_top_lvl)
4052 (\(_ :: SomeException) -> lookupModuleInGraph mod_str)
4053 -- If the top-level name is not in scope, `lookupModuleInscope` will
4054 -- throw an exception, then lookup the module name in the module graph.
4055 mb_err_msg <- validateBP mod_str fun_str mb_mod
4056 case mb_err_msg of
4057 Just err_msg -> printForUser $
4058 text "Cannot set breakpoint on" <+> quotes (text inp)
4059 <> text ":" <+> err_msg
4060 Nothing -> do
4061 -- No errors found, go and set the breakpoint
4062 mb_mod_info <- GHC.getModuleInfo $ fromJust mb_mod
4063 let modBreaks = case mb_mod_info of
4064 (Just mod_info) -> GHC.modInfoModBreaks mod_info
4065 Nothing -> emptyModBreaks
4066 findBreakAndSet (fromJust mb_mod) $ findBreakForBind fun_str modBreaks
4067 where
4068 -- Try to lookup the module for an identifier that is in scope.
4069 -- `parseName` throws an exception, if the identifier is not in scope
4070 lookupModuleInscope :: GhciMonad m => String -> m (Maybe Module)
4071 lookupModuleInscope mod_top_lvl = do
4072 names <- GHC.parseName mod_top_lvl
4073 pure $ Just $ head $ GHC.nameModule <$> names
4074 -- if GHC.parseName succeeds `names` is not empty!
4075 -- if it fails, the last line will not be evaluated.
4076
4077 -- Lookup the Module of a module name in the module graph
4078 lookupModuleInGraph :: GhciMonad m => String -> m (Maybe Module)
4079 lookupModuleInGraph mod_str = do
4080 graph <- GHC.getModuleGraph
4081 let hmods = ms_mod <$> GHC.mgModSummaries graph
4082 pure $ find ((== mod_str) . showModule) hmods
4083
4084 -- Check validity of an identifier to set a breakpoint:
4085 -- 1. The module of the identifier must exist
4086 -- 2. the identifier must be in an interpreted module
4087 -- 3. the ModBreaks array for module `mod` must have an entry
4088 -- for the function
4089 validateBP :: GhciMonad m => String -> String -> Maybe Module
4090 -> m (Maybe SDoc)
4091 validateBP mod_str fun_str Nothing = pure $ Just $ quotes (text
4092 (combineModIdent mod_str (Prelude.takeWhile (/= '.') fun_str)))
4093 <+> text "not in scope"
4094 validateBP _ "" (Just _) = pure $ Just $ text "Function name is missing"
4095 validateBP _ fun_str (Just modl) = do
4096 isInterpr <- GHC.moduleIsInterpreted modl
4097 (_, decls) <- getModBreak modl
4098 mb_err_msg <- case isInterpr of
4099 False -> pure $ Just $ text "Module" <+> quotes (ppr modl)
4100 <+> text "is not interpreted"
4101 True -> case fun_str `elem` (declPath <$> elems decls) of
4102 False -> pure $ Just $
4103 text "No breakpoint found for" <+> quotes (text fun_str)
4104 <+> "in module" <+> quotes (ppr modl)
4105 True -> pure Nothing
4106 pure mb_err_msg
4107
4108 breakSyntax :: a
4109 breakSyntax = throwGhcException $ CmdLineError ("Syntax: :break [<mod>.]<func>[.<func>]\n"
4110 ++ " :break [<mod>] <line> [<column>]")
4111
4112 findBreakAndSet :: GhciMonad m
4113 => Module -> (TickArray -> [(Int, RealSrcSpan)]) -> m ()
4114 findBreakAndSet md lookupTickTree = do
4115 tickArray <- getTickArray md
4116 case lookupTickTree tickArray of
4117 [] -> liftIO $ putStrLn $ "No breakpoints found at that location."
4118 some -> mapM_ breakAt some
4119 where
4120 breakAt (tick, pan) = do
4121 setBreakFlag md tick True
4122 (alreadySet, nm) <-
4123 recordBreak $ BreakLocation
4124 { breakModule = md
4125 , breakLoc = RealSrcSpan pan Strict.Nothing
4126 , breakTick = tick
4127 , onBreakCmd = ""
4128 , breakEnabled = True
4129 }
4130 printForUser $
4131 text "Breakpoint " <> ppr nm <>
4132 if alreadySet
4133 then text " was already set at " <> ppr pan
4134 else text " activated at " <> ppr pan
4135
4136 -- When a line number is specified, the current policy for choosing
4137 -- the best breakpoint is this:
4138 -- - the leftmost complete subexpression on the specified line, or
4139 -- - the leftmost subexpression starting on the specified line, or
4140 -- - the rightmost subexpression enclosing the specified line
4141 --
4142 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,RealSrcSpan)
4143 findBreakByLine line arr
4144 | not (inRange (bounds arr) line) = Nothing
4145 | otherwise =
4146 listToMaybe (sortBy (leftmostLargestRealSrcSpan `on` snd) comp) `mplus`
4147 listToMaybe (sortBy (compare `on` snd) incomp) `mplus`
4148 listToMaybe (sortBy (flip compare `on` snd) ticks)
4149 where
4150 ticks = arr ! line
4151
4152 starts_here = [ (ix,pan) | (ix, pan) <- ticks,
4153 GHC.srcSpanStartLine pan == line ]
4154
4155 (comp, incomp) = partition ends_here starts_here
4156 where ends_here (_,pan) = GHC.srcSpanEndLine pan == line
4157
4158 -- The aim is to find the breakpoints for all the RHSs of the
4159 -- equations corresponding to a binding. So we find all breakpoints
4160 -- for
4161 -- (a) this binder only (it maybe a top-level or a nested declaration)
4162 -- (b) that do not have an enclosing breakpoint
4163 findBreakForBind :: String -> GHC.ModBreaks -> TickArray
4164 -> [(BreakIndex,RealSrcSpan)]
4165 findBreakForBind str_name modbreaks _ = filter (not . enclosed) ticks
4166 where
4167 ticks = [ (index, span)
4168 | (index, decls) <- assocs (GHC.modBreaks_decls modbreaks),
4169 str_name == declPath decls,
4170 RealSrcSpan span _ <- [GHC.modBreaks_locs modbreaks ! index] ]
4171 enclosed (_,sp0) = any subspan ticks
4172 where subspan (_,sp) = sp /= sp0 &&
4173 realSrcSpanStart sp <= realSrcSpanStart sp0 &&
4174 realSrcSpanEnd sp0 <= realSrcSpanEnd sp
4175
4176 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
4177 -> Maybe (BreakIndex,RealSrcSpan)
4178 findBreakByCoord mb_file (line, col) arr
4179 | not (inRange (bounds arr) line) = Nothing
4180 | otherwise =
4181 listToMaybe (sortBy (flip compare `on` snd) contains ++
4182 sortBy (compare `on` snd) after_here)
4183 where
4184 ticks = arr ! line
4185
4186 -- the ticks that span this coordinate
4187 contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan Strict.Nothing `spans` (line,col),
4188 is_correct_file pan ]
4189
4190 is_correct_file pan
4191 | Just f <- mb_file = GHC.srcSpanFile pan == f
4192 | otherwise = True
4193
4194 after_here = [ tick | tick@(_,pan) <- ticks,
4195 GHC.srcSpanStartLine pan == line,
4196 GHC.srcSpanStartCol pan >= col ]
4197
4198 -- For now, use ANSI bold on terminals that we know support it.
4199 -- Otherwise, we add a line of carets under the active expression instead.
4200 -- In particular, on Windows and when running the testsuite (which sets
4201 -- TERM to vt100 for other reasons) we get carets.
4202 -- We really ought to use a proper termcap/terminfo library.
4203 do_bold :: Bool
4204 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
4205 where mTerm = System.Environment.getEnv "TERM"
4206 `catchIO` \_ -> return "TERM not set"
4207
4208 start_bold :: String
4209 start_bold = "\ESC[1m"
4210 end_bold :: String
4211 end_bold = "\ESC[0m"
4212
4213 {-
4214 Note [Setting Breakpoints by Id]
4215 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4216 To set a breakpoint first check whether a ModBreaks array contains a
4217 breakpoint with the given function name:
4218 In `:break M.foo` `M` may be a module name or a local alias of an import
4219 statement. To lookup a breakpoint in the ModBreaks, the effective module
4220 name is needed. Even if a module called `M` exists, `M` may still be
4221 a local alias. To get the module name, parse the top-level identifier with
4222 `GHC.parseName`. If this succeeds, extract the module name from the
4223 returned value. If it fails, catch the exception and assume `M` is a real
4224 module name.
4225
4226 The names of nested functions are stored in `ModBreaks.modBreaks_decls`.
4227 -}
4228
4229 -----------------------------------------------------------------------------
4230 -- :where
4231
4232 whereCmd :: GHC.GhcMonad m => String -> m ()
4233 whereCmd = noArgs $ do
4234 mstrs <- getCallStackAtCurrentBreakpoint
4235 case mstrs of
4236 Nothing -> return ()
4237 Just strs -> liftIO $ putStrLn (renderStack strs)
4238
4239 -----------------------------------------------------------------------------
4240 -- :list
4241
4242 listCmd :: GhciMonad m => String -> m ()
4243 listCmd "" = do
4244 mb_span <- getCurrentBreakSpan
4245 case mb_span of
4246 Nothing ->
4247 printForUser $ text "Not stopped at a breakpoint; nothing to list"
4248 Just (RealSrcSpan pan _) ->
4249 listAround pan True
4250 Just pan@(UnhelpfulSpan _) ->
4251 do resumes <- GHC.getResumeContext
4252 case resumes of
4253 [] -> panic "No resumes"
4254 (r:_) ->
4255 do let traceIt = case GHC.resumeHistory r of
4256 [] -> text "rerunning with :trace,"
4257 _ -> empty
4258 doWhat = traceIt <+> text ":back then :list"
4259 printForUser (text "Unable to list source for" <+>
4260 ppr pan
4261 $$ text "Try" <+> doWhat)
4262 listCmd str = list2 (words str)
4263
4264 list2 :: GhciMonad m => [String] -> m ()
4265 list2 [arg] | all isDigit arg = do
4266 imports <- GHC.getContext
4267 case iiModules imports of
4268 [] -> liftIO $ putStrLn "No module to list"
4269 (mn : _) -> do
4270 md <- lookupModuleName mn
4271 listModuleLine md (read arg)
4272 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
4273 md <- wantInterpretedModule arg1
4274 listModuleLine md (read arg2)
4275 list2 [arg] = do
4276 wantNameFromInterpretedModule noCanDo arg $ \name -> do
4277 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
4278 case loc of
4279 RealSrcLoc l _ ->
4280 do tickArray <- assert (isExternalName name) $
4281 getTickArray (GHC.nameModule name)
4282 let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))
4283 (GHC.srcLocLine l, GHC.srcLocCol l)
4284 tickArray
4285 case mb_span of
4286 Nothing -> listAround (realSrcLocSpan l) False
4287 Just (_, pan) -> listAround pan False
4288 UnhelpfulLoc _ ->
4289 noCanDo name $ text "can't find its location: " <>
4290 ppr loc
4291 where
4292 noCanDo n why = printForUser $
4293 text "cannot list source code for " <> ppr n <> text ": " <> why
4294 list2 _other =
4295 liftIO $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
4296
4297 listModuleLine :: GHC.GhcMonad m => Module -> Int -> m ()
4298 listModuleLine modl line = do
4299 graph <- GHC.getModuleGraph
4300 let this = GHC.mgLookupModule graph modl
4301 case this of
4302 Nothing -> panic "listModuleLine"
4303 Just summ -> do
4304 let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
4305 loc = mkRealSrcLoc (mkFastString (filename)) line 0
4306 listAround (realSrcLocSpan loc) False
4307
4308 -- | list a section of a source file around a particular SrcSpan.
4309 -- If the highlight flag is True, also highlight the span using
4310 -- start_bold\/end_bold.
4311
4312 -- GHC files are UTF-8, so we can implement this by:
4313 -- 1) read the file in as a BS and syntax highlight it as before
4314 -- 2) convert the BS to String using utf-string, and write it out.
4315 -- It would be better if we could convert directly between UTF-8 and the
4316 -- console encoding, of course.
4317 listAround :: MonadIO m => RealSrcSpan -> Bool -> m ()
4318 listAround pan do_highlight = do
4319 contents <- liftIO $ BS.readFile (unpackFS file)
4320 -- Drop carriage returns to avoid duplicates, see #9367.
4321 let ls = BS.split '\n' $ BS.filter (/= '\r') contents
4322 ls' = take (line2 - line1 + 1 + pad_before + pad_after) $
4323 drop (line1 - 1 - pad_before) $ ls
4324 fst_line = max 1 (line1 - pad_before)
4325 line_nos = [ fst_line .. ]
4326
4327 highlighted | do_highlight = zipWith highlight line_nos ls'
4328 | otherwise = [\p -> BS.concat[p,l] | l <- ls']
4329
4330 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
4331 prefixed = zipWith ($) highlighted bs_line_nos
4332 output = BS.intercalate (BS.pack "\n") prefixed
4333
4334 let utf8Decoded = utf8DecodeByteString output
4335 liftIO $ putStrLn utf8Decoded
4336 where
4337 file = GHC.srcSpanFile pan
4338 line1 = GHC.srcSpanStartLine pan
4339 col1 = GHC.srcSpanStartCol pan - 1
4340 line2 = GHC.srcSpanEndLine pan
4341 col2 = GHC.srcSpanEndCol pan - 1
4342
4343 pad_before | line1 == 1 = 0
4344 | otherwise = 1
4345 pad_after = 1
4346
4347 highlight | do_bold = highlight_bold
4348 | otherwise = highlight_carets
4349
4350 highlight_bold no line prefix
4351 | no == line1 && no == line2
4352 = let (a,r) = BS.splitAt col1 line
4353 (b,c) = BS.splitAt (col2-col1) r
4354 in
4355 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
4356 | no == line1
4357 = let (a,b) = BS.splitAt col1 line in
4358 BS.concat [prefix, a, BS.pack start_bold, b]
4359 | no == line2
4360 = let (a,b) = BS.splitAt col2 line in
4361 BS.concat [prefix, a, BS.pack end_bold, b]
4362 | otherwise = BS.concat [prefix, line]
4363
4364 highlight_carets no line prefix
4365 | no == line1 && no == line2
4366 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
4367 BS.replicate (col2-col1) '^']
4368 | no == line1
4369 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
4370 prefix, line]
4371 | no == line2
4372 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
4373 BS.pack "^^"]
4374 | otherwise = BS.concat [prefix, line]
4375 where
4376 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
4377 nl = BS.singleton '\n'
4378
4379
4380 -- --------------------------------------------------------------------------
4381 -- Tick arrays
4382
4383 getTickArray :: GhciMonad m => Module -> m TickArray
4384 getTickArray modl = do
4385 st <- getGHCiState
4386 let arrmap = tickarrays st
4387 case lookupModuleEnv arrmap modl of
4388 Just arr -> return arr
4389 Nothing -> do
4390 (ticks, _) <- getModBreak modl
4391 let arr = mkTickArray (assocs ticks)
4392 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
4393 return arr
4394
4395 discardTickArrays :: GhciMonad m => m ()
4396 discardTickArrays = modifyGHCiState (\st -> st {tickarrays = emptyModuleEnv})
4397
4398 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
4399 mkTickArray ticks
4400 = accumArray (flip (:)) [] (1, max_line)
4401 [ (line, (nm,pan)) | (nm,RealSrcSpan pan _) <- ticks, line <- srcSpanLines pan ]
4402 where
4403 max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp _) <- ticks ]
4404 srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ]
4405
4406 -- don't reset the counter back to zero?
4407 discardActiveBreakPoints :: GhciMonad m => m ()
4408 discardActiveBreakPoints = do
4409 st <- getGHCiState
4410 mapM_ (turnBreakOnOff False) $ breaks st
4411 setGHCiState $ st { breaks = IntMap.empty }
4412
4413 -- don't reset the counter back to zero?
4414 discardInterfaceCache :: GhciMonad m => m ()
4415 discardInterfaceCache = do
4416 modifyGHCiState $ (\st -> st { hmiCache = [] })
4417
4418 deleteBreak :: GhciMonad m => Int -> m ()
4419 deleteBreak identity = do
4420 st <- getGHCiState
4421 let oldLocations = breaks st
4422 case IntMap.lookup identity oldLocations of
4423 Nothing -> printForUser (text "Breakpoint" <+> ppr identity <+>
4424 text "does not exist")
4425 Just loc -> do
4426 _ <- (turnBreakOnOff False) loc
4427 let rest = IntMap.delete identity oldLocations
4428 setGHCiState $ st { breaks = rest }
4429
4430 turnBreakOnOff :: GhciMonad m => Bool -> BreakLocation -> m BreakLocation
4431 turnBreakOnOff onOff loc
4432 | onOff == breakEnabled loc = return loc
4433 | otherwise = do
4434 setBreakFlag (breakModule loc) (breakTick loc) onOff
4435 return loc { breakEnabled = onOff }
4436
4437 getModBreak :: GHC.GhcMonad m
4438 => Module -> m (Array Int SrcSpan, Array Int [String])
4439 getModBreak m = do
4440 mod_info <- fromMaybe (panic "getModBreak") <$> GHC.getModuleInfo m
4441 let modBreaks = GHC.modInfoModBreaks mod_info
4442 let ticks = GHC.modBreaks_locs modBreaks
4443 let decls = GHC.modBreaks_decls modBreaks
4444 return (ticks, decls)
4445
4446 setBreakFlag :: GhciMonad m => Module -> Int -> Bool ->m ()
4447 setBreakFlag md ix enaDisa = do
4448 let enaDisaToCount True = breakOn
4449 enaDisaToCount False = breakOff
4450 setupBreakpoint (GHC.BreakInfo md ix) $ enaDisaToCount enaDisa
4451
4452 -- ---------------------------------------------------------------------------
4453 -- User code exception handling
4454
4455 -- This is the exception handler for exceptions generated by the
4456 -- user's code and exceptions coming from children sessions;
4457 -- it normally just prints out the exception. The
4458 -- handler must be recursive, in case showing the exception causes
4459 -- more exceptions to be raised.
4460 --
4461 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
4462 -- raising another exception. We therefore don't put the recursive
4463 -- handler around the flushing operation, so if stderr is closed
4464 -- GHCi will just die gracefully rather than going into an infinite loop.
4465 handler :: GhciMonad m => SomeException -> m Bool
4466 handler exception = do
4467 flushInterpBuffers
4468 withSignalHandlers $
4469 ghciHandle handler (showException exception >> return False)
4470
4471 showException :: MonadIO m => SomeException -> m ()
4472 showException se =
4473 liftIO $ case fromException se of
4474 -- omit the location for CmdLineError:
4475 Just (CmdLineError s) -> putException s
4476 -- ditto:
4477 Just other_ghc_ex -> putException (show other_ghc_ex)
4478 Nothing ->
4479 case fromException se of
4480 Just UserInterrupt -> putException "Interrupted."
4481 _ -> putException ("*** Exception: " ++ show se)
4482 where
4483 putException = hPutStrLn stderr
4484
4485
4486 -----------------------------------------------------------------------------
4487 -- recursive exception handlers
4488
4489 -- Don't forget to unblock async exceptions in the handler, or if we're
4490 -- in an exception loop (eg. let a = error a in a) the ^C exception
4491 -- may never be delivered. Thanks to Marcin for pointing out the bug.
4492
4493 ghciHandle :: (HasLogger m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a
4494 ghciHandle h m = mask $ \restore -> do
4495 -- Force dflags to avoid leaking the associated HscEnv
4496 !log <- getLogger
4497 catch (restore (GHC.prettyPrintGhcErrors log m)) $ \e -> restore (h e)
4498
4499 ghciTry :: ExceptionMonad m => m a -> m (Either SomeException a)
4500 ghciTry m = fmap Right m `catch` \e -> return $ Left e
4501
4502 tryBool :: ExceptionMonad m => m a -> m Bool
4503 tryBool m = do
4504 r <- ghciTry m
4505 case r of
4506 Left _ -> return False
4507 Right _ -> return True
4508
4509 -- ----------------------------------------------------------------------------
4510 -- Utils
4511
4512 lookupModule :: GHC.GhcMonad m => String -> m Module
4513 lookupModule mName = lookupModuleName (GHC.mkModuleName mName)
4514
4515 lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module
4516 lookupModuleName mName = GHC.lookupQualifiedModule NoPkgQual mName
4517
4518 isMainUnitModule :: Module -> Bool
4519 isMainUnitModule m = GHC.moduleUnit m == mainUnit
4520
4521 showModule :: Module -> String
4522 showModule = moduleNameString . moduleName
4523
4524 -- Return a String with the declPath of the function of a breakpoint.
4525 -- See Note [Field modBreaks_decls] in GHC.ByteCode.Types
4526 declPath :: [String] -> String
4527 declPath = intercalate "."
4528
4529 -- | Optionally show a fixity declaration like @infixr 4 #@
4530 --
4531 -- We always display the fixity of terms with symbolic names (like <$>).
4532 -- For other terms we only display the fixity if it has been set to a
4533 -- value other than the default infixl 9.
4534 --
4535 -- We have no way of distinguishing between a fixity that has been
4536 -- manually set to infixl 9 and a fixity that has assumed infixl 9 as
4537 -- the default, so we choose to not display the fixity in both cases
4538 -- (for terms with non-symbolic names).
4539 --
4540 -- See #19200.
4541 showFixity :: TyThing -> Fixity -> SDoc
4542 showFixity thing fixity
4543 | fixity /= GHC.defaultFixity || isSymOcc (getOccName thing)
4544 = ppr fixity <+> pprInfixName (GHC.getName thing)
4545 | otherwise = empty
4546
4547 -- TODO: won't work if home dir is encoded.
4548 -- (changeDirectory may not work either in that case.)
4549 expandPath :: MonadIO m => String -> m String
4550 expandPath = liftIO . expandPathIO
4551
4552 expandPathIO :: String -> IO String
4553 expandPathIO p =
4554 case dropWhile isSpace p of
4555 ('~':d) -> do
4556 tilde <- getHomeDirectory -- will fail if HOME not defined
4557 return (tilde ++ '/':d)
4558 other ->
4559 return other
4560
4561 wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
4562 wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str)
4563
4564 wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module
4565 wantInterpretedModuleName modname = do
4566 modl <- lookupModuleName modname
4567 let str = moduleNameString modname
4568 home_unit <- hsc_home_unit <$> GHC.getSession
4569 unless (isHomeModule home_unit modl) $
4570 throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
4571 is_interpreted <- GHC.moduleIsInterpreted modl
4572 when (not is_interpreted) $
4573 throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
4574 return modl
4575
4576 wantNameFromInterpretedModule :: GHC.GhcMonad m
4577 => (Name -> SDoc -> m ())
4578 -> String
4579 -> (Name -> m ())
4580 -> m ()
4581 wantNameFromInterpretedModule noCanDo str and_then =
4582 handleSourceError GHC.printException $ do
4583 names <- GHC.parseName str
4584 case names of
4585 [] -> return ()
4586 (n:_) -> do
4587 let modl = assert (isExternalName n) $ GHC.nameModule n
4588 if not (GHC.isExternalName n)
4589 then noCanDo n $ ppr n <>
4590 text " is not defined in an interpreted module"
4591 else do
4592 is_interpreted <- GHC.moduleIsInterpreted modl
4593 if not is_interpreted
4594 then noCanDo n $ text "module " <> ppr modl <>
4595 text " is not interpreted"
4596 else and_then n
4597
4598 clearAllTargets :: GhciMonad m => m ()
4599 clearAllTargets = discardActiveBreakPoints
4600 >> discardInterfaceCache
4601 >> GHC.setTargets []
4602 >> GHC.load LoadAllTargets
4603 >> pure ()
4604
4605 -- Split up a string with an eventually qualified declaration name into 3 components
4606 -- 1. module name
4607 -- 2. top-level decl
4608 -- 3. full-name of the eventually nested decl, but without module qualification
4609 -- eg "foo" = ("", "foo", "foo")
4610 -- "A.B.C.foo" = ("A.B.C", "foo", "foo")
4611 -- "M.N.foo.bar" = ("M.N", "foo", "foo.bar")
4612 splitIdent :: String -> (String, String, String)
4613 splitIdent [] = ("", "", "")
4614 splitIdent inp@(a : _)
4615 | (isUpper a) = case fixs of
4616 [] -> (inp, "", "")
4617 (i1 : [] ) -> (upto i1, from i1, from i1)
4618 (i1 : i2 : _) -> (upto i1, take (i2 - i1 - 1) (from i1), from i1)
4619 | otherwise = case ixs of
4620 [] -> ("", inp, inp)
4621 (i1 : _) -> ("", upto i1, inp)
4622 where
4623 ixs = elemIndices '.' inp -- indices of '.' in whole input
4624 fixs = dropWhile isNextUc ixs -- indices of '.' in function names --
4625 isNextUc ix = isUpper $ safeInp !! (ix+1)
4626 safeInp = inp ++ " "
4627 upto i = take i inp
4628 from i = drop (i + 1) inp
4629
4630 -- Qualify an identifier name with a module name
4631 -- combineModIdent "A" "foo" = "A.foo"
4632 -- combineModIdent "" "foo" = "foo"
4633 combineModIdent :: String -> String -> String
4634 combineModIdent mod ident
4635 | null mod = ident
4636 | null ident = mod
4637 | otherwise = mod ++ "." ++ ident