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