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