Enable new warning for fragile/incorrect CPP #if usage
[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
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, msObjFilePath )
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 ( 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
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 #ifndef 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_ False), completeHomeModuleOrFile),
190 ("load!", keepGoingPaths (loadModule_ True), 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 False), noCompletion),
197 ("reload!", keepGoing' (reloadModule True), 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 #ifdef 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 #ifdef 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 #ifdef 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) -> t) (catMaybes mb_stuffs)
1342 return $ vcat (intersperse (text "") $ map pprInfo filtered)
1343
1344 -- Filter out names whose parent is also there Good
1345 -- example is '[]', which is both a type and data
1346 -- constructor in the same type
1347 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
1348 filterOutChildren get_thing xs
1349 = filterOut has_parent xs
1350 where
1351 all_names = mkNameSet (map (getName . get_thing) xs)
1352 has_parent x = case tyThingParent_maybe (get_thing x) of
1353 Just p -> getName p `elemNameSet` all_names
1354 Nothing -> False
1355
1356 pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc
1357 pprInfo (thing, fixity, cls_insts, fam_insts)
1358 = pprTyThingInContextLoc thing
1359 $$ show_fixity
1360 $$ vcat (map GHC.pprInstance cls_insts)
1361 $$ vcat (map GHC.pprFamInst fam_insts)
1362 where
1363 show_fixity
1364 | fixity == GHC.defaultFixity = empty
1365 | otherwise = ppr fixity <+> pprInfixName (GHC.getName thing)
1366
1367 -----------------------------------------------------------------------------
1368 -- :main
1369
1370 runMain :: String -> GHCi ()
1371 runMain s = case toArgs s of
1372 Left err -> liftIO (hPutStrLn stderr err)
1373 Right args ->
1374 do dflags <- getDynFlags
1375 let main = fromMaybe "main" (mainFunIs dflags)
1376 -- Wrap the main function in 'void' to discard its value instead
1377 -- of printing it (#9086). See Haskell 2010 report Chapter 5.
1378 doWithArgs args $ "Control.Monad.void (" ++ main ++ ")"
1379
1380 -----------------------------------------------------------------------------
1381 -- :run
1382
1383 runRun :: String -> GHCi ()
1384 runRun s = case toCmdArgs s of
1385 Left err -> liftIO (hPutStrLn stderr err)
1386 Right (cmd, args) -> doWithArgs args cmd
1387
1388 doWithArgs :: [String] -> String -> GHCi ()
1389 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
1390 show args ++ " (" ++ cmd ++ ")"]
1391
1392 -----------------------------------------------------------------------------
1393 -- :cd
1394
1395 changeDirectory :: String -> InputT GHCi ()
1396 changeDirectory "" = do
1397 -- :cd on its own changes to the user's home directory
1398 either_dir <- liftIO $ tryIO getHomeDirectory
1399 case either_dir of
1400 Left _e -> return ()
1401 Right dir -> changeDirectory dir
1402 changeDirectory dir = do
1403 graph <- GHC.getModuleGraph
1404 when (not (null graph)) $
1405 liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."
1406 GHC.setTargets []
1407 _ <- GHC.load LoadAllTargets
1408 lift $ setContextAfterLoad False []
1409 GHC.workingDirectoryChanged
1410 dir' <- expandPath dir
1411 liftIO $ setCurrentDirectory dir'
1412 dflags <- getDynFlags
1413 -- With -fexternal-interpreter, we have to change the directory of the subprocess too.
1414 -- (this gives consistent behaviour with and without -fexternal-interpreter)
1415 when (gopt Opt_ExternalInterpreter dflags) $
1416 lift $ enqueueCommands ["System.Directory.setCurrentDirectory " ++ show dir']
1417
1418 trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
1419 trySuccess act =
1420 handleSourceError (\e -> do GHC.printException e
1421 return Failed) $ do
1422 act
1423
1424 -----------------------------------------------------------------------------
1425 -- :edit
1426
1427 editFile :: String -> InputT GHCi ()
1428 editFile str =
1429 do file <- if null str then lift chooseEditFile else expandPath str
1430 st <- getGHCiState
1431 errs <- liftIO $ readIORef $ lastErrorLocations st
1432 let cmd = editor st
1433 when (null cmd)
1434 $ throwGhcException (CmdLineError "editor not set, use :set editor")
1435 lineOpt <- liftIO $ do
1436 let sameFile p1 p2 = liftA2 (==) (canonicalizePath p1) (canonicalizePath p2)
1437 `catchIO` (\_ -> return False)
1438
1439 curFileErrs <- filterM (\(f, _) -> unpackFS f `sameFile` file) errs
1440 return $ case curFileErrs of
1441 (_, line):_ -> " +" ++ show line
1442 _ -> ""
1443 let cmdArgs = ' ':(file ++ lineOpt)
1444 code <- liftIO $ system (cmd ++ cmdArgs)
1445
1446 when (code == ExitSuccess)
1447 $ reloadModule False ""
1448
1449 -- The user didn't specify a file so we pick one for them.
1450 -- Our strategy is to pick the first module that failed to load,
1451 -- or otherwise the first target.
1452 --
1453 -- XXX: Can we figure out what happened if the depndecy analysis fails
1454 -- (e.g., because the porgrammeer mistyped the name of a module)?
1455 -- XXX: Can we figure out the location of an error to pass to the editor?
1456 -- XXX: if we could figure out the list of errors that occured during the
1457 -- last load/reaload, then we could start the editor focused on the first
1458 -- of those.
1459 chooseEditFile :: GHCi String
1460 chooseEditFile =
1461 do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
1462
1463 graph <- GHC.getModuleGraph
1464 failed_graph <- filterM hasFailed graph
1465 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
1466 pick xs = case xs of
1467 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
1468 _ -> Nothing
1469
1470 case pick (order failed_graph) of
1471 Just file -> return file
1472 Nothing ->
1473 do targets <- GHC.getTargets
1474 case msum (map fromTarget targets) of
1475 Just file -> return file
1476 Nothing -> throwGhcException (CmdLineError "No files to edit.")
1477
1478 where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
1479 fromTarget _ = Nothing -- when would we get a module target?
1480
1481
1482 -----------------------------------------------------------------------------
1483 -- :def
1484
1485 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
1486 defineMacro _ (':':_) =
1487 liftIO $ putStrLn "macro name cannot start with a colon"
1488 defineMacro overwrite s = do
1489 let (macro_name, definition) = break isSpace s
1490 macros <- ghci_macros <$> getGHCiState
1491 let defined = map cmdName macros
1492 if null macro_name
1493 then if null defined
1494 then liftIO $ putStrLn "no macros defined"
1495 else liftIO $ putStr ("the following macros are defined:\n" ++
1496 unlines defined)
1497 else do
1498 if (not overwrite && macro_name `elem` defined)
1499 then throwGhcException (CmdLineError
1500 ("macro '" ++ macro_name ++ "' is already defined"))
1501 else do
1502
1503 -- compile the expression
1504 handleSourceError GHC.printException $ do
1505 step <- getGhciStepIO
1506 expr <- GHC.parseExpr definition
1507 -- > ghciStepIO . definition :: String -> IO String
1508 let stringTy = nlHsTyVar stringTy_RDR
1509 ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy
1510 body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)
1511 `mkHsApp` (nlHsPar expr)
1512 tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM)
1513 new_expr = L (getLoc expr) $ ExprWithTySig body tySig
1514 hv <- GHC.compileParsedExprRemote new_expr
1515
1516 let newCmd = Command { cmdName = macro_name
1517 , cmdAction = lift . runMacro hv
1518 , cmdHidden = False
1519 , cmdCompletionFunc = noCompletion
1520 }
1521
1522 -- later defined macros have precedence
1523 modifyGHCiState $ \s ->
1524 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
1525 in s { ghci_macros = newCmd : filtered }
1526
1527 runMacro :: GHC.ForeignHValue{-String -> IO String-} -> String -> GHCi Bool
1528 runMacro fun s = do
1529 hsc_env <- GHC.getSession
1530 str <- liftIO $ evalStringToIOString hsc_env fun s
1531 enqueueCommands (lines str)
1532 return False
1533
1534
1535 -----------------------------------------------------------------------------
1536 -- :undef
1537
1538 undefineMacro :: String -> GHCi ()
1539 undefineMacro str = mapM_ undef (words str)
1540 where undef macro_name = do
1541 cmds <- ghci_macros <$> getGHCiState
1542 if (macro_name `notElem` map cmdName cmds)
1543 then throwGhcException (CmdLineError
1544 ("macro '" ++ macro_name ++ "' is not defined"))
1545 else do
1546 -- This is a tad racy but really, it's a shell
1547 modifyGHCiState $ \s ->
1548 s { ghci_macros = filter ((/= macro_name) . cmdName)
1549 (ghci_macros s) }
1550
1551
1552 -----------------------------------------------------------------------------
1553 -- :cmd
1554
1555 cmdCmd :: String -> GHCi ()
1556 cmdCmd str = handleSourceError GHC.printException $ do
1557 step <- getGhciStepIO
1558 expr <- GHC.parseExpr str
1559 -- > ghciStepIO str :: IO String
1560 let new_expr = step `mkHsApp` expr
1561 hv <- GHC.compileParsedExprRemote new_expr
1562
1563 hsc_env <- GHC.getSession
1564 cmds <- liftIO $ evalString hsc_env hv
1565 enqueueCommands (lines cmds)
1566
1567 -- | Generate a typed ghciStepIO expression
1568 -- @ghciStepIO :: Ty String -> IO String@.
1569 getGhciStepIO :: GHCi (LHsExpr RdrName)
1570 getGhciStepIO = do
1571 ghciTyConName <- GHC.getGHCiMonad
1572 let stringTy = nlHsTyVar stringTy_RDR
1573 ghciM = nlHsTyVar (getRdrName ghciTyConName) `nlHsAppTy` stringTy
1574 ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy
1575 body = nlHsVar (getRdrName ghciStepIoMName)
1576 tySig = mkLHsSigWcType (ghciM `nlHsFunTy` ioM)
1577 return $ noLoc $ ExprWithTySig body tySig
1578
1579 -----------------------------------------------------------------------------
1580 -- :check
1581
1582 checkModule :: String -> InputT GHCi ()
1583 checkModule m = do
1584 let modl = GHC.mkModuleName m
1585 ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do
1586 r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
1587 dflags <- getDynFlags
1588 liftIO $ putStrLn $ showSDoc dflags $
1589 case GHC.moduleInfo r of
1590 cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1591 let
1592 (loc, glob) = ASSERT( all isExternalName scope )
1593 partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1594 in
1595 (text "global names: " <+> ppr glob) $$
1596 (text "local names: " <+> ppr loc)
1597 _ -> empty
1598 return True
1599 afterLoad (successIf ok) False
1600
1601
1602 -----------------------------------------------------------------------------
1603 -- :load, :add, :reload
1604
1605 -- | Sets '-fdefer-type-errors' if 'defer' is true, executes 'load' and unsets
1606 -- '-fdefer-type-errors' again if it has not been set before.
1607 deferredLoad :: Bool -> InputT GHCi SuccessFlag -> InputT GHCi ()
1608 deferredLoad defer load = do
1609 -- Force originalFlags to avoid leaking the associated HscEnv
1610 !originalFlags <- getDynFlags
1611 when defer $ Monad.void $
1612 GHC.setProgramDynFlags $ setGeneralFlag' Opt_DeferTypeErrors originalFlags
1613 Monad.void $ load
1614 Monad.void $ GHC.setProgramDynFlags $ originalFlags
1615
1616 loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
1617 loadModule fs = timeIt (const Nothing) (loadModule' fs)
1618
1619 -- | @:load@ command
1620 loadModule_ :: Bool -> [FilePath] -> InputT GHCi ()
1621 loadModule_ defer fs = deferredLoad defer (loadModule (zip fs (repeat Nothing)))
1622
1623 loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
1624 loadModule' files = do
1625 let (filenames, phases) = unzip files
1626 exp_filenames <- mapM expandPath filenames
1627 let files' = zip exp_filenames phases
1628 targets <- mapM (uncurry GHC.guessTarget) files'
1629
1630 -- NOTE: we used to do the dependency anal first, so that if it
1631 -- fails we didn't throw away the current set of modules. This would
1632 -- require some re-working of the GHC interface, so we'll leave it
1633 -- as a ToDo for now.
1634
1635 -- unload first
1636 _ <- GHC.abandonAll
1637 lift discardActiveBreakPoints
1638 GHC.setTargets []
1639 _ <- GHC.load LoadAllTargets
1640
1641 GHC.setTargets targets
1642 doLoadAndCollectInfo False LoadAllTargets
1643
1644 -- | @:add@ command
1645 addModule :: [FilePath] -> InputT GHCi ()
1646 addModule files = do
1647 lift revertCAFs -- always revert CAFs on load/add.
1648 files' <- mapM expandPath files
1649 targets <- mapM (\m -> GHC.guessTarget m Nothing) files'
1650 -- remove old targets with the same id; e.g. for :add *M
1651 mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
1652 mapM_ GHC.addTarget targets
1653 _ <- doLoadAndCollectInfo False LoadAllTargets
1654 return ()
1655
1656 -- | @:reload@ command
1657 reloadModule :: Bool -> String -> InputT GHCi ()
1658 reloadModule defer m = deferredLoad defer $
1659 doLoadAndCollectInfo True loadTargets
1660 where
1661 loadTargets | null m = LoadAllTargets
1662 | otherwise = LoadUpTo (GHC.mkModuleName m)
1663
1664 -- | Load/compile targets and (optionally) collect module-info
1665 --
1666 -- This collects the necessary SrcSpan annotated type information (via
1667 -- 'collectInfo') required by the @:all-types@, @:loc-at@, @:type-at@,
1668 -- and @:uses@ commands.
1669 --
1670 -- Meta-info collection is not enabled by default and needs to be
1671 -- enabled explicitly via @:set +c@. The reason is that collecting
1672 -- the type-information for all sub-spans can be quite expensive, and
1673 -- since those commands are designed to be used by editors and
1674 -- tooling, it's useless to collect this data for normal GHCi
1675 -- sessions.
1676 doLoadAndCollectInfo :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag
1677 doLoadAndCollectInfo retain_context howmuch = do
1678 doCollectInfo <- lift (isOptionSet CollectInfo)
1679
1680 doLoad retain_context howmuch >>= \case
1681 Succeeded | doCollectInfo -> do
1682 loaded <- getModuleGraph >>= filterM GHC.isLoaded . map GHC.ms_mod_name
1683 v <- mod_infos <$> getGHCiState
1684 !newInfos <- collectInfo v loaded
1685 modifyGHCiState (\st -> st { mod_infos = newInfos })
1686 return Succeeded
1687 flag -> return flag
1688
1689 doLoad :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag
1690 doLoad retain_context howmuch = do
1691 -- turn off breakpoints before we load: we can't turn them off later, because
1692 -- the ModBreaks will have gone away.
1693 lift discardActiveBreakPoints
1694
1695 lift resetLastErrorLocations
1696 -- Enable buffering stdout and stderr as we're compiling. Keeping these
1697 -- handles unbuffered will just slow the compilation down, especially when
1698 -- compiling in parallel.
1699 gbracket (liftIO $ do hSetBuffering stdout LineBuffering
1700 hSetBuffering stderr LineBuffering)
1701 (\_ ->
1702 liftIO $ do hSetBuffering stdout NoBuffering
1703 hSetBuffering stderr NoBuffering) $ \_ -> do
1704 ok <- trySuccess $ GHC.load howmuch
1705 afterLoad ok retain_context
1706 return ok
1707
1708
1709 afterLoad :: SuccessFlag
1710 -> Bool -- keep the remembered_ctx, as far as possible (:reload)
1711 -> InputT GHCi ()
1712 afterLoad ok retain_context = do
1713 lift revertCAFs -- always revert CAFs on load.
1714 lift discardTickArrays
1715 loaded_mods <- getLoadedModules
1716 modulesLoadedMsg ok loaded_mods
1717 lift $ setContextAfterLoad retain_context loaded_mods
1718
1719 setContextAfterLoad :: Bool -> [GHC.ModSummary] -> GHCi ()
1720 setContextAfterLoad keep_ctxt [] = do
1721 setContextKeepingPackageModules keep_ctxt []
1722 setContextAfterLoad keep_ctxt ms = do
1723 -- load a target if one is available, otherwise load the topmost module.
1724 targets <- GHC.getTargets
1725 case [ m | Just m <- map (findTarget ms) targets ] of
1726 [] ->
1727 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1728 load_this (last graph')
1729 (m:_) ->
1730 load_this m
1731 where
1732 findTarget mds t
1733 = case filter (`matches` t) mds of
1734 [] -> Nothing
1735 (m:_) -> Just m
1736
1737 summary `matches` Target (TargetModule m) _ _
1738 = GHC.ms_mod_name summary == m
1739 summary `matches` Target (TargetFile f _) _ _
1740 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1741 _ `matches` _
1742 = False
1743
1744 load_this summary | m <- GHC.ms_mod summary = do
1745 is_interp <- GHC.moduleIsInterpreted m
1746 dflags <- getDynFlags
1747 let star_ok = is_interp && not (safeLanguageOn dflags)
1748 -- We import the module with a * iff
1749 -- - it is interpreted, and
1750 -- - -XSafe is off (it doesn't allow *-imports)
1751 let new_ctx | star_ok = [mkIIModule (GHC.moduleName m)]
1752 | otherwise = [mkIIDecl (GHC.moduleName m)]
1753 setContextKeepingPackageModules keep_ctxt new_ctx
1754
1755
1756 -- | Keep any package modules (except Prelude) when changing the context.
1757 setContextKeepingPackageModules
1758 :: Bool -- True <=> keep all of remembered_ctx
1759 -- False <=> just keep package imports
1760 -> [InteractiveImport] -- new context
1761 -> GHCi ()
1762
1763 setContextKeepingPackageModules keep_ctx trans_ctx = do
1764
1765 st <- getGHCiState
1766 let rem_ctx = remembered_ctx st
1767 new_rem_ctx <- if keep_ctx then return rem_ctx
1768 else keepPackageImports rem_ctx
1769 setGHCiState st{ remembered_ctx = new_rem_ctx,
1770 transient_ctx = filterSubsumed new_rem_ctx trans_ctx }
1771 setGHCContextFromGHCiState
1772
1773 -- | Filters a list of 'InteractiveImport', clearing out any home package
1774 -- imports so only imports from external packages are preserved. ('IIModule'
1775 -- counts as a home package import, because we are only able to bring a
1776 -- full top-level into scope when the source is available.)
1777 keepPackageImports :: [InteractiveImport] -> GHCi [InteractiveImport]
1778 keepPackageImports = filterM is_pkg_import
1779 where
1780 is_pkg_import :: InteractiveImport -> GHCi Bool
1781 is_pkg_import (IIModule _) = return False
1782 is_pkg_import (IIDecl d)
1783 = do e <- gtry $ GHC.findModule mod_name (fmap sl_fs $ ideclPkgQual d)
1784 case e :: Either SomeException Module of
1785 Left _ -> return False
1786 Right m -> return (not (isHomeModule m))
1787 where
1788 mod_name = unLoc (ideclName d)
1789
1790
1791 modulesLoadedMsg :: SuccessFlag -> [GHC.ModSummary] -> InputT GHCi ()
1792 modulesLoadedMsg ok mods = do
1793 dflags <- getDynFlags
1794 unqual <- GHC.getPrintUnqual
1795 let mod_name mod = do
1796 is_interpreted <- GHC.isModuleInterpreted mod
1797 return $ if is_interpreted
1798 then ppr (GHC.ms_mod mod)
1799 else ppr (GHC.ms_mod mod)
1800 <> text " ("
1801 <> text (normalise $ msObjFilePath mod)
1802 <> text ")" -- fix #9887
1803 mod_names <- mapM mod_name mods
1804 let mod_commas
1805 | null mods = text "none."
1806 | otherwise = hsep (punctuate comma mod_names) <> text "."
1807 status = case ok of
1808 Failed -> text "Failed"
1809 Succeeded -> text "Ok"
1810
1811 msg = status <> text ", modules loaded:" <+> mod_commas
1812
1813 when (verbosity dflags > 0) $
1814 liftIO $ putStrLn $ showSDocForUser dflags unqual msg
1815
1816
1817 -- | Run an 'ExceptT' wrapped 'GhcMonad' while handling source errors
1818 -- and printing 'throwE' strings to 'stderr'
1819 runExceptGhcMonad :: GHC.GhcMonad m => ExceptT SDoc m () -> m ()
1820 runExceptGhcMonad act = handleSourceError GHC.printException $
1821 either handleErr pure =<<
1822 runExceptT act
1823 where
1824 handleErr sdoc = do
1825 dflags <- getDynFlags
1826 liftIO . hPutStrLn stderr . showSDocForUser dflags alwaysQualify $ sdoc
1827
1828 -- | Inverse of 'runExceptT' for \"pure\" computations
1829 -- (c.f. 'except' for 'Except')
1830 exceptT :: Applicative m => Either e a -> ExceptT e m a
1831 exceptT = ExceptT . pure
1832
1833 -----------------------------------------------------------------------------
1834 -- | @:type@ command. See also Note [TcRnExprMode] in TcRnDriver.
1835
1836 typeOfExpr :: String -> InputT GHCi ()
1837 typeOfExpr str = handleSourceError GHC.printException $ do
1838 let (mode, expr_str) = case break isSpace str of
1839 ("+d", rest) -> (GHC.TM_Default, dropWhile isSpace rest)
1840 ("+v", rest) -> (GHC.TM_NoInst, dropWhile isSpace rest)
1841 _ -> (GHC.TM_Inst, str)
1842 ty <- GHC.exprType mode expr_str
1843 printForUser $ sep [text expr_str, nest 2 (dcolon <+> pprTypeForUser ty)]
1844
1845 -----------------------------------------------------------------------------
1846 -- | @:type-at@ command
1847
1848 typeAtCmd :: String -> InputT GHCi ()
1849 typeAtCmd str = runExceptGhcMonad $ do
1850 (span',sample) <- exceptT $ parseSpanArg str
1851 infos <- mod_infos <$> getGHCiState
1852 (info, ty) <- findType infos span' sample
1853 lift $ printForUserModInfo (modinfoInfo info)
1854 (sep [text sample,nest 2 (dcolon <+> ppr ty)])
1855
1856 -----------------------------------------------------------------------------
1857 -- | @:uses@ command
1858
1859 usesCmd :: String -> InputT GHCi ()
1860 usesCmd str = runExceptGhcMonad $ do
1861 (span',sample) <- exceptT $ parseSpanArg str
1862 infos <- mod_infos <$> getGHCiState
1863 uses <- findNameUses infos span' sample
1864 forM_ uses (liftIO . putStrLn . showSrcSpan)
1865
1866 -----------------------------------------------------------------------------
1867 -- | @:loc-at@ command
1868
1869 locAtCmd :: String -> InputT GHCi ()
1870 locAtCmd str = runExceptGhcMonad $ do
1871 (span',sample) <- exceptT $ parseSpanArg str
1872 infos <- mod_infos <$> getGHCiState
1873 (_,_,sp) <- findLoc infos span' sample
1874 liftIO . putStrLn . showSrcSpan $ sp
1875
1876 -----------------------------------------------------------------------------
1877 -- | @:all-types@ command
1878
1879 allTypesCmd :: String -> InputT GHCi ()
1880 allTypesCmd _ = runExceptGhcMonad $ do
1881 infos <- mod_infos <$> getGHCiState
1882 forM_ (M.elems infos) $ \mi ->
1883 forM_ (modinfoSpans mi) (lift . printSpan)
1884 where
1885 printSpan span'
1886 | Just ty <- spaninfoType span' = do
1887 df <- getDynFlags
1888 let tyInfo = unwords . words $
1889 showSDocForUser df alwaysQualify (pprTypeForUser ty)
1890 liftIO . putStrLn $
1891 showRealSrcSpan (spaninfoSrcSpan span') ++ ": " ++ tyInfo
1892 | otherwise = return ()
1893
1894 -----------------------------------------------------------------------------
1895 -- Helpers for locAtCmd/typeAtCmd/usesCmd
1896
1897 -- | Parse a span: <module-name/filepath> <sl> <sc> <el> <ec> <string>
1898 parseSpanArg :: String -> Either SDoc (RealSrcSpan,String)
1899 parseSpanArg s = do
1900 (fp,s0) <- readAsString (skipWs s)
1901 s0' <- skipWs1 s0
1902 (sl,s1) <- readAsInt s0'
1903 s1' <- skipWs1 s1
1904 (sc,s2) <- readAsInt s1'
1905 s2' <- skipWs1 s2
1906 (el,s3) <- readAsInt s2'
1907 s3' <- skipWs1 s3
1908 (ec,s4) <- readAsInt s3'
1909
1910 trailer <- case s4 of
1911 [] -> Right ""
1912 _ -> skipWs1 s4
1913
1914 let fs = mkFastString fp
1915 span' = mkRealSrcSpan (mkRealSrcLoc fs sl sc)
1916 (mkRealSrcLoc fs el ec)
1917
1918 return (span',trailer)
1919 where
1920 readAsInt :: String -> Either SDoc (Int,String)
1921 readAsInt "" = Left "Premature end of string while expecting Int"
1922 readAsInt s0 = case reads s0 of
1923 [s_rest] -> Right s_rest
1924 _ -> Left ("Couldn't read" <+> text (show s0) <+> "as Int")
1925
1926 readAsString :: String -> Either SDoc (String,String)
1927 readAsString s0
1928 | '"':_ <- s0 = case reads s0 of
1929 [s_rest] -> Right s_rest
1930 _ -> leftRes
1931 | s_rest@(_:_,_) <- breakWs s0 = Right s_rest
1932 | otherwise = leftRes
1933 where
1934 leftRes = Left ("Couldn't read" <+> text (show s0) <+> "as String")
1935
1936 skipWs1 :: String -> Either SDoc String
1937 skipWs1 (c:cs) | isWs c = Right (skipWs cs)
1938 skipWs1 s0 = Left ("Expected whitespace in" <+> text (show s0))
1939
1940 isWs = (`elem` [' ','\t'])
1941 skipWs = dropWhile isWs
1942 breakWs = break isWs
1943
1944
1945 -- | Pretty-print \"real\" 'SrcSpan's as
1946 -- @<filename>:(<line>,<col>)-(<line-end>,<col-end>)@
1947 -- while simply unpacking 'UnhelpfulSpan's
1948 showSrcSpan :: SrcSpan -> String
1949 showSrcSpan (UnhelpfulSpan s) = unpackFS s
1950 showSrcSpan (RealSrcSpan spn) = showRealSrcSpan spn
1951
1952 -- | Variant of 'showSrcSpan' for 'RealSrcSpan's
1953 showRealSrcSpan :: RealSrcSpan -> String
1954 showRealSrcSpan spn = concat [ fp, ":(", show sl, ",", show sc
1955 , ")-(", show el, ",", show ec, ")"
1956 ]
1957 where
1958 fp = unpackFS (srcSpanFile spn)
1959 sl = srcSpanStartLine spn
1960 sc = srcSpanStartCol spn
1961 el = srcSpanEndLine spn
1962 ec = srcSpanEndCol spn
1963
1964 -----------------------------------------------------------------------------
1965 -- | @:kind@ command
1966
1967 kindOfType :: Bool -> String -> InputT GHCi ()
1968 kindOfType norm str = handleSourceError GHC.printException $ do
1969 (ty, kind) <- GHC.typeKind norm str
1970 printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind
1971 , ppWhen norm $ equals <+> pprTypeForUser ty ]
1972
1973 -----------------------------------------------------------------------------
1974 -- :quit
1975
1976 quit :: String -> InputT GHCi Bool
1977 quit _ = return True
1978
1979
1980 -----------------------------------------------------------------------------
1981 -- :script
1982
1983 -- running a script file #1363
1984
1985 scriptCmd :: String -> InputT GHCi ()
1986 scriptCmd ws = do
1987 case words ws of
1988 [s] -> runScript s
1989 _ -> throwGhcException (CmdLineError "syntax: :script <filename>")
1990
1991 runScript :: String -- ^ filename
1992 -> InputT GHCi ()
1993 runScript filename = do
1994 filename' <- expandPath filename
1995 either_script <- liftIO $ tryIO (openFile filename' ReadMode)
1996 case either_script of
1997 Left _err -> throwGhcException (CmdLineError $ "IO error: \""++filename++"\" "
1998 ++(ioeGetErrorString _err))
1999 Right script -> do
2000 st <- getGHCiState
2001 let prog = progname st
2002 line = line_number st
2003 setGHCiState st{progname=filename',line_number=0}
2004 scriptLoop script
2005 liftIO $ hClose script
2006 new_st <- getGHCiState
2007 setGHCiState new_st{progname=prog,line_number=line}
2008 where scriptLoop script = do
2009 res <- runOneCommand handler $ fileLoop script
2010 case res of
2011 Nothing -> return ()
2012 Just s -> if s
2013 then scriptLoop script
2014 else return ()
2015
2016 -----------------------------------------------------------------------------
2017 -- :issafe
2018
2019 -- Displaying Safe Haskell properties of a module
2020
2021 isSafeCmd :: String -> InputT GHCi ()
2022 isSafeCmd m =
2023 case words m of
2024 [s] | looksLikeModuleName s -> do
2025 md <- lift $ lookupModule s
2026 isSafeModule md
2027 [] -> do md <- guessCurrentModule "issafe"
2028 isSafeModule md
2029 _ -> throwGhcException (CmdLineError "syntax: :issafe <module>")
2030
2031 isSafeModule :: Module -> InputT GHCi ()
2032 isSafeModule m = do
2033 mb_mod_info <- GHC.getModuleInfo m
2034 when (isNothing mb_mod_info)
2035 (throwGhcException $ CmdLineError $ "unknown module: " ++ mname)
2036
2037 dflags <- getDynFlags
2038 let iface = GHC.modInfoIface $ fromJust mb_mod_info
2039 when (isNothing iface)
2040 (throwGhcException $ CmdLineError $ "can't load interface file for module: " ++
2041 (GHC.moduleNameString $ GHC.moduleName m))
2042
2043 (msafe, pkgs) <- GHC.moduleTrustReqs m
2044 let trust = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface
2045 pkg = if packageTrusted dflags m then "trusted" else "untrusted"
2046 (good, bad) = tallyPkgs dflags pkgs
2047
2048 -- print info to user...
2049 liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")"
2050 liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off")
2051 when (not $ S.null good)
2052 (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++
2053 (intercalate ", " $ map (showPpr dflags) (S.toList good)))
2054 case msafe && S.null bad of
2055 True -> liftIO $ putStrLn $ mname ++ " is trusted!"
2056 False -> do
2057 when (not $ null bad)
2058 (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "
2059 ++ (intercalate ", " $ map (showPpr dflags) (S.toList bad)))
2060 liftIO $ putStrLn $ mname ++ " is NOT trusted!"
2061
2062 where
2063 mname = GHC.moduleNameString $ GHC.moduleName m
2064
2065 packageTrusted dflags md
2066 | thisPackage dflags == moduleUnitId md = True
2067 | otherwise = trusted $ getPackageDetails dflags (moduleUnitId md)
2068
2069 tallyPkgs dflags deps | not (packageTrustOn dflags) = (S.empty, S.empty)
2070 | otherwise = S.partition part deps
2071 where part pkg = trusted $ getInstalledPackageDetails dflags pkg
2072
2073 -----------------------------------------------------------------------------
2074 -- :browse
2075
2076 -- Browsing a module's contents
2077
2078 browseCmd :: Bool -> String -> InputT GHCi ()
2079 browseCmd bang m =
2080 case words m of
2081 ['*':s] | looksLikeModuleName s -> do
2082 md <- lift $ wantInterpretedModule s
2083 browseModule bang md False
2084 [s] | looksLikeModuleName s -> do
2085 md <- lift $ lookupModule s
2086 browseModule bang md True
2087 [] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "")
2088 browseModule bang md True
2089 _ -> throwGhcException (CmdLineError "syntax: :browse <module>")
2090
2091 guessCurrentModule :: String -> InputT GHCi Module
2092 -- Guess which module the user wants to browse. Pick
2093 -- modules that are interpreted first. The most
2094 -- recently-added module occurs last, it seems.
2095 guessCurrentModule cmd
2096 = do imports <- GHC.getContext
2097 when (null imports) $ throwGhcException $
2098 CmdLineError (':' : cmd ++ ": no current module")
2099 case (head imports) of
2100 IIModule m -> GHC.findModule m Nothing
2101 IIDecl d -> GHC.findModule (unLoc (ideclName d))
2102 (fmap sl_fs $ ideclPkgQual d)
2103
2104 -- without bang, show items in context of their parents and omit children
2105 -- with bang, show class methods and data constructors separately, and
2106 -- indicate import modules, to aid qualifying unqualified names
2107 -- with sorted, sort items alphabetically
2108 browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
2109 browseModule bang modl exports_only = do
2110 -- :browse reports qualifiers wrt current context
2111 unqual <- GHC.getPrintUnqual
2112
2113 mb_mod_info <- GHC.getModuleInfo modl
2114 case mb_mod_info of
2115 Nothing -> throwGhcException (CmdLineError ("unknown module: " ++
2116 GHC.moduleNameString (GHC.moduleName modl)))
2117 Just mod_info -> do
2118 dflags <- getDynFlags
2119 let names
2120 | exports_only = GHC.modInfoExports mod_info
2121 | otherwise = GHC.modInfoTopLevelScope mod_info
2122 `orElse` []
2123
2124 -- sort alphabetically name, but putting locally-defined
2125 -- identifiers first. We would like to improve this; see #1799.
2126 sorted_names = loc_sort local ++ occ_sort external
2127 where
2128 (local,external) = ASSERT( all isExternalName names )
2129 partition ((==modl) . nameModule) names
2130 occ_sort = sortBy (compare `on` nameOccName)
2131 -- try to sort by src location. If the first name in our list
2132 -- has a good source location, then they all should.
2133 loc_sort ns
2134 | n:_ <- ns, isGoodSrcSpan (nameSrcSpan n)
2135 = sortBy (compare `on` nameSrcSpan) ns
2136 | otherwise
2137 = occ_sort ns
2138
2139 mb_things <- mapM GHC.lookupName sorted_names
2140 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
2141
2142 rdr_env <- GHC.getGRE
2143
2144 let things | bang = catMaybes mb_things
2145 | otherwise = filtered_things
2146 pretty | bang = pprTyThing showToHeader
2147 | otherwise = pprTyThingInContext showToHeader
2148
2149 labels [] = text "-- not currently imported"
2150 labels l = text $ intercalate "\n" $ map qualifier l
2151
2152 qualifier :: Maybe [ModuleName] -> String
2153 qualifier = maybe "-- defined locally"
2154 (("-- imported via "++) . intercalate ", "
2155 . map GHC.moduleNameString)
2156 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
2157
2158 modNames :: [[Maybe [ModuleName]]]
2159 modNames = map (importInfo . GHC.getName) things
2160
2161 -- annotate groups of imports with their import modules
2162 -- the default ordering is somewhat arbitrary, so we group
2163 -- by header and sort groups; the names themselves should
2164 -- really come in order of source appearance.. (trac #1799)
2165 annotate mts = concatMap (\(m,ts)->labels m:ts)
2166 $ sortBy cmpQualifiers $ grp mts
2167 where cmpQualifiers =
2168 compare `on` (map (fmap (map moduleNameFS)) . fst)
2169 grp [] = []
2170 grp mts@((m,_):_) = (m,map snd g) : grp ng
2171 where (g,ng) = partition ((==m).fst) mts
2172
2173 let prettyThings, prettyThings' :: [SDoc]
2174 prettyThings = map pretty things
2175 prettyThings' | bang = annotate $ zip modNames prettyThings
2176 | otherwise = prettyThings
2177 liftIO $ putStrLn $ showSDocForUser dflags unqual (vcat prettyThings')
2178 -- ToDo: modInfoInstances currently throws an exception for
2179 -- package modules. When it works, we can do this:
2180 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
2181
2182
2183 -----------------------------------------------------------------------------
2184 -- :module
2185
2186 -- Setting the module context. For details on context handling see
2187 -- "remembered_ctx" and "transient_ctx" in GhciMonad.
2188
2189 moduleCmd :: String -> GHCi ()
2190 moduleCmd str
2191 | all sensible strs = cmd
2192 | otherwise = throwGhcException (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
2193 where
2194 (cmd, strs) =
2195 case str of
2196 '+':stuff -> rest addModulesToContext stuff
2197 '-':stuff -> rest remModulesFromContext stuff
2198 stuff -> rest setContext stuff
2199
2200 rest op stuff = (op as bs, stuffs)
2201 where (as,bs) = partitionWith starred stuffs
2202 stuffs = words stuff
2203
2204 sensible ('*':m) = looksLikeModuleName m
2205 sensible m = looksLikeModuleName m
2206
2207 starred ('*':m) = Left (GHC.mkModuleName m)
2208 starred m = Right (GHC.mkModuleName m)
2209
2210
2211 -- -----------------------------------------------------------------------------
2212 -- Four ways to manipulate the context:
2213 -- (a) :module +<stuff>: addModulesToContext
2214 -- (b) :module -<stuff>: remModulesFromContext
2215 -- (c) :module <stuff>: setContext
2216 -- (d) import <module>...: addImportToContext
2217
2218 addModulesToContext :: [ModuleName] -> [ModuleName] -> GHCi ()
2219 addModulesToContext starred unstarred = restoreContextOnFailure $ do
2220 addModulesToContext_ starred unstarred
2221
2222 addModulesToContext_ :: [ModuleName] -> [ModuleName] -> GHCi ()
2223 addModulesToContext_ starred unstarred = do
2224 mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)
2225 setGHCContextFromGHCiState
2226
2227 remModulesFromContext :: [ModuleName] -> [ModuleName] -> GHCi ()
2228 remModulesFromContext starred unstarred = do
2229 -- we do *not* call restoreContextOnFailure here. If the user
2230 -- is trying to fix up a context that contains errors by removing
2231 -- modules, we don't want GHC to silently put them back in again.
2232 mapM_ rm (starred ++ unstarred)
2233 setGHCContextFromGHCiState
2234 where
2235 rm :: ModuleName -> GHCi ()
2236 rm str = do
2237 m <- moduleName <$> lookupModuleName str
2238 let filt = filter ((/=) m . iiModuleName)
2239 modifyGHCiState $ \st ->
2240 st { remembered_ctx = filt (remembered_ctx st)
2241 , transient_ctx = filt (transient_ctx st) }
2242
2243 setContext :: [ModuleName] -> [ModuleName] -> GHCi ()
2244 setContext starred unstarred = restoreContextOnFailure $ do
2245 modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] }
2246 -- delete the transient context
2247 addModulesToContext_ starred unstarred
2248
2249 addImportToContext :: String -> GHCi ()
2250 addImportToContext str = restoreContextOnFailure $ do
2251 idecl <- GHC.parseImportDecl str
2252 addII (IIDecl idecl) -- #5836
2253 setGHCContextFromGHCiState
2254
2255 -- Util used by addImportToContext and addModulesToContext
2256 addII :: InteractiveImport -> GHCi ()
2257 addII iidecl = do
2258 checkAdd iidecl
2259 modifyGHCiState $ \st ->
2260 st { remembered_ctx = addNotSubsumed iidecl (remembered_ctx st)
2261 , transient_ctx = filter (not . (iidecl `iiSubsumes`))
2262 (transient_ctx st)
2263 }
2264
2265 -- Sometimes we can't tell whether an import is valid or not until
2266 -- we finally call 'GHC.setContext'. e.g.
2267 --
2268 -- import System.IO (foo)
2269 --
2270 -- will fail because System.IO does not export foo. In this case we
2271 -- don't want to store the import in the context permanently, so we
2272 -- catch the failure from 'setGHCContextFromGHCiState' and set the
2273 -- context back to what it was.
2274 --
2275 -- See #6007
2276 --
2277 restoreContextOnFailure :: GHCi a -> GHCi a
2278 restoreContextOnFailure do_this = do
2279 st <- getGHCiState
2280 let rc = remembered_ctx st; tc = transient_ctx st
2281 do_this `gonException` (modifyGHCiState $ \st' ->
2282 st' { remembered_ctx = rc, transient_ctx = tc })
2283
2284 -- -----------------------------------------------------------------------------
2285 -- Validate a module that we want to add to the context
2286
2287 checkAdd :: InteractiveImport -> GHCi ()
2288 checkAdd ii = do
2289 dflags <- getDynFlags
2290 let safe = safeLanguageOn dflags
2291 case ii of
2292 IIModule modname
2293 | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell"
2294 | otherwise -> wantInterpretedModuleName modname >> return ()
2295
2296 IIDecl d -> do
2297 let modname = unLoc (ideclName d)
2298 pkgqual = ideclPkgQual d
2299 m <- GHC.lookupModule modname (fmap sl_fs pkgqual)
2300 when safe $ do
2301 t <- GHC.isModuleTrusted m
2302 when (not t) $ throwGhcException $ ProgramError $ ""
2303
2304 -- -----------------------------------------------------------------------------
2305 -- Update the GHC API's view of the context
2306
2307 -- | Sets the GHC context from the GHCi state. The GHC context is
2308 -- always set this way, we never modify it incrementally.
2309 --
2310 -- We ignore any imports for which the ModuleName does not currently
2311 -- exist. This is so that the remembered_ctx can contain imports for
2312 -- modules that are not currently loaded, perhaps because we just did
2313 -- a :reload and encountered errors.
2314 --
2315 -- Prelude is added if not already present in the list. Therefore to
2316 -- override the implicit Prelude import you can say 'import Prelude ()'
2317 -- at the prompt, just as in Haskell source.
2318 --
2319 setGHCContextFromGHCiState :: GHCi ()
2320 setGHCContextFromGHCiState = do
2321 st <- getGHCiState
2322 -- re-use checkAdd to check whether the module is valid. If the
2323 -- module does not exist, we do *not* want to print an error
2324 -- here, we just want to silently keep the module in the context
2325 -- until such time as the module reappears again. So we ignore
2326 -- the actual exception thrown by checkAdd, using tryBool to
2327 -- turn it into a Bool.
2328 iidecls <- filterM (tryBool.checkAdd) (transient_ctx st ++ remembered_ctx st)
2329
2330 prel_iidecls <- getImplicitPreludeImports iidecls
2331 valid_prel_iidecls <- filterM (tryBool . checkAdd) prel_iidecls
2332
2333 extra_imports <- filterM (tryBool . checkAdd) (map IIDecl (extra_imports st))
2334
2335 GHC.setContext $ iidecls ++ extra_imports ++ valid_prel_iidecls
2336
2337
2338 getImplicitPreludeImports :: [InteractiveImport] -> GHCi [InteractiveImport]
2339 getImplicitPreludeImports iidecls = do
2340 dflags <- GHC.getInteractiveDynFlags
2341 -- allow :seti to override -XNoImplicitPrelude
2342 st <- getGHCiState
2343
2344 -- We add the prelude imports if there are no *-imports, and we also
2345 -- allow each prelude import to be subsumed by another explicit import
2346 -- of the same module. This means that you can override the prelude import
2347 -- with "import Prelude hiding (map)", for example.
2348 let prel_iidecls =
2349 if xopt LangExt.ImplicitPrelude dflags && not (any isIIModule iidecls)
2350 then [ IIDecl imp
2351 | imp <- prelude_imports st
2352 , not (any (sameImpModule imp) iidecls) ]
2353 else []
2354
2355 return prel_iidecls
2356
2357 -- -----------------------------------------------------------------------------
2358 -- Utils on InteractiveImport
2359
2360 mkIIModule :: ModuleName -> InteractiveImport
2361 mkIIModule = IIModule
2362
2363 mkIIDecl :: ModuleName -> InteractiveImport
2364 mkIIDecl = IIDecl . simpleImportDecl
2365
2366 iiModules :: [InteractiveImport] -> [ModuleName]
2367 iiModules is = [m | IIModule m <- is]
2368
2369 isIIModule :: InteractiveImport -> Bool
2370 isIIModule (IIModule _) = True
2371 isIIModule _ = False
2372
2373 iiModuleName :: InteractiveImport -> ModuleName
2374 iiModuleName (IIModule m) = m
2375 iiModuleName (IIDecl d) = unLoc (ideclName d)
2376
2377 preludeModuleName :: ModuleName
2378 preludeModuleName = GHC.mkModuleName "Prelude"
2379
2380 sameImpModule :: ImportDecl RdrName -> InteractiveImport -> Bool
2381 sameImpModule _ (IIModule _) = False -- we only care about imports here
2382 sameImpModule imp (IIDecl d) = unLoc (ideclName d) == unLoc (ideclName imp)
2383
2384 addNotSubsumed :: InteractiveImport
2385 -> [InteractiveImport] -> [InteractiveImport]
2386 addNotSubsumed i is
2387 | any (`iiSubsumes` i) is = is
2388 | otherwise = i : filter (not . (i `iiSubsumes`)) is
2389
2390 -- | @filterSubsumed is js@ returns the elements of @js@ not subsumed
2391 -- by any of @is@.
2392 filterSubsumed :: [InteractiveImport] -> [InteractiveImport]
2393 -> [InteractiveImport]
2394 filterSubsumed is js = filter (\j -> not (any (`iiSubsumes` j) is)) js
2395
2396 -- | Returns True if the left import subsumes the right one. Doesn't
2397 -- need to be 100% accurate, conservatively returning False is fine.
2398 -- (EXCEPT: (IIModule m) *must* subsume itself, otherwise a panic in
2399 -- plusProv will ensue (#5904))
2400 --
2401 -- Note that an IIModule does not necessarily subsume an IIDecl,
2402 -- because e.g. a module might export a name that is only available
2403 -- qualified within the module itself.
2404 --
2405 -- Note that 'import M' does not necessarily subsume 'import M(foo)',
2406 -- because M might not export foo and we want an error to be produced
2407 -- in that case.
2408 --
2409 iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool
2410 iiSubsumes (IIModule m1) (IIModule m2) = m1==m2
2411 iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude
2412 = unLoc (ideclName d1) == unLoc (ideclName d2)
2413 && ideclAs d1 == ideclAs d2
2414 && (not (ideclQualified d1) || ideclQualified d2)
2415 && (ideclHiding d1 `hidingSubsumes` ideclHiding d2)
2416 where
2417 _ `hidingSubsumes` Just (False,L _ []) = True
2418 Just (False, L _ xs) `hidingSubsumes` Just (False,L _ ys)
2419 = all (`elem` xs) ys
2420 h1 `hidingSubsumes` h2 = h1 == h2
2421 iiSubsumes _ _ = False
2422
2423
2424 ----------------------------------------------------------------------------
2425 -- :set
2426
2427 -- set options in the interpreter. Syntax is exactly the same as the
2428 -- ghc command line, except that certain options aren't available (-C,
2429 -- -E etc.)
2430 --
2431 -- This is pretty fragile: most options won't work as expected. ToDo:
2432 -- figure out which ones & disallow them.
2433
2434 setCmd :: String -> GHCi ()
2435 setCmd "" = showOptions False
2436 setCmd "-a" = showOptions True
2437 setCmd str
2438 = case getCmd str of
2439 Right ("args", rest) ->
2440 case toArgs rest of
2441 Left err -> liftIO (hPutStrLn stderr err)
2442 Right args -> setArgs args
2443 Right ("prog", rest) ->
2444 case toArgs rest of
2445 Right [prog] -> setProg prog
2446 _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")
2447
2448 Right ("prompt", rest) ->
2449 setPromptString setPrompt (dropWhile isSpace rest)
2450 "syntax: set prompt <string>"
2451 Right ("prompt-function", rest) ->
2452 setPromptFunc setPrompt $ dropWhile isSpace rest
2453 Right ("prompt-cont", rest) ->
2454 setPromptString setPromptCont (dropWhile isSpace rest)
2455 "syntax: :set prompt-cont <string>"
2456 Right ("prompt-cont-function", rest) ->
2457 setPromptFunc setPromptCont $ dropWhile isSpace rest
2458
2459 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
2460 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
2461 _ -> case toArgs str of
2462 Left err -> liftIO (hPutStrLn stderr err)
2463 Right wds -> setOptions wds
2464
2465 setiCmd :: String -> GHCi ()
2466 setiCmd "" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False
2467 setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True
2468 setiCmd str =
2469 case toArgs str of
2470 Left err -> liftIO (hPutStrLn stderr err)
2471 Right wds -> newDynFlags True wds
2472
2473 showOptions :: Bool -> GHCi ()
2474 showOptions show_all
2475 = do st <- getGHCiState
2476 dflags <- getDynFlags
2477 let opts = options st
2478 liftIO $ putStrLn (showSDoc dflags (
2479 text "options currently set: " <>
2480 if null opts
2481 then text "none."
2482 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
2483 ))
2484 getDynFlags >>= liftIO . showDynFlags show_all
2485
2486
2487 showDynFlags :: Bool -> DynFlags -> IO ()
2488 showDynFlags show_all dflags = do
2489 showLanguages' show_all dflags
2490 putStrLn $ showSDoc dflags $
2491 text "GHCi-specific dynamic flag settings:" $$
2492 nest 2 (vcat (map (setting "-f" "-fno-" gopt) ghciFlags))
2493 putStrLn $ showSDoc dflags $
2494 text "other dynamic, non-language, flag settings:" $$
2495 nest 2 (vcat (map (setting "-f" "-fno-" gopt) others))
2496 putStrLn $ showSDoc dflags $
2497 text "warning settings:" $$
2498 nest 2 (vcat (map (setting "-W" "-Wno-" wopt) DynFlags.wWarningFlags))
2499 where
2500 setting prefix noPrefix test flag
2501 | quiet = empty
2502 | is_on = text prefix <> text name
2503 | otherwise = text noPrefix <> text name
2504 where name = flagSpecName flag
2505 f = flagSpecFlag flag
2506 is_on = test f dflags
2507 quiet = not show_all && test f default_dflags == is_on
2508
2509 default_dflags = defaultDynFlags (settings dflags)
2510
2511 (ghciFlags,others) = partition (\f -> flagSpecFlag f `elem` flgs)
2512 DynFlags.fFlags
2513 flgs = [ Opt_PrintExplicitForalls
2514 , Opt_PrintExplicitKinds
2515 , Opt_PrintUnicodeSyntax
2516 , Opt_PrintBindResult
2517 , Opt_BreakOnException
2518 , Opt_BreakOnError
2519 , Opt_PrintEvldWithShow
2520 ]
2521
2522 setArgs, setOptions :: [String] -> GHCi ()
2523 setProg, setEditor, setStop :: String -> GHCi ()
2524
2525 setArgs args = do
2526 st <- getGHCiState
2527 wrapper <- mkEvalWrapper (progname st) args
2528 setGHCiState st { GhciMonad.args = args, evalWrapper = wrapper }
2529
2530 setProg prog = do
2531 st <- getGHCiState
2532 wrapper <- mkEvalWrapper prog (GhciMonad.args st)
2533 setGHCiState st { progname = prog, evalWrapper = wrapper }
2534
2535 setEditor cmd = modifyGHCiState (\st -> st { editor = cmd })
2536
2537 setStop str@(c:_) | isDigit c
2538 = do let (nm_str,rest) = break (not.isDigit) str
2539 nm = read nm_str
2540 st <- getGHCiState
2541 let old_breaks = breaks st
2542 if all ((/= nm) . fst) old_breaks
2543 then printForUser (text "Breakpoint" <+> ppr nm <+>
2544 text "does not exist")
2545 else do
2546 let new_breaks = map fn old_breaks
2547 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
2548 | otherwise = (i,loc)
2549 setGHCiState st{ breaks = new_breaks }
2550 setStop cmd = modifyGHCiState (\st -> st { stop = cmd })
2551
2552 setPrompt :: PromptFunction -> GHCi ()
2553 setPrompt v = modifyGHCiState (\st -> st {prompt = v})
2554
2555 setPromptCont :: PromptFunction -> GHCi ()
2556 setPromptCont v = modifyGHCiState (\st -> st {prompt_cont = v})
2557
2558 setPromptFunc :: (PromptFunction -> GHCi ()) -> String -> GHCi ()
2559 setPromptFunc fSetPrompt s = do
2560 -- We explicitly annotate the type of the expression to ensure
2561 -- that unsafeCoerce# is passed the exact type necessary rather
2562 -- than a more general one
2563 let exprStr = "(" ++ s ++ ") :: [String] -> Int -> IO String"
2564 (HValue funValue) <- GHC.compileExpr exprStr
2565 fSetPrompt (convertToPromptFunction $ unsafeCoerce funValue)
2566 where
2567 convertToPromptFunction :: ([String] -> Int -> IO String)
2568 -> PromptFunction
2569 convertToPromptFunction func = (\mods line -> liftIO $
2570 liftM text (func mods line))
2571
2572 setPromptString :: (PromptFunction -> GHCi ()) -> String -> String -> GHCi ()
2573 setPromptString fSetPrompt value err = do
2574 if null value
2575 then liftIO $ hPutStrLn stderr $ err
2576 else case value of
2577 ('\"':_) ->
2578 case reads value of
2579 [(value', xs)] | all isSpace xs ->
2580 setParsedPromptString fSetPrompt value'
2581 _ -> liftIO $ hPutStrLn stderr
2582 "Can't parse prompt string. Use Haskell syntax."
2583 _ ->
2584 setParsedPromptString fSetPrompt value
2585
2586 setParsedPromptString :: (PromptFunction -> GHCi ()) -> String -> GHCi ()
2587 setParsedPromptString fSetPrompt s = do
2588 case (checkPromptStringForErrors s) of
2589 Just err ->
2590 liftIO $ hPutStrLn stderr err
2591 Nothing ->
2592 fSetPrompt $ generatePromptFunctionFromString s
2593
2594 setOptions wds =
2595 do -- first, deal with the GHCi opts (+s, +t, etc.)
2596 let (plus_opts, minus_opts) = partitionWith isPlus wds
2597 mapM_ setOpt plus_opts
2598 -- then, dynamic flags
2599 when (not (null minus_opts)) $ newDynFlags False minus_opts
2600
2601 newDynFlags :: Bool -> [String] -> GHCi ()
2602 newDynFlags interactive_only minus_opts = do
2603 let lopts = map noLoc minus_opts
2604
2605 idflags0 <- GHC.getInteractiveDynFlags
2606 (idflags1, leftovers, warns) <- GHC.parseDynamicFlags idflags0 lopts
2607
2608 liftIO $ handleFlagWarnings idflags1 warns
2609 when (not $ null leftovers)
2610 (throwGhcException . CmdLineError
2611 $ "Some flags have not been recognized: "
2612 ++ (concat . intersperse ", " $ map unLoc leftovers))
2613
2614 when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do
2615 liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"
2616 GHC.setInteractiveDynFlags idflags1
2617 installInteractivePrint (interactivePrint idflags1) False
2618
2619 dflags0 <- getDynFlags
2620 when (not interactive_only) $ do
2621 (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags dflags0 lopts
2622 new_pkgs <- GHC.setProgramDynFlags dflags1
2623
2624 -- if the package flags changed, reset the context and link
2625 -- the new packages.
2626 hsc_env <- GHC.getSession
2627 let dflags2 = hsc_dflags hsc_env
2628 when (packageFlagsChanged dflags2 dflags0) $ do
2629 when (verbosity dflags2 > 0) $
2630 liftIO . putStrLn $
2631 "package flags have changed, resetting and loading new packages..."
2632 GHC.setTargets []
2633 _ <- GHC.load LoadAllTargets
2634 liftIO $ linkPackages hsc_env new_pkgs
2635 -- package flags changed, we can't re-use any of the old context
2636 setContextAfterLoad False []
2637 -- and copy the package state to the interactive DynFlags
2638 idflags <- GHC.getInteractiveDynFlags
2639 GHC.setInteractiveDynFlags
2640 idflags{ pkgState = pkgState dflags2
2641 , pkgDatabase = pkgDatabase dflags2
2642 , packageFlags = packageFlags dflags2 }
2643
2644 let ld0length = length $ ldInputs dflags0
2645 fmrk0length = length $ cmdlineFrameworks dflags0
2646
2647 newLdInputs = drop ld0length (ldInputs dflags2)
2648 newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2)
2649
2650 hsc_env' = hsc_env { hsc_dflags =
2651 dflags2 { ldInputs = newLdInputs
2652 , cmdlineFrameworks = newCLFrameworks } }
2653
2654 when (not (null newLdInputs && null newCLFrameworks)) $
2655 liftIO $ linkCmdLineLibs hsc_env'
2656
2657 return ()
2658
2659
2660 unsetOptions :: String -> GHCi ()
2661 unsetOptions str
2662 = -- first, deal with the GHCi opts (+s, +t, etc.)
2663 let opts = words str
2664 (minus_opts, rest1) = partition isMinus opts
2665 (plus_opts, rest2) = partitionWith isPlus rest1
2666 (other_opts, rest3) = partition (`elem` map fst defaulters) rest2
2667
2668 defaulters =
2669 [ ("args" , setArgs default_args)
2670 , ("prog" , setProg default_progname)
2671 , ("prompt" , setPrompt default_prompt)
2672 , ("prompt-cont", setPromptCont default_prompt_cont)
2673 , ("editor" , liftIO findEditor >>= setEditor)
2674 , ("stop" , setStop default_stop)
2675 ]
2676
2677 no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
2678 no_flag ('-':'X':rest) = return ("-XNo" ++ rest)
2679 no_flag f = throwGhcException (ProgramError ("don't know how to reverse " ++ f))
2680
2681 in if (not (null rest3))
2682 then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))
2683 else do
2684 mapM_ (fromJust.flip lookup defaulters) other_opts
2685
2686 mapM_ unsetOpt plus_opts
2687
2688 no_flags <- mapM no_flag minus_opts
2689 when (not (null no_flags)) $ newDynFlags False no_flags
2690
2691 isMinus :: String -> Bool
2692 isMinus ('-':_) = True
2693 isMinus _ = False
2694
2695 isPlus :: String -> Either String String
2696 isPlus ('+':opt) = Left opt
2697 isPlus other = Right other
2698
2699 setOpt, unsetOpt :: String -> GHCi ()
2700
2701 setOpt str
2702 = case strToGHCiOpt str of
2703 Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
2704 Just o -> setOption o
2705
2706 unsetOpt str
2707 = case strToGHCiOpt str of
2708 Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
2709 Just o -> unsetOption o
2710
2711 strToGHCiOpt :: String -> (Maybe GHCiOption)
2712 strToGHCiOpt "m" = Just Multiline
2713 strToGHCiOpt "s" = Just ShowTiming
2714 strToGHCiOpt "t" = Just ShowType
2715 strToGHCiOpt "r" = Just RevertCAFs
2716 strToGHCiOpt "c" = Just CollectInfo
2717 strToGHCiOpt _ = Nothing
2718
2719 optToStr :: GHCiOption -> String
2720 optToStr Multiline = "m"
2721 optToStr ShowTiming = "s"
2722 optToStr ShowType = "t"
2723 optToStr RevertCAFs = "r"
2724 optToStr CollectInfo = "c"
2725
2726
2727 -- ---------------------------------------------------------------------------
2728 -- :show
2729
2730 showCmd :: String -> GHCi ()
2731 showCmd "" = showOptions False
2732 showCmd "-a" = showOptions True
2733 showCmd str = do
2734 st <- getGHCiState
2735 dflags <- getDynFlags
2736
2737 let lookupCmd :: String -> Maybe (GHCi ())
2738 lookupCmd name = lookup name $ map (\(_,b,c) -> (b,c)) cmds
2739
2740 -- (show in help?, command name, action)
2741 action :: String -> GHCi () -> (Bool, String, GHCi ())
2742 action name m = (True, name, m)
2743
2744 hidden :: String -> GHCi () -> (Bool, String, GHCi ())
2745 hidden name m = (False, name, m)
2746
2747 cmds =
2748 [ action "args" $ liftIO $ putStrLn (show (GhciMonad.args st))
2749 , action "prog" $ liftIO $ putStrLn (show (progname st))
2750 , action "editor" $ liftIO $ putStrLn (show (editor st))
2751 , action "stop" $ liftIO $ putStrLn (show (stop st))
2752 , action "imports" $ showImports
2753 , action "modules" $ showModules
2754 , action "bindings" $ showBindings
2755 , action "linker" $ getDynFlags >>= liftIO . showLinkerState
2756 , action "breaks" $ showBkptTable
2757 , action "context" $ showContext
2758 , action "packages" $ showPackages
2759 , action "paths" $ showPaths
2760 , action "language" $ showLanguages
2761 , hidden "languages" $ showLanguages -- backwards compat
2762 , hidden "lang" $ showLanguages -- useful abbreviation
2763 ]
2764
2765 case words str of
2766 [w] | Just action <- lookupCmd w -> action
2767
2768 _ -> let helpCmds = [ text name | (True, name, _) <- cmds ]
2769 in throwGhcException $ CmdLineError $ showSDoc dflags
2770 $ hang (text "syntax:") 4
2771 $ hang (text ":show") 6
2772 $ brackets (fsep $ punctuate (text " |") helpCmds)
2773
2774 showiCmd :: String -> GHCi ()
2775 showiCmd str = do
2776 case words str of
2777 ["languages"] -> showiLanguages -- backwards compat
2778 ["language"] -> showiLanguages
2779 ["lang"] -> showiLanguages -- useful abbreviation
2780 _ -> throwGhcException (CmdLineError ("syntax: :showi language"))
2781
2782 showImports :: GHCi ()
2783 showImports = do
2784 st <- getGHCiState
2785 dflags <- getDynFlags
2786 let rem_ctx = reverse (remembered_ctx st)
2787 trans_ctx = transient_ctx st
2788
2789 show_one (IIModule star_m)
2790 = ":module +*" ++ moduleNameString star_m
2791 show_one (IIDecl imp) = showPpr dflags imp
2792
2793 prel_iidecls <- getImplicitPreludeImports (rem_ctx ++ trans_ctx)
2794
2795 let show_prel p = show_one p ++ " -- implicit"
2796 show_extra p = show_one (IIDecl p) ++ " -- fixed"
2797
2798 trans_comment s = s ++ " -- added automatically" :: String
2799 --
2800 liftIO $ mapM_ putStrLn (map show_one rem_ctx ++
2801 map (trans_comment . show_one) trans_ctx ++
2802 map show_prel prel_iidecls ++
2803 map show_extra (extra_imports st))
2804
2805 showModules :: GHCi ()
2806 showModules = do
2807 loaded_mods <- getLoadedModules
2808 -- we want *loaded* modules only, see #1734
2809 let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)
2810 mapM_ show_one loaded_mods
2811
2812 getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
2813 getLoadedModules = do
2814 graph <- GHC.getModuleGraph
2815 filterM (GHC.isLoaded . GHC.ms_mod_name) graph
2816
2817 showBindings :: GHCi ()
2818 showBindings = do
2819 bindings <- GHC.getBindings
2820 (insts, finsts) <- GHC.getInsts
2821 docs <- mapM makeDoc (reverse bindings)
2822 -- reverse so the new ones come last
2823 let idocs = map GHC.pprInstanceHdr insts
2824 fidocs = map GHC.pprFamInst finsts
2825 mapM_ printForUserPartWay (docs ++ idocs ++ fidocs)
2826 where
2827 makeDoc (AnId i) = pprTypeAndContents i
2828 makeDoc tt = do
2829 mb_stuff <- GHC.getInfo False (getName tt)
2830 return $ maybe (text "") pprTT mb_stuff
2831
2832 pprTT :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc
2833 pprTT (thing, fixity, _cls_insts, _fam_insts)
2834 = pprTyThing showToHeader thing
2835 $$ show_fixity
2836 where
2837 show_fixity
2838 | fixity == GHC.defaultFixity = empty
2839 | otherwise = ppr fixity <+> ppr (GHC.getName thing)
2840
2841
2842 printTyThing :: TyThing -> GHCi ()
2843 printTyThing tyth = printForUser (pprTyThing showToHeader tyth)
2844
2845 showBkptTable :: GHCi ()
2846 showBkptTable = do
2847 st <- getGHCiState
2848 printForUser $ prettyLocations (breaks st)
2849
2850 showContext :: GHCi ()
2851 showContext = do
2852 resumes <- GHC.getResumeContext
2853 printForUser $ vcat (map pp_resume (reverse resumes))
2854 where
2855 pp_resume res =
2856 ptext (sLit "--> ") <> text (GHC.resumeStmt res)
2857 $$ nest 2 (pprStopped res)
2858
2859 pprStopped :: GHC.Resume -> SDoc
2860 pprStopped res =
2861 ptext (sLit "Stopped in")
2862 <+> ((case mb_mod_name of
2863 Nothing -> empty
2864 Just mod_name -> text (moduleNameString mod_name) <> char '.')
2865 <> text (GHC.resumeDecl res))
2866 <> char ',' <+> ppr (GHC.resumeSpan res)
2867 where
2868 mb_mod_name = moduleName <$> GHC.breakInfo_module <$> GHC.resumeBreakInfo res
2869
2870 showPackages :: GHCi ()
2871 showPackages = do
2872 dflags <- getDynFlags
2873 let pkg_flags = packageFlags dflags
2874 liftIO $ putStrLn $ showSDoc dflags $
2875 text ("active package flags:"++if null pkg_flags then " none" else "") $$
2876 nest 2 (vcat (map pprFlag pkg_flags))
2877
2878 showPaths :: GHCi ()
2879 showPaths = do
2880 dflags <- getDynFlags
2881 liftIO $ do
2882 cwd <- getCurrentDirectory
2883 putStrLn $ showSDoc dflags $
2884 text "current working directory: " $$
2885 nest 2 (text cwd)
2886 let ipaths = importPaths dflags
2887 putStrLn $ showSDoc dflags $
2888 text ("module import search paths:"++if null ipaths then " none" else "") $$
2889 nest 2 (vcat (map text ipaths))
2890
2891 showLanguages :: GHCi ()
2892 showLanguages = getDynFlags >>= liftIO . showLanguages' False
2893
2894 showiLanguages :: GHCi ()
2895 showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False
2896
2897 showLanguages' :: Bool -> DynFlags -> IO ()
2898 showLanguages' show_all dflags =
2899 putStrLn $ showSDoc dflags $ vcat
2900 [ text "base language is: " <>
2901 case language dflags of
2902 Nothing -> text "Haskell2010"
2903 Just Haskell98 -> text "Haskell98"
2904 Just Haskell2010 -> text "Haskell2010"
2905 , (if show_all then text "all active language options:"
2906 else text "with the following modifiers:") $$
2907 nest 2 (vcat (map (setting xopt) DynFlags.xFlags))
2908 ]
2909 where
2910 setting test flag
2911 | quiet = empty
2912 | is_on = text "-X" <> text name
2913 | otherwise = text "-XNo" <> text name
2914 where name = flagSpecName flag
2915 f = flagSpecFlag flag
2916 is_on = test f dflags
2917 quiet = not show_all && test f default_dflags == is_on
2918
2919 default_dflags =
2920 defaultDynFlags (settings dflags) `lang_set`
2921 case language dflags of
2922 Nothing -> Just Haskell2010
2923 other -> other
2924
2925 -- -----------------------------------------------------------------------------
2926 -- Completion
2927
2928 completeCmd :: String -> GHCi ()
2929 completeCmd argLine0 = case parseLine argLine0 of
2930 Just ("repl", resultRange, left) -> do
2931 (unusedLine,compls) <- ghciCompleteWord (reverse left,"")
2932 let compls' = takeRange resultRange compls
2933 liftIO . putStrLn $ unwords [ show (length compls'), show (length compls), show (reverse unusedLine) ]
2934 forM_ (takeRange resultRange compls) $ \(Completion r _ _) -> do
2935 liftIO $ print r
2936 _ -> throwGhcException (CmdLineError "Syntax: :complete repl [<range>] <quoted-string-to-complete>")
2937 where
2938 parseLine argLine
2939 | null argLine = Nothing
2940 | null rest1 = Nothing
2941 | otherwise = (,,) dom <$> resRange <*> s
2942 where
2943 (dom, rest1) = breakSpace argLine
2944 (rng, rest2) = breakSpace rest1
2945 resRange | head rest1 == '"' = parseRange ""
2946 | otherwise = parseRange rng
2947 s | head rest1 == '"' = readMaybe rest1 :: Maybe String
2948 | otherwise = readMaybe rest2
2949 breakSpace = fmap (dropWhile isSpace) . break isSpace
2950
2951 takeRange (lb,ub) = maybe id (drop . pred) lb . maybe id take ub
2952
2953 -- syntax: [n-][m] with semantics "drop (n-1) . take m"
2954 parseRange :: String -> Maybe (Maybe Int,Maybe Int)
2955 parseRange s = case span isDigit s of
2956 (_, "") ->
2957 -- upper limit only
2958 Just (Nothing, bndRead s)
2959 (s1, '-' : s2)
2960 | all isDigit s2 ->
2961 Just (bndRead s1, bndRead s2)
2962 _ ->
2963 Nothing
2964 where
2965 bndRead x = if null x then Nothing else Just (read x)
2966
2967
2968
2969 completeGhciCommand, completeMacro, completeIdentifier, completeModule,
2970 completeSetModule, completeSeti, completeShowiOptions,
2971 completeHomeModule, completeSetOptions, completeShowOptions,
2972 completeHomeModuleOrFile, completeExpression
2973 :: CompletionFunc GHCi
2974
2975 -- | Provide completions for last word in a given string.
2976 --
2977 -- Takes a tuple of two strings. First string is a reversed line to be
2978 -- completed. Second string is likely unused, 'completeCmd' always passes an
2979 -- empty string as second item in tuple.
2980 ghciCompleteWord :: CompletionFunc GHCi
2981 ghciCompleteWord line@(left,_) = case firstWord of
2982 -- If given string starts with `:` colon, and there is only one following
2983 -- word then provide REPL command completions. If there is more than one
2984 -- word complete either filename or builtin ghci commands or macros.
2985 ':':cmd | null rest -> completeGhciCommand line
2986 | otherwise -> do
2987 completion <- lookupCompletion cmd
2988 completion line
2989 -- If given string starts with `import` keyword provide module name
2990 -- completions
2991 "import" -> completeModule line
2992 -- otherwise provide identifier completions
2993 _ -> completeExpression line
2994 where
2995 (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
2996 lookupCompletion ('!':_) = return completeFilename
2997 lookupCompletion c = do
2998 maybe_cmd <- lookupCommand' c
2999 case maybe_cmd of
3000 Just cmd -> return (cmdCompletionFunc cmd)
3001 Nothing -> return completeFilename
3002
3003 completeGhciCommand = wrapCompleter " " $ \w -> do
3004 macros <- ghci_macros <$> getGHCiState
3005 cmds <- ghci_commands `fmap` getGHCiState
3006 let macro_names = map (':':) . map cmdName $ macros
3007 let command_names = map (':':) . map cmdName $ filter (not . cmdHidden) cmds
3008 let{ candidates = case w of
3009 ':' : ':' : _ -> map (':':) command_names
3010 _ -> nub $ macro_names ++ command_names }
3011 return $ filter (w `isPrefixOf`) candidates
3012
3013 completeMacro = wrapIdentCompleter $ \w -> do
3014 cmds <- ghci_macros <$> getGHCiState
3015 return (filter (w `isPrefixOf`) (map cmdName cmds))
3016
3017 completeIdentifier line@(left, _) =
3018 -- Note: `left` is a reversed input
3019 case left of
3020 (x:_) | isSymbolChar x -> wrapCompleter (specials ++ spaces) complete line
3021 _ -> wrapIdentCompleter complete line
3022 where
3023 complete w = do
3024 rdrs <- GHC.getRdrNamesInScope
3025 dflags <- GHC.getSessionDynFlags
3026 return (filter (w `isPrefixOf`) (map (showPpr dflags) rdrs))
3027
3028 completeModule = wrapIdentCompleter $ \w -> do
3029 dflags <- GHC.getSessionDynFlags
3030 let pkg_mods = allVisibleModules dflags
3031 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
3032 return $ filter (w `isPrefixOf`)
3033 $ map (showPpr dflags) $ loaded_mods ++ pkg_mods
3034
3035 completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
3036 dflags <- GHC.getSessionDynFlags
3037 modules <- case m of
3038 Just '-' -> do
3039 imports <- GHC.getContext
3040 return $ map iiModuleName imports
3041 _ -> do
3042 let pkg_mods = allVisibleModules dflags
3043 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
3044 return $ loaded_mods ++ pkg_mods
3045 return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules
3046
3047 completeHomeModule = wrapIdentCompleter listHomeModules
3048
3049 listHomeModules :: String -> GHCi [String]
3050 listHomeModules w = do
3051 g <- GHC.getModuleGraph
3052 let home_mods = map GHC.ms_mod_name g
3053 dflags <- getDynFlags
3054 return $ sort $ filter (w `isPrefixOf`)
3055 $ map (showPpr dflags) home_mods
3056
3057 completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
3058 return (filter (w `isPrefixOf`) opts)
3059 where opts = "args":"prog":"prompt":"prompt-cont":"prompt-function":
3060 "prompt-cont-function":"editor":"stop":flagList
3061 flagList = map head $ group $ sort allNonDeprecatedFlags
3062
3063 completeSeti = wrapCompleter flagWordBreakChars $ \w -> do
3064 return (filter (w `isPrefixOf`) flagList)
3065 where flagList = map head $ group $ sort allNonDeprecatedFlags
3066
3067 completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
3068 return (filter (w `isPrefixOf`) opts)
3069 where opts = ["args", "prog", "editor", "stop",
3070 "modules", "bindings", "linker", "breaks",
3071 "context", "packages", "paths", "language", "imports"]
3072
3073 completeShowiOptions = wrapCompleter flagWordBreakChars $ \w -> do
3074 return (filter (w `isPrefixOf`) ["language"])
3075
3076 completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
3077 $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
3078 listFiles
3079
3080 unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
3081 unionComplete f1 f2 line = do
3082 cs1 <- f1 line
3083 cs2 <- f2 line
3084 return (cs1 ++ cs2)
3085
3086 wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
3087 wrapCompleter breakChars fun = completeWord Nothing breakChars
3088 $ fmap (map simpleCompletion . nubSort) . fun
3089
3090 wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
3091 wrapIdentCompleter = wrapCompleter word_break_chars
3092
3093 wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi
3094 wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars
3095 $ \rest -> fmap (map simpleCompletion . nubSort) . fun (getModifier rest)
3096 where
3097 getModifier = find (`elem` modifChars)
3098
3099 -- | Return a list of visible module names for autocompletion.
3100 -- (NB: exposed != visible)
3101 allVisibleModules :: DynFlags -> [ModuleName]
3102 allVisibleModules dflags = listVisibleModuleNames dflags
3103
3104 completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
3105 completeIdentifier
3106
3107
3108 -- -----------------------------------------------------------------------------
3109 -- commands for debugger
3110
3111 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
3112 sprintCmd = pprintCommand False False
3113 printCmd = pprintCommand True False
3114 forceCmd = pprintCommand False True
3115
3116 pprintCommand :: Bool -> Bool -> String -> GHCi ()
3117 pprintCommand bind force str = do
3118 pprintClosureCommand bind force str
3119
3120 stepCmd :: String -> GHCi ()
3121 stepCmd arg = withSandboxOnly ":step" $ step arg
3122 where
3123 step [] = doContinue (const True) GHC.SingleStep
3124 step expression = runStmt expression GHC.SingleStep >> return ()
3125
3126 stepLocalCmd :: String -> GHCi ()
3127 stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg
3128 where
3129 step expr
3130 | not (null expr) = stepCmd expr
3131 | otherwise = do
3132 mb_span <- getCurrentBreakSpan
3133 case mb_span of
3134 Nothing -> stepCmd []
3135 Just loc -> do
3136 Just md <- getCurrentBreakModule
3137 current_toplevel_decl <- enclosingTickSpan md loc
3138 doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl) GHC.SingleStep
3139
3140 stepModuleCmd :: String -> GHCi ()
3141 stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg
3142 where
3143 step expr
3144 | not (null expr) = stepCmd expr
3145 | otherwise = do
3146 mb_span <- getCurrentBreakSpan
3147 case mb_span of
3148 Nothing -> stepCmd []
3149 Just pan -> do
3150 let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span
3151 doContinue f GHC.SingleStep
3152
3153 -- | Returns the span of the largest tick containing the srcspan given
3154 enclosingTickSpan :: Module -> SrcSpan -> GHCi RealSrcSpan
3155 enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
3156 enclosingTickSpan md (RealSrcSpan src) = do
3157 ticks <- getTickArray md
3158 let line = srcSpanStartLine src
3159 ASSERT(inRange (bounds ticks) line) do
3160 let enclosing_spans = [ pan | (_,pan) <- ticks ! line
3161 , realSrcSpanEnd pan >= realSrcSpanEnd src]
3162 return . head . sortBy leftmostLargestRealSrcSpan $ enclosing_spans
3163 where
3164
3165 leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering
3166 leftmostLargestRealSrcSpan a b =
3167 (realSrcSpanStart a `compare` realSrcSpanStart b)
3168 `thenCmp`
3169 (realSrcSpanEnd b `compare` realSrcSpanEnd a)
3170
3171 traceCmd :: String -> GHCi ()
3172 traceCmd arg
3173 = withSandboxOnly ":trace" $ tr arg
3174 where
3175 tr [] = doContinue (const True) GHC.RunAndLogSteps
3176 tr expression = runStmt expression GHC.RunAndLogSteps >> return ()
3177
3178 continueCmd :: String -> GHCi ()
3179 continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion
3180
3181 -- doContinue :: SingleStep -> GHCi ()
3182 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
3183 doContinue pre step = do
3184 runResult <- resume pre step
3185 _ <- afterRunStmt pre runResult
3186 return ()
3187
3188 abandonCmd :: String -> GHCi ()
3189 abandonCmd = noArgs $ withSandboxOnly ":abandon" $ do
3190 b <- GHC.abandon -- the prompt will change to indicate the new context
3191 when (not b) $ liftIO $ putStrLn "There is no computation running."
3192
3193 deleteCmd :: String -> GHCi ()
3194 deleteCmd argLine = withSandboxOnly ":delete" $ do
3195 deleteSwitch $ words argLine
3196 where
3197 deleteSwitch :: [String] -> GHCi ()
3198 deleteSwitch [] =
3199 liftIO $ putStrLn "The delete command requires at least one argument."
3200 -- delete all break points
3201 deleteSwitch ("*":_rest) = discardActiveBreakPoints
3202 deleteSwitch idents = do
3203 mapM_ deleteOneBreak idents
3204 where
3205 deleteOneBreak :: String -> GHCi ()
3206 deleteOneBreak str
3207 | all isDigit str = deleteBreak (read str)
3208 | otherwise = return ()
3209
3210 historyCmd :: String -> GHCi ()
3211 historyCmd arg
3212 | null arg = history 20
3213 | all isDigit arg = history (read arg)
3214 | otherwise = liftIO $ putStrLn "Syntax: :history [num]"
3215 where
3216 history num = do
3217 resumes <- GHC.getResumeContext
3218 case resumes of
3219 [] -> liftIO $ putStrLn "Not stopped at a breakpoint"
3220 (r:_) -> do
3221 let hist = GHC.resumeHistory r
3222 (took,rest) = splitAt num hist
3223 case hist of
3224 [] -> liftIO $ putStrLn $
3225 "Empty history. Perhaps you forgot to use :trace?"
3226 _ -> do
3227 pans <- mapM GHC.getHistorySpan took
3228 let nums = map (printf "-%-3d:") [(1::Int)..]
3229 names = map GHC.historyEnclosingDecls took
3230 printForUser (vcat(zipWith3
3231 (\x y z -> x <+> y <+> z)
3232 (map text nums)
3233 (map (bold . hcat . punctuate colon . map text) names)
3234 (map (parens . ppr) pans)))
3235 liftIO $ putStrLn $ if null rest then "<end of history>" else "..."
3236
3237 bold :: SDoc -> SDoc
3238 bold c | do_bold = text start_bold <> c <> text end_bold
3239 | otherwise = c
3240
3241 backCmd :: String -> GHCi ()
3242 backCmd arg
3243 | null arg = back 1
3244 | all isDigit arg = back (read arg)
3245 | otherwise = liftIO $ putStrLn "Syntax: :back [num]"
3246 where
3247 back num = withSandboxOnly ":back" $ do
3248 (names, _, pan, _) <- GHC.back num
3249 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan
3250 printTypeOfNames names
3251 -- run the command set with ":set stop <cmd>"
3252 st <- getGHCiState
3253 enqueueCommands [stop st]
3254
3255 forwardCmd :: String -> GHCi ()
3256 forwardCmd arg
3257 | null arg = forward 1
3258 | all isDigit arg = forward (read arg)
3259 | otherwise = liftIO $ putStrLn "Syntax: :back [num]"
3260 where
3261 forward num = withSandboxOnly ":forward" $ do
3262 (names, ix, pan, _) <- GHC.forward num
3263 printForUser $ (if (ix == 0)
3264 then ptext (sLit "Stopped at")
3265 else ptext (sLit "Logged breakpoint at")) <+> ppr pan
3266 printTypeOfNames names
3267 -- run the command set with ":set stop <cmd>"
3268 st <- getGHCiState
3269 enqueueCommands [stop st]
3270
3271 -- handle the "break" command
3272 breakCmd :: String -> GHCi ()
3273 breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine
3274
3275 breakSwitch :: [String] -> GHCi ()
3276 breakSwitch [] = do
3277 liftIO $ putStrLn "The break command requires at least one argument."
3278 breakSwitch (arg1:rest)
3279 | looksLikeModuleName arg1 && not (null rest) = do
3280 md <- wantInterpretedModule arg1
3281 breakByModule md rest
3282 | all isDigit arg1 = do
3283 imports <- GHC.getContext
3284 case iiModules imports of
3285 (mn : _) -> do
3286 md <- lookupModuleName mn
3287 breakByModuleLine md (read arg1) rest
3288 [] -> do
3289 liftIO $ putStrLn "No modules are loaded with debugging support."
3290 | otherwise = do -- try parsing it as an identifier
3291 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
3292 maybe_info <- GHC.getModuleInfo (GHC.nameModule name)
3293 case maybe_info of
3294 Nothing -> noCanDo name (ptext (sLit "cannot get module info"))
3295 Just minf ->
3296 ASSERT( isExternalName name )
3297 findBreakAndSet (GHC.nameModule name) $
3298 findBreakForBind name (GHC.modInfoModBreaks minf)
3299 where
3300 noCanDo n why = printForUser $
3301 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
3302
3303 breakByModule :: Module -> [String] -> GHCi ()
3304 breakByModule md (arg1:rest)
3305 | all isDigit arg1 = do -- looks like a line number
3306 breakByModuleLine md (read arg1) rest
3307 breakByModule _ _
3308 = breakSyntax
3309
3310 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
3311 breakByModuleLine md line args
3312 | [] <- args = findBreakAndSet md $ maybeToList . findBreakByLine line
3313 | [col] <- args, all isDigit col =
3314 findBreakAndSet md $ maybeToList . findBreakByCoord Nothing (line, read col)
3315 | otherwise = breakSyntax
3316
3317 breakSyntax :: a
3318 breakSyntax = throwGhcException (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
3319
3320 findBreakAndSet :: Module -> (TickArray -> [(Int, RealSrcSpan)]) -> GHCi ()
3321 findBreakAndSet md lookupTickTree = do
3322 tickArray <- getTickArray md
3323 (breakArray, _) <- getModBreak md
3324 case lookupTickTree tickArray of
3325 [] -> liftIO $ putStrLn $ "No breakpoints found at that location."
3326 some -> mapM_ (breakAt breakArray) some
3327 where
3328 breakAt breakArray (tick, pan) = do
3329 setBreakFlag True breakArray tick
3330 (alreadySet, nm) <-
3331 recordBreak $ BreakLocation
3332 { breakModule = md
3333 , breakLoc = RealSrcSpan pan
3334 , breakTick = tick
3335 , onBreakCmd = ""
3336 }
3337 printForUser $
3338 text "Breakpoint " <> ppr nm <>
3339 if alreadySet
3340 then text " was already set at " <> ppr pan
3341 else text " activated at " <> ppr pan
3342
3343 -- When a line number is specified, the current policy for choosing
3344 -- the best breakpoint is this:
3345 -- - the leftmost complete subexpression on the specified line, or
3346 -- - the leftmost subexpression starting on the specified line, or
3347 -- - the rightmost subexpression enclosing the specified line
3348 --
3349 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,RealSrcSpan)
3350 findBreakByLine line arr
3351 | not (inRange (bounds arr) line) = Nothing
3352 | otherwise =
3353 listToMaybe (sortBy (leftmostLargestRealSrcSpan `on` snd) comp) `mplus`
3354 listToMaybe (sortBy (compare `on` snd) incomp) `mplus`
3355 listToMaybe (sortBy (flip compare `on` snd) ticks)
3356 where
3357 ticks = arr ! line
3358
3359 starts_here = [ (ix,pan) | (ix, pan) <- ticks,
3360 GHC.srcSpanStartLine pan == line ]
3361
3362 (comp, incomp) = partition ends_here starts_here
3363 where ends_here (_,pan) = GHC.srcSpanEndLine pan == line
3364
3365 -- The aim is to find the breakpoints for all the RHSs of the
3366 -- equations corresponding to a binding. So we find all breakpoints
3367 -- for
3368 -- (a) this binder only (not a nested declaration)
3369 -- (b) that do not have an enclosing breakpoint
3370 findBreakForBind :: Name -> GHC.ModBreaks -> TickArray
3371 -> [(BreakIndex,RealSrcSpan)]
3372 findBreakForBind name modbreaks _ = filter (not . enclosed) ticks
3373 where
3374 ticks = [ (index, span)
3375 | (index, [n]) <- assocs (GHC.modBreaks_decls modbreaks),
3376 n == occNameString (nameOccName name),
3377 RealSrcSpan span <- [GHC.modBreaks_locs modbreaks ! index] ]
3378 enclosed (_,sp0) = any subspan ticks
3379 where subspan (_,sp) = sp /= sp0 &&
3380 realSrcSpanStart sp <= realSrcSpanStart sp0 &&
3381 realSrcSpanEnd sp0 <= realSrcSpanEnd sp
3382
3383 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
3384 -> Maybe (BreakIndex,RealSrcSpan)
3385 findBreakByCoord mb_file (line, col) arr
3386 | not (inRange (bounds arr) line) = Nothing
3387 | otherwise =
3388 listToMaybe (sortBy (flip compare `on` snd) contains ++
3389 sortBy (compare `on` snd) after_here)
3390 where
3391 ticks = arr ! line
3392
3393 -- the ticks that span this coordinate
3394 contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan `spans` (line,col),
3395 is_correct_file pan ]
3396
3397 is_correct_file pan
3398 | Just f <- mb_file = GHC.srcSpanFile pan == f
3399 | otherwise = True
3400
3401 after_here = [ tick | tick@(_,pan) <- ticks,
3402 GHC.srcSpanStartLine pan == line,
3403 GHC.srcSpanStartCol pan >= col ]
3404
3405 -- For now, use ANSI bold on terminals that we know support it.
3406 -- Otherwise, we add a line of carets under the active expression instead.
3407 -- In particular, on Windows and when running the testsuite (which sets
3408 -- TERM to vt100 for other reasons) we get carets.
3409 -- We really ought to use a proper termcap/terminfo library.
3410 do_bold :: Bool
3411 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
3412 where mTerm = System.Environment.getEnv "TERM"
3413 `catchIO` \_ -> return "TERM not set"
3414
3415 start_bold :: String
3416 start_bold = "\ESC[1m"
3417 end_bold :: String
3418 end_bold = "\ESC[0m"
3419
3420 -----------------------------------------------------------------------------
3421 -- :where
3422
3423 whereCmd :: String -> GHCi ()
3424 whereCmd = noArgs $ do
3425 mstrs <- getCallStackAtCurrentBreakpoint
3426 case mstrs of
3427 Nothing -> return ()
3428 Just strs -> liftIO $ putStrLn (renderStack strs)
3429
3430 -----------------------------------------------------------------------------
3431 -- :list
3432
3433 listCmd :: String -> InputT GHCi ()
3434 listCmd c = listCmd' c
3435
3436 listCmd' :: String -> InputT GHCi ()
3437 listCmd' "" = do
3438 mb_span <- lift getCurrentBreakSpan
3439 case mb_span of
3440 Nothing ->
3441 printForUser $ text "Not stopped at a breakpoint; nothing to list"
3442 Just (RealSrcSpan pan) ->
3443 listAround pan True
3444 Just pan@(UnhelpfulSpan _) ->
3445 do resumes <- GHC.getResumeContext
3446 case resumes of
3447 [] -> panic "No resumes"
3448 (r:_) ->
3449 do let traceIt = case GHC.resumeHistory r of
3450 [] -> text "rerunning with :trace,"
3451 _ -> empty
3452 doWhat = traceIt <+> text ":back then :list"
3453 printForUser (text "Unable to list source for" <+>
3454 ppr pan
3455 $$ text "Try" <+> doWhat)
3456 listCmd' str = list2 (words str)
3457
3458 list2 :: [String] -> InputT GHCi ()
3459 list2 [arg] | all isDigit arg = do
3460 imports <- GHC.getContext
3461 case iiModules imports of
3462 [] -> liftIO $ putStrLn "No module to list"
3463 (mn : _) -> do
3464 md <- lift $ lookupModuleName mn
3465 listModuleLine md (read arg)
3466 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
3467 md <- wantInterpretedModule arg1
3468 listModuleLine md (read arg2)
3469 list2 [arg] = do
3470 wantNameFromInterpretedModule noCanDo arg $ \name -> do
3471 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
3472 case loc of
3473 RealSrcLoc l ->
3474 do tickArray <- ASSERT( isExternalName name )
3475 lift $ getTickArray (GHC.nameModule name)
3476 let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))
3477 (GHC.srcLocLine l, GHC.srcLocCol l)
3478 tickArray
3479 case mb_span of
3480 Nothing -> listAround (realSrcLocSpan l) False
3481 Just (_, pan) -> listAround pan False
3482 UnhelpfulLoc _ ->
3483 noCanDo name $ text "can't find its location: " <>
3484 ppr loc
3485 where
3486 noCanDo n why = printForUser $
3487 text "cannot list source code for " <> ppr n <> text ": " <> why
3488 list2 _other =
3489 liftIO $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
3490
3491 listModuleLine :: Module -> Int -> InputT GHCi ()
3492 listModuleLine modl line = do
3493 graph <- GHC.getModuleGraph
3494 let this = filter ((== modl) . GHC.ms_mod) graph
3495 case this of
3496 [] -> panic "listModuleLine"
3497 summ:_ -> do
3498 let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
3499 loc = mkRealSrcLoc (mkFastString (filename)) line 0
3500 listAround (realSrcLocSpan loc) False
3501
3502 -- | list a section of a source file around a particular SrcSpan.
3503 -- If the highlight flag is True, also highlight the span using
3504 -- start_bold\/end_bold.
3505
3506 -- GHC files are UTF-8, so we can implement this by:
3507 -- 1) read the file in as a BS and syntax highlight it as before
3508 -- 2) convert the BS to String using utf-string, and write it out.
3509 -- It would be better if we could convert directly between UTF-8 and the
3510 -- console encoding, of course.
3511 listAround :: MonadIO m => RealSrcSpan -> Bool -> InputT m ()
3512 listAround pan do_highlight = do
3513 contents <- liftIO $ BS.readFile (unpackFS file)
3514 -- Drop carriage returns to avoid duplicates, see #9367.
3515 let ls = BS.split '\n' $ BS.filter (/= '\r') contents
3516 ls' = take (line2 - line1 + 1 + pad_before + pad_after) $
3517 drop (line1 - 1 - pad_before) $ ls
3518 fst_line = max 1 (line1 - pad_before)
3519 line_nos = [ fst_line .. ]
3520
3521 highlighted | do_highlight = zipWith highlight line_nos ls'
3522 | otherwise = [\p -> BS.concat[p,l] | l <- ls']
3523
3524 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
3525 prefixed = zipWith ($) highlighted bs_line_nos
3526 output = BS.intercalate (BS.pack "\n") prefixed
3527
3528 utf8Decoded <- liftIO $ BS.useAsCStringLen output
3529 $ \(p,n) -> utf8DecodeString (castPtr p) n
3530 liftIO $ putStrLn utf8Decoded
3531 where
3532 file = GHC.srcSpanFile pan
3533 line1 = GHC.srcSpanStartLine pan
3534 col1 = GHC.srcSpanStartCol pan - 1
3535 line2 = GHC.srcSpanEndLine pan
3536 col2 = GHC.srcSpanEndCol pan - 1
3537
3538 pad_before | line1 == 1 = 0
3539 | otherwise = 1
3540 pad_after = 1
3541
3542 highlight | do_bold = highlight_bold
3543 | otherwise = highlight_carets
3544
3545 highlight_bold no line prefix
3546 | no == line1 && no == line2
3547 = let (a,r) = BS.splitAt col1 line
3548 (b,c) = BS.splitAt (col2-col1) r
3549 in
3550 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
3551 | no == line1
3552 = let (a,b) = BS.splitAt col1 line in
3553 BS.concat [prefix, a, BS.pack start_bold, b]
3554 | no == line2
3555 = let (a,b) = BS.splitAt col2 line in
3556 BS.concat [prefix, a, BS.pack end_bold, b]
3557 | otherwise = BS.concat [prefix, line]
3558
3559 highlight_carets no line prefix
3560 | no == line1 && no == line2
3561 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
3562 BS.replicate (col2-col1) '^']
3563 | no == line1
3564 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
3565 prefix, line]
3566 | no == line2
3567 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
3568 BS.pack "^^"]
3569 | otherwise = BS.concat [prefix, line]
3570 where
3571 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
3572 nl = BS.singleton '\n'
3573
3574
3575 -- --------------------------------------------------------------------------
3576 -- Tick arrays
3577
3578 getTickArray :: Module -> GHCi TickArray
3579 getTickArray modl = do
3580 st <- getGHCiState
3581 let arrmap = tickarrays st
3582 case lookupModuleEnv arrmap modl of
3583 Just arr -> return arr
3584 Nothing -> do
3585 (_breakArray, ticks) <- getModBreak modl
3586 let arr = mkTickArray (assocs ticks)
3587 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
3588 return arr
3589
3590 discardTickArrays :: GHCi ()
3591 discardTickArrays = modifyGHCiState (\st -> st {tickarrays = emptyModuleEnv})
3592
3593 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
3594 mkTickArray ticks
3595 = accumArray (flip (:)) [] (1, max_line)
3596 [ (line, (nm,pan)) | (nm,RealSrcSpan pan) <- ticks, line <- srcSpanLines pan ]
3597 where
3598 max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp) <- ticks ]
3599 srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ]
3600
3601 -- don't reset the counter back to zero?
3602 discardActiveBreakPoints :: GHCi ()
3603 discardActiveBreakPoints = do
3604 st <- getGHCiState
3605 mapM_ (turnOffBreak.snd) (breaks st)
3606 setGHCiState $ st { breaks = [] }
3607
3608 deleteBreak :: Int -> GHCi ()
3609 deleteBreak identity = do
3610 st <- getGHCiState
3611 let oldLocations = breaks st
3612 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
3613 if null this
3614 then printForUser (text "Breakpoint" <+> ppr identity <+>
3615 text "does not exist")
3616 else do
3617 mapM_ (turnOffBreak.snd) this
3618 setGHCiState $ st { breaks = rest }
3619
3620 turnOffBreak :: BreakLocation -> GHCi ()
3621 turnOffBreak loc = do
3622 (arr, _) <- getModBreak (breakModule loc)
3623 hsc_env <- GHC.getSession
3624 liftIO $ enableBreakpoint hsc_env arr (breakTick loc) False
3625
3626 getModBreak :: Module -> GHCi (ForeignRef BreakArray, Array Int SrcSpan)
3627 getModBreak m = do
3628 Just mod_info <- GHC.getModuleInfo m
3629 let modBreaks = GHC.modInfoModBreaks mod_info
3630 let arr = GHC.modBreaks_flags modBreaks
3631 let ticks = GHC.modBreaks_locs modBreaks
3632 return (arr, ticks)
3633
3634 setBreakFlag :: Bool -> ForeignRef BreakArray -> Int -> GHCi ()
3635 setBreakFlag toggle arr i = do
3636 hsc_env <- GHC.getSession
3637 liftIO $ enableBreakpoint hsc_env arr i toggle
3638
3639 -- ---------------------------------------------------------------------------
3640 -- User code exception handling
3641
3642 -- This is the exception handler for exceptions generated by the
3643 -- user's code and exceptions coming from children sessions;
3644 -- it normally just prints out the exception. The
3645 -- handler must be recursive, in case showing the exception causes
3646 -- more exceptions to be raised.
3647 --
3648 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
3649 -- raising another exception. We therefore don't put the recursive
3650 -- handler arond the flushing operation, so if stderr is closed
3651 -- GHCi will just die gracefully rather than going into an infinite loop.
3652 handler :: SomeException -> GHCi Bool
3653
3654 handler exception = do
3655 flushInterpBuffers
3656 withSignalHandlers $
3657 ghciHandle handler (showException exception >> return False)
3658
3659 showException :: SomeException -> GHCi ()
3660 showException se =
3661 liftIO $ case fromException se of
3662 -- omit the location for CmdLineError:
3663 Just (CmdLineError s) -> putException s
3664 -- ditto:
3665 Just other_ghc_ex -> putException (show other_ghc_ex)
3666 Nothing ->
3667 case fromException se of
3668 Just UserInterrupt -> putException "Interrupted."
3669 _ -> putException ("*** Exception: " ++ show se)
3670 where
3671 putException = hPutStrLn stderr
3672
3673
3674 -----------------------------------------------------------------------------
3675 -- recursive exception handlers
3676
3677 -- Don't forget to unblock async exceptions in the handler, or if we're
3678 -- in an exception loop (eg. let a = error a in a) the ^C exception
3679 -- may never be delivered. Thanks to Marcin for pointing out the bug.
3680
3681 ghciHandle :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a
3682 ghciHandle h m = gmask $ \restore -> do
3683 -- Force dflags to avoid leaking the associated HscEnv
3684 !dflags <- getDynFlags
3685 gcatch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e)
3686
3687 ghciTry :: GHCi a -> GHCi (Either SomeException a)
3688 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
3689
3690 tryBool :: GHCi a -> GHCi Bool
3691 tryBool m = do
3692 r <- ghciTry m
3693 case r of
3694 Left _ -> return False
3695 Right _ -> return True
3696
3697 -- ----------------------------------------------------------------------------
3698 -- Utils
3699
3700 lookupModule :: GHC.GhcMonad m => String -> m Module
3701 lookupModule mName = lookupModuleName (GHC.mkModuleName mName)
3702
3703 lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module
3704 lookupModuleName mName = GHC.lookupModule mName Nothing
3705
3706 isHomeModule :: Module -> Bool
3707 isHomeModule m = GHC.moduleUnitId m == mainUnitId
3708
3709 -- TODO: won't work if home dir is encoded.
3710 -- (changeDirectory may not work either in that case.)
3711 expandPath :: MonadIO m => String -> InputT m String
3712 expandPath = liftIO . expandPathIO
3713
3714 expandPathIO :: String -> IO String
3715 expandPathIO p =
3716 case dropWhile isSpace p of
3717 ('~':d) -> do
3718 tilde <- getHomeDirectory -- will fail if HOME not defined
3719 return (tilde ++ '/':d)
3720 other ->
3721 return other
3722
3723 wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
3724 wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str)
3725
3726 wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module
3727 wantInterpretedModuleName modname = do
3728 modl <- lookupModuleName modname
3729 let str = moduleNameString modname
3730 dflags <- getDynFlags
3731 when (GHC.moduleUnitId modl /= thisPackage dflags) $
3732 throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
3733 is_interpreted <- GHC.moduleIsInterpreted modl
3734 when (not is_interpreted) $
3735 throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
3736 return modl
3737
3738 wantNameFromInterpretedModule :: GHC.GhcMonad m
3739 => (Name -> SDoc -> m ())
3740 -> String
3741 -> (Name -> m ())
3742 -> m ()
3743 wantNameFromInterpretedModule noCanDo str and_then =
3744 handleSourceError GHC.printException $ do
3745 names <- GHC.parseName str
3746 case names of
3747 [] -> return ()
3748 (n:_) -> do
3749 let modl = ASSERT( isExternalName n ) GHC.nameModule n
3750 if not (GHC.isExternalName n)
3751 then noCanDo n $ ppr n <>
3752 text " is not defined in an interpreted module"
3753 else do
3754 is_interpreted <- GHC.moduleIsInterpreted modl
3755 if not is_interpreted
3756 then noCanDo n $ text "module " <> ppr modl <>
3757 text " is not interpreted"
3758 else and_then n