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