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