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