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