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