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