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