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