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