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