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