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