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