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