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