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