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