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