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