Allow 'default' declarations in GHCi
[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 liftIO $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
2039 GHC.setTargets []
2040 _ <- GHC.load LoadAllTargets
2041 liftIO $ linkPackages dflags2 new_pkgs
2042 -- package flags changed, we can't re-use any of the old context
2043 setContextAfterLoad False []
2044 -- and copy the package state to the interactive DynFlags
2045 idflags <- GHC.getInteractiveDynFlags
2046 GHC.setInteractiveDynFlags
2047 idflags{ pkgState = pkgState dflags2
2048 , pkgDatabase = pkgDatabase dflags2
2049 , packageFlags = packageFlags dflags2 }
2050
2051 return ()
2052
2053
2054 unsetOptions :: String -> GHCi ()
2055 unsetOptions str
2056 = -- first, deal with the GHCi opts (+s, +t, etc.)
2057 let opts = words str
2058 (minus_opts, rest1) = partition isMinus opts
2059 (plus_opts, rest2) = partitionWith isPlus rest1
2060 (other_opts, rest3) = partition (`elem` map fst defaulters) rest2
2061
2062 defaulters =
2063 [ ("args" , setArgs default_args)
2064 , ("prog" , setProg default_progname)
2065 , ("prompt", setPrompt Nothing)
2066 , ("editor", liftIO findEditor >>= setEditor)
2067 , ("stop" , setStop default_stop)
2068 ]
2069
2070 no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
2071 no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
2072
2073 in if (not (null rest3))
2074 then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))
2075 else do
2076 mapM_ (fromJust.flip lookup defaulters) other_opts
2077
2078 mapM_ unsetOpt plus_opts
2079
2080 no_flags <- mapM no_flag minus_opts
2081 newDynFlags False no_flags
2082
2083 isMinus :: String -> Bool
2084 isMinus ('-':_) = True
2085 isMinus _ = False
2086
2087 isPlus :: String -> Either String String
2088 isPlus ('+':opt) = Left opt
2089 isPlus other = Right other
2090
2091 setOpt, unsetOpt :: String -> GHCi ()
2092
2093 setOpt str
2094 = case strToGHCiOpt str of
2095 Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
2096 Just o -> setOption o
2097
2098 unsetOpt str
2099 = case strToGHCiOpt str of
2100 Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
2101 Just o -> unsetOption o
2102
2103 strToGHCiOpt :: String -> (Maybe GHCiOption)
2104 strToGHCiOpt "m" = Just Multiline
2105 strToGHCiOpt "s" = Just ShowTiming
2106 strToGHCiOpt "t" = Just ShowType
2107 strToGHCiOpt "r" = Just RevertCAFs
2108 strToGHCiOpt _ = Nothing
2109
2110 optToStr :: GHCiOption -> String
2111 optToStr Multiline = "m"
2112 optToStr ShowTiming = "s"
2113 optToStr ShowType = "t"
2114 optToStr RevertCAFs = "r"
2115
2116
2117 -- ---------------------------------------------------------------------------
2118 -- :show
2119
2120 showCmd :: String -> GHCi ()
2121 showCmd "" = showOptions False
2122 showCmd "-a" = showOptions True
2123 showCmd str = do
2124 st <- getGHCiState
2125 case words str of
2126 ["args"] -> liftIO $ putStrLn (show (GhciMonad.args st))
2127 ["prog"] -> liftIO $ putStrLn (show (progname st))
2128 ["prompt"] -> liftIO $ putStrLn (show (prompt st))
2129 ["editor"] -> liftIO $ putStrLn (show (editor st))
2130 ["stop"] -> liftIO $ putStrLn (show (stop st))
2131 ["imports"] -> showImports
2132 ["modules" ] -> showModules
2133 ["bindings"] -> showBindings
2134 ["linker"] ->
2135 do dflags <- getDynFlags
2136 liftIO $ showLinkerState dflags
2137 ["breaks"] -> showBkptTable
2138 ["context"] -> showContext
2139 ["packages"] -> showPackages
2140 ["languages"] -> showLanguages -- backwards compat
2141 ["language"] -> showLanguages
2142 ["lang"] -> showLanguages -- useful abbreviation
2143 _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
2144 " | breaks | context | packages | language ]"))
2145
2146 showiCmd :: String -> GHCi ()
2147 showiCmd str = do
2148 case words str of
2149 ["languages"] -> showiLanguages -- backwards compat
2150 ["language"] -> showiLanguages
2151 ["lang"] -> showiLanguages -- useful abbreviation
2152 _ -> ghcError (CmdLineError ("syntax: :showi language"))
2153
2154 showImports :: GHCi ()
2155 showImports = do
2156 st <- getGHCiState
2157 dflags <- getDynFlags
2158 let rem_ctx = reverse (remembered_ctx st)
2159 trans_ctx = transient_ctx st
2160
2161 show_one (IIModule star_m)
2162 = ":module +*" ++ moduleNameString star_m
2163 show_one (IIDecl imp) = showPpr dflags imp
2164
2165 prel_imp
2166 | any isPreludeImport (rem_ctx ++ trans_ctx) = []
2167 | otherwise = ["import Prelude -- implicit"]
2168
2169 trans_comment s = s ++ " -- added automatically"
2170 --
2171 liftIO $ mapM_ putStrLn (prel_imp ++ map show_one rem_ctx
2172 ++ map (trans_comment . show_one) trans_ctx)
2173
2174 showModules :: GHCi ()
2175 showModules = do
2176 loaded_mods <- getLoadedModules
2177 -- we want *loaded* modules only, see #1734
2178 let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)
2179 mapM_ show_one loaded_mods
2180
2181 getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
2182 getLoadedModules = do
2183 graph <- GHC.getModuleGraph
2184 filterM (GHC.isLoaded . GHC.ms_mod_name) graph
2185
2186 showBindings :: GHCi ()
2187 showBindings = do
2188 bindings <- GHC.getBindings
2189 (insts, finsts) <- GHC.getInsts
2190 docs <- mapM makeDoc (reverse bindings)
2191 -- reverse so the new ones come last
2192 let idocs = map GHC.pprInstanceHdr insts
2193 fidocs = map GHC.pprFamInstHdr finsts
2194 mapM_ printForUserPartWay (docs ++ idocs ++ fidocs)
2195 where
2196 makeDoc (AnId i) = pprTypeAndContents i
2197 makeDoc tt = do
2198 dflags <- getDynFlags
2199 let pefas = dopt Opt_PrintExplicitForalls dflags
2200 mb_stuff <- GHC.getInfo (getName tt)
2201 return $ maybe (text "") (pprTT pefas) mb_stuff
2202 pprTT :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.ClsInst]) -> SDoc
2203 pprTT pefas (thing, fixity, _insts) =
2204 pprTyThing pefas thing
2205 $$ show_fixity
2206 where
2207 show_fixity
2208 | fixity == GHC.defaultFixity = empty
2209 | otherwise = ppr fixity <+> ppr (GHC.getName thing)
2210
2211
2212 printTyThing :: TyThing -> GHCi ()
2213 printTyThing tyth = do dflags <- getDynFlags
2214 let pefas = dopt Opt_PrintExplicitForalls dflags
2215 printForUser (pprTyThing pefas tyth)
2216
2217 showBkptTable :: GHCi ()
2218 showBkptTable = do
2219 st <- getGHCiState
2220 printForUser $ prettyLocations (breaks st)
2221
2222 showContext :: GHCi ()
2223 showContext = do
2224 resumes <- GHC.getResumeContext
2225 printForUser $ vcat (map pp_resume (reverse resumes))
2226 where
2227 pp_resume res =
2228 ptext (sLit "--> ") <> text (GHC.resumeStmt res)
2229 $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan res))
2230
2231 showPackages :: GHCi ()
2232 showPackages = do
2233 dflags <- getDynFlags
2234 let pkg_flags = packageFlags dflags
2235 liftIO $ putStrLn $ showSDoc dflags $ vcat $
2236 text ("active package flags:"++if null pkg_flags then " none" else "")
2237 : map showFlag pkg_flags
2238 where showFlag (ExposePackage p) = text $ " -package " ++ p
2239 showFlag (HidePackage p) = text $ " -hide-package " ++ p
2240 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
2241 showFlag (ExposePackageId p) = text $ " -package-id " ++ p
2242 showFlag (TrustPackage p) = text $ " -trust " ++ p
2243 showFlag (DistrustPackage p) = text $ " -distrust " ++ p
2244
2245 showLanguages :: GHCi ()
2246 showLanguages = getDynFlags >>= liftIO . showLanguages' False
2247
2248 showiLanguages :: GHCi ()
2249 showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False
2250
2251 showLanguages' :: Bool -> DynFlags -> IO ()
2252 showLanguages' show_all dflags =
2253 putStrLn $ showSDoc dflags $ vcat
2254 [ text "base language is: " <>
2255 case language dflags of
2256 Nothing -> text "Haskell2010"
2257 Just Haskell98 -> text "Haskell98"
2258 Just Haskell2010 -> text "Haskell2010"
2259 , (if show_all then text "all active language options:"
2260 else text "with the following modifiers:") $$
2261 nest 2 (vcat (map (setting xopt) DynFlags.xFlags))
2262 ]
2263 where
2264 setting test (str, f, _)
2265 | quiet = empty
2266 | is_on = text "-X" <> text str
2267 | otherwise = text "-XNo" <> text str
2268 where is_on = test f dflags
2269 quiet = not show_all && test f default_dflags == is_on
2270
2271 default_dflags =
2272 defaultDynFlags (settings dflags) `lang_set`
2273 case language dflags of
2274 Nothing -> Just Haskell2010
2275 other -> other
2276
2277 -- -----------------------------------------------------------------------------
2278 -- Completion
2279
2280 completeCmd, completeMacro, completeIdentifier, completeModule,
2281 completeSetModule, completeSeti, completeShowiOptions,
2282 completeHomeModule, completeSetOptions, completeShowOptions,
2283 completeHomeModuleOrFile, completeExpression
2284 :: CompletionFunc GHCi
2285
2286 ghciCompleteWord :: CompletionFunc GHCi
2287 ghciCompleteWord line@(left,_) = case firstWord of
2288 ':':cmd | null rest -> completeCmd line
2289 | otherwise -> do
2290 completion <- lookupCompletion cmd
2291 completion line
2292 "import" -> completeModule line
2293 _ -> completeExpression line
2294 where
2295 (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
2296 lookupCompletion ('!':_) = return completeFilename
2297 lookupCompletion c = do
2298 maybe_cmd <- lookupCommand' c
2299 case maybe_cmd of
2300 Just (_,_,f) -> return f
2301 Nothing -> return completeFilename
2302
2303 completeCmd = wrapCompleter " " $ \w -> do
2304 macros <- liftIO $ readIORef macros_ref
2305 cmds <- ghci_commands `fmap` getGHCiState
2306 let macro_names = map (':':) . map cmdName $ macros
2307 let command_names = map (':':) . map cmdName $ cmds
2308 let{ candidates = case w of
2309 ':' : ':' : _ -> map (':':) command_names
2310 _ -> nub $ macro_names ++ command_names }
2311 return $ filter (w `isPrefixOf`) candidates
2312
2313 completeMacro = wrapIdentCompleter $ \w -> do
2314 cmds <- liftIO $ readIORef macros_ref
2315 return (filter (w `isPrefixOf`) (map cmdName cmds))
2316
2317 completeIdentifier = wrapIdentCompleter $ \w -> do
2318 rdrs <- GHC.getRdrNamesInScope
2319 dflags <- GHC.getSessionDynFlags
2320 return (filter (w `isPrefixOf`) (map (showPpr dflags) rdrs))
2321
2322 completeModule = wrapIdentCompleter $ \w -> do
2323 dflags <- GHC.getSessionDynFlags
2324 let pkg_mods = allExposedModules dflags
2325 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
2326 return $ filter (w `isPrefixOf`)
2327 $ map (showPpr dflags) $ loaded_mods ++ pkg_mods
2328
2329 completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
2330 dflags <- GHC.getSessionDynFlags
2331 modules <- case m of
2332 Just '-' -> do
2333 imports <- GHC.getContext
2334 return $ map iiModuleName imports
2335 _ -> do
2336 let pkg_mods = allExposedModules dflags
2337 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
2338 return $ loaded_mods ++ pkg_mods
2339 return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules
2340
2341 completeHomeModule = wrapIdentCompleter listHomeModules
2342
2343 listHomeModules :: String -> GHCi [String]
2344 listHomeModules w = do
2345 g <- GHC.getModuleGraph
2346 let home_mods = map GHC.ms_mod_name g
2347 dflags <- getDynFlags
2348 return $ sort $ filter (w `isPrefixOf`)
2349 $ map (showPpr dflags) home_mods
2350
2351 completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
2352 return (filter (w `isPrefixOf`) opts)
2353 where opts = "args":"prog":"prompt":"editor":"stop":flagList
2354 flagList = map head $ group $ sort allFlags
2355
2356 completeSeti = wrapCompleter flagWordBreakChars $ \w -> do
2357 return (filter (w `isPrefixOf`) flagList)
2358 where flagList = map head $ group $ sort allFlags
2359
2360 completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
2361 return (filter (w `isPrefixOf`) opts)
2362 where opts = ["args", "prog", "prompt", "editor", "stop",
2363 "modules", "bindings", "linker", "breaks",
2364 "context", "packages", "language"]
2365
2366 completeShowiOptions = wrapCompleter flagWordBreakChars $ \w -> do
2367 return (filter (w `isPrefixOf`) ["language"])
2368
2369 completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
2370 $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
2371 listFiles
2372
2373 unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
2374 unionComplete f1 f2 line = do
2375 cs1 <- f1 line
2376 cs2 <- f2 line
2377 return (cs1 ++ cs2)
2378
2379 wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
2380 wrapCompleter breakChars fun = completeWord Nothing breakChars
2381 $ fmap (map simpleCompletion) . fmap sort . fun
2382
2383 wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
2384 wrapIdentCompleter = wrapCompleter word_break_chars
2385
2386 wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi
2387 wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars
2388 $ \rest -> fmap (map simpleCompletion) . fmap sort . fun (getModifier rest)
2389 where
2390 getModifier = find (`elem` modifChars)
2391
2392 allExposedModules :: DynFlags -> [ModuleName]
2393 allExposedModules dflags
2394 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
2395 where
2396 pkg_db = pkgIdMap (pkgState dflags)
2397
2398 completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
2399 completeIdentifier
2400
2401
2402 -- -----------------------------------------------------------------------------
2403 -- commands for debugger
2404
2405 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
2406 sprintCmd = pprintCommand False False
2407 printCmd = pprintCommand True False
2408 forceCmd = pprintCommand False True
2409
2410 pprintCommand :: Bool -> Bool -> String -> GHCi ()
2411 pprintCommand bind force str = do
2412 pprintClosureCommand bind force str
2413
2414 stepCmd :: String -> GHCi ()
2415 stepCmd arg = withSandboxOnly ":step" $ step arg
2416 where
2417 step [] = doContinue (const True) GHC.SingleStep
2418 step expression = runStmt expression GHC.SingleStep >> return ()
2419
2420 stepLocalCmd :: String -> GHCi ()
2421 stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg
2422 where
2423 step expr
2424 | not (null expr) = stepCmd expr
2425 | otherwise = do
2426 mb_span <- getCurrentBreakSpan
2427 case mb_span of
2428 Nothing -> stepCmd []
2429 Just loc -> do
2430 Just md <- getCurrentBreakModule
2431 current_toplevel_decl <- enclosingTickSpan md loc
2432 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
2433
2434 stepModuleCmd :: String -> GHCi ()
2435 stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg
2436 where
2437 step expr
2438 | not (null expr) = stepCmd expr
2439 | otherwise = do
2440 mb_span <- getCurrentBreakSpan
2441 case mb_span of
2442 Nothing -> stepCmd []
2443 Just pan -> do
2444 let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span
2445 doContinue f GHC.SingleStep
2446
2447 -- | Returns the span of the largest tick containing the srcspan given
2448 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
2449 enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
2450 enclosingTickSpan md (RealSrcSpan src) = do
2451 ticks <- getTickArray md
2452 let line = srcSpanStartLine src
2453 ASSERT (inRange (bounds ticks) line) do
2454 let toRealSrcSpan (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
2455 toRealSrcSpan (RealSrcSpan s) = s
2456 enclosing_spans = [ pan | (_,pan) <- ticks ! line
2457 , realSrcSpanEnd (toRealSrcSpan pan) >= realSrcSpanEnd src]
2458 return . head . sortBy leftmost_largest $ enclosing_spans
2459
2460 traceCmd :: String -> GHCi ()
2461 traceCmd arg
2462 = withSandboxOnly ":trace" $ tr arg
2463 where
2464 tr [] = doContinue (const True) GHC.RunAndLogSteps
2465 tr expression = runStmt expression GHC.RunAndLogSteps >> return ()
2466
2467 continueCmd :: String -> GHCi ()
2468 continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion
2469
2470 -- doContinue :: SingleStep -> GHCi ()
2471 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
2472 doContinue pre step = do
2473 runResult <- resume pre step
2474 _ <- afterRunStmt pre runResult
2475 return ()
2476
2477 abandonCmd :: String -> GHCi ()
2478 abandonCmd = noArgs $ withSandboxOnly ":abandon" $ do
2479 b <- GHC.abandon -- the prompt will change to indicate the new context
2480 when (not b) $ liftIO $ putStrLn "There is no computation running."
2481
2482 deleteCmd :: String -> GHCi ()
2483 deleteCmd argLine = withSandboxOnly ":delete" $ do
2484 deleteSwitch $ words argLine
2485 where
2486 deleteSwitch :: [String] -> GHCi ()
2487 deleteSwitch [] =
2488 liftIO $ putStrLn "The delete command requires at least one argument."
2489 -- delete all break points
2490 deleteSwitch ("*":_rest) = discardActiveBreakPoints
2491 deleteSwitch idents = do
2492 mapM_ deleteOneBreak idents
2493 where
2494 deleteOneBreak :: String -> GHCi ()
2495 deleteOneBreak str
2496 | all isDigit str = deleteBreak (read str)
2497 | otherwise = return ()
2498
2499 historyCmd :: String -> GHCi ()
2500 historyCmd arg
2501 | null arg = history 20
2502 | all isDigit arg = history (read arg)
2503 | otherwise = liftIO $ putStrLn "Syntax: :history [num]"
2504 where
2505 history num = do
2506 resumes <- GHC.getResumeContext
2507 case resumes of
2508 [] -> liftIO $ putStrLn "Not stopped at a breakpoint"
2509 (r:_) -> do
2510 let hist = GHC.resumeHistory r
2511 (took,rest) = splitAt num hist
2512 case hist of
2513 [] -> liftIO $ putStrLn $
2514 "Empty history. Perhaps you forgot to use :trace?"
2515 _ -> do
2516 pans <- mapM GHC.getHistorySpan took
2517 let nums = map (printf "-%-3d:") [(1::Int)..]
2518 names = map GHC.historyEnclosingDecls took
2519 printForUser (vcat(zipWith3
2520 (\x y z -> x <+> y <+> z)
2521 (map text nums)
2522 (map (bold . hcat . punctuate colon . map text) names)
2523 (map (parens . ppr) pans)))
2524 liftIO $ putStrLn $ if null rest then "<end of history>" else "..."
2525
2526 bold :: SDoc -> SDoc
2527 bold c | do_bold = text start_bold <> c <> text end_bold
2528 | otherwise = c
2529
2530 backCmd :: String -> GHCi ()
2531 backCmd = noArgs $ withSandboxOnly ":back" $ do
2532 (names, _, pan) <- GHC.back
2533 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan
2534 printTypeOfNames names
2535 -- run the command set with ":set stop <cmd>"
2536 st <- getGHCiState
2537 enqueueCommands [stop st]
2538
2539 forwardCmd :: String -> GHCi ()
2540 forwardCmd = noArgs $ withSandboxOnly ":forward" $ do
2541 (names, ix, pan) <- GHC.forward
2542 printForUser $ (if (ix == 0)
2543 then ptext (sLit "Stopped at")
2544 else ptext (sLit "Logged breakpoint at")) <+> ppr pan
2545 printTypeOfNames names
2546 -- run the command set with ":set stop <cmd>"
2547 st <- getGHCiState
2548 enqueueCommands [stop st]
2549
2550 -- handle the "break" command
2551 breakCmd :: String -> GHCi ()
2552 breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine
2553
2554 breakSwitch :: [String] -> GHCi ()
2555 breakSwitch [] = do
2556 liftIO $ putStrLn "The break command requires at least one argument."
2557 breakSwitch (arg1:rest)
2558 | looksLikeModuleName arg1 && not (null rest) = do
2559 md <- wantInterpretedModule arg1
2560 breakByModule md rest
2561 | all isDigit arg1 = do
2562 imports <- GHC.getContext
2563 case iiModules imports of
2564 (mn : _) -> do
2565 md <- lookupModuleName mn
2566 breakByModuleLine md (read arg1) rest
2567 [] -> do
2568 liftIO $ putStrLn "No modules are loaded with debugging support."
2569 | otherwise = do -- try parsing it as an identifier
2570 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
2571 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2572 case loc of
2573 RealSrcLoc l ->
2574 ASSERT( isExternalName name )
2575 findBreakAndSet (GHC.nameModule name) $
2576 findBreakByCoord (Just (GHC.srcLocFile l))
2577 (GHC.srcLocLine l,
2578 GHC.srcLocCol l)
2579 UnhelpfulLoc _ ->
2580 noCanDo name $ text "can't find its location: " <> ppr loc
2581 where
2582 noCanDo n why = printForUser $
2583 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
2584
2585 breakByModule :: Module -> [String] -> GHCi ()
2586 breakByModule md (arg1:rest)
2587 | all isDigit arg1 = do -- looks like a line number
2588 breakByModuleLine md (read arg1) rest
2589 breakByModule _ _
2590 = breakSyntax
2591
2592 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
2593 breakByModuleLine md line args
2594 | [] <- args = findBreakAndSet md $ findBreakByLine line
2595 | [col] <- args, all isDigit col =
2596 findBreakAndSet md $ findBreakByCoord Nothing (line, read col)
2597 | otherwise = breakSyntax
2598
2599 breakSyntax :: a
2600 breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
2601
2602 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
2603 findBreakAndSet md lookupTickTree = do
2604 tickArray <- getTickArray md
2605 (breakArray, _) <- getModBreak md
2606 case lookupTickTree tickArray of
2607 Nothing -> liftIO $ putStrLn $ "No breakpoints found at that location."
2608 Just (tick, pan) -> do
2609 success <- liftIO $ setBreakFlag True breakArray tick
2610 if success
2611 then do
2612 (alreadySet, nm) <-
2613 recordBreak $ BreakLocation
2614 { breakModule = md
2615 , breakLoc = pan
2616 , breakTick = tick
2617 , onBreakCmd = ""
2618 }
2619 printForUser $
2620 text "Breakpoint " <> ppr nm <>
2621 if alreadySet
2622 then text " was already set at " <> ppr pan
2623 else text " activated at " <> ppr pan
2624 else do
2625 printForUser $ text "Breakpoint could not be activated at"
2626 <+> ppr pan
2627
2628 -- When a line number is specified, the current policy for choosing
2629 -- the best breakpoint is this:
2630 -- - the leftmost complete subexpression on the specified line, or
2631 -- - the leftmost subexpression starting on the specified line, or
2632 -- - the rightmost subexpression enclosing the specified line
2633 --
2634 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2635 findBreakByLine line arr
2636 | not (inRange (bounds arr) line) = Nothing
2637 | otherwise =
2638 listToMaybe (sortBy (leftmost_largest `on` snd) comp) `mplus`
2639 listToMaybe (sortBy (leftmost_smallest `on` snd) incomp) `mplus`
2640 listToMaybe (sortBy (rightmost `on` snd) ticks)
2641 where
2642 ticks = arr ! line
2643
2644 starts_here = [ tick | tick@(_,pan) <- ticks,
2645 GHC.srcSpanStartLine (toRealSpan pan) == line ]
2646
2647 (comp, incomp) = partition ends_here starts_here
2648 where ends_here (_,pan) = GHC.srcSpanEndLine (toRealSpan pan) == line
2649 toRealSpan (RealSrcSpan pan) = pan
2650 toRealSpan (UnhelpfulSpan _) = panic "findBreakByLine UnhelpfulSpan"
2651
2652 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2653 -> Maybe (BreakIndex,SrcSpan)
2654 findBreakByCoord mb_file (line, col) arr
2655 | not (inRange (bounds arr) line) = Nothing
2656 | otherwise =
2657 listToMaybe (sortBy (rightmost `on` snd) contains ++
2658 sortBy (leftmost_smallest `on` snd) after_here)
2659 where
2660 ticks = arr ! line
2661
2662 -- the ticks that span this coordinate
2663 contains = [ tick | tick@(_,pan) <- ticks, pan `spans` (line,col),
2664 is_correct_file pan ]
2665
2666 is_correct_file pan
2667 | Just f <- mb_file = GHC.srcSpanFile (toRealSpan pan) == f
2668 | otherwise = True
2669
2670 after_here = [ tick | tick@(_,pan) <- ticks,
2671 let pan' = toRealSpan pan,
2672 GHC.srcSpanStartLine pan' == line,
2673 GHC.srcSpanStartCol pan' >= col ]
2674
2675 toRealSpan (RealSrcSpan pan) = pan
2676 toRealSpan (UnhelpfulSpan _) = panic "findBreakByCoord UnhelpfulSpan"
2677
2678 -- For now, use ANSI bold on terminals that we know support it.
2679 -- Otherwise, we add a line of carets under the active expression instead.
2680 -- In particular, on Windows and when running the testsuite (which sets
2681 -- TERM to vt100 for other reasons) we get carets.
2682 -- We really ought to use a proper termcap/terminfo library.
2683 do_bold :: Bool
2684 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2685 where mTerm = System.Environment.getEnv "TERM"
2686 `catchIO` \_ -> return "TERM not set"
2687
2688 start_bold :: String
2689 start_bold = "\ESC[1m"
2690 end_bold :: String
2691 end_bold = "\ESC[0m"
2692
2693
2694 -----------------------------------------------------------------------------
2695 -- :list
2696
2697 listCmd :: String -> InputT GHCi ()
2698 listCmd c = listCmd' c
2699
2700 listCmd' :: String -> InputT GHCi ()
2701 listCmd' "" = do
2702 mb_span <- lift getCurrentBreakSpan
2703 case mb_span of
2704 Nothing ->
2705 printForUser $ text "Not stopped at a breakpoint; nothing to list"
2706 Just (RealSrcSpan pan) ->
2707 listAround pan True
2708 Just pan@(UnhelpfulSpan _) ->
2709 do resumes <- GHC.getResumeContext
2710 case resumes of
2711 [] -> panic "No resumes"
2712 (r:_) ->
2713 do let traceIt = case GHC.resumeHistory r of
2714 [] -> text "rerunning with :trace,"
2715 _ -> empty
2716 doWhat = traceIt <+> text ":back then :list"
2717 printForUser (text "Unable to list source for" <+>
2718 ppr pan
2719 $$ text "Try" <+> doWhat)
2720 listCmd' str = list2 (words str)
2721
2722 list2 :: [String] -> InputT GHCi ()
2723 list2 [arg] | all isDigit arg = do
2724 imports <- GHC.getContext
2725 case iiModules imports of
2726 [] -> liftIO $ putStrLn "No module to list"
2727 (mn : _) -> do
2728 md <- lift $ lookupModuleName mn
2729 listModuleLine md (read arg)
2730 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2731 md <- wantInterpretedModule arg1
2732 listModuleLine md (read arg2)
2733 list2 [arg] = do
2734 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2735 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2736 case loc of
2737 RealSrcLoc l ->
2738 do tickArray <- ASSERT( isExternalName name )
2739 lift $ getTickArray (GHC.nameModule name)
2740 let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))
2741 (GHC.srcLocLine l, GHC.srcLocCol l)
2742 tickArray
2743 case mb_span of
2744 Nothing -> listAround (realSrcLocSpan l) False
2745 Just (_, UnhelpfulSpan _) -> panic "list2 UnhelpfulSpan"
2746 Just (_, RealSrcSpan pan) -> listAround pan False
2747 UnhelpfulLoc _ ->
2748 noCanDo name $ text "can't find its location: " <>
2749 ppr loc
2750 where
2751 noCanDo n why = printForUser $
2752 text "cannot list source code for " <> ppr n <> text ": " <> why
2753 list2 _other =
2754 liftIO $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2755
2756 listModuleLine :: Module -> Int -> InputT GHCi ()
2757 listModuleLine modl line = do
2758 graph <- GHC.getModuleGraph
2759 let this = filter ((== modl) . GHC.ms_mod) graph
2760 case this of
2761 [] -> panic "listModuleLine"
2762 summ:_ -> do
2763 let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
2764 loc = mkRealSrcLoc (mkFastString (filename)) line 0
2765 listAround (realSrcLocSpan loc) False
2766
2767 -- | list a section of a source file around a particular SrcSpan.
2768 -- If the highlight flag is True, also highlight the span using
2769 -- start_bold\/end_bold.
2770
2771 -- GHC files are UTF-8, so we can implement this by:
2772 -- 1) read the file in as a BS and syntax highlight it as before
2773 -- 2) convert the BS to String using utf-string, and write it out.
2774 -- It would be better if we could convert directly between UTF-8 and the
2775 -- console encoding, of course.
2776 listAround :: MonadIO m => RealSrcSpan -> Bool -> InputT m ()
2777 listAround pan do_highlight = do
2778 contents <- liftIO $ BS.readFile (unpackFS file)
2779 let ls = BS.split '\n' contents
2780 ls' = take (line2 - line1 + 1 + pad_before + pad_after) $
2781 drop (line1 - 1 - pad_before) $ ls
2782 fst_line = max 1 (line1 - pad_before)
2783 line_nos = [ fst_line .. ]
2784
2785 highlighted | do_highlight = zipWith highlight line_nos ls'
2786 | otherwise = [\p -> BS.concat[p,l] | l <- ls']
2787
2788 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2789 prefixed = zipWith ($) highlighted bs_line_nos
2790 output = BS.intercalate (BS.pack "\n") prefixed
2791
2792 utf8Decoded <- liftIO $ BS.useAsCStringLen output
2793 $ \(p,n) -> utf8DecodeString (castPtr p) n
2794 liftIO $ putStrLn utf8Decoded
2795 where
2796 file = GHC.srcSpanFile pan
2797 line1 = GHC.srcSpanStartLine pan
2798 col1 = GHC.srcSpanStartCol pan - 1
2799 line2 = GHC.srcSpanEndLine pan
2800 col2 = GHC.srcSpanEndCol pan - 1
2801
2802 pad_before | line1 == 1 = 0
2803 | otherwise = 1
2804 pad_after = 1
2805
2806 highlight | do_bold = highlight_bold
2807 | otherwise = highlight_carets
2808
2809 highlight_bold no line prefix
2810 | no == line1 && no == line2
2811 = let (a,r) = BS.splitAt col1 line
2812 (b,c) = BS.splitAt (col2-col1) r
2813 in
2814 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2815 | no == line1
2816 = let (a,b) = BS.splitAt col1 line in
2817 BS.concat [prefix, a, BS.pack start_bold, b]
2818 | no == line2
2819 = let (a,b) = BS.splitAt col2 line in
2820 BS.concat [prefix, a, BS.pack end_bold, b]
2821 | otherwise = BS.concat [prefix, line]
2822
2823 highlight_carets no line prefix
2824 | no == line1 && no == line2
2825 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2826 BS.replicate (col2-col1) '^']
2827 | no == line1
2828 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2829 prefix, line]
2830 | no == line2
2831 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2832 BS.pack "^^"]
2833 | otherwise = BS.concat [prefix, line]
2834 where
2835 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2836 nl = BS.singleton '\n'
2837
2838
2839 -- --------------------------------------------------------------------------
2840 -- Tick arrays
2841
2842 getTickArray :: Module -> GHCi TickArray
2843 getTickArray modl = do
2844 st <- getGHCiState
2845 let arrmap = tickarrays st
2846 case lookupModuleEnv arrmap modl of
2847 Just arr -> return arr
2848 Nothing -> do
2849 (_breakArray, ticks) <- getModBreak modl
2850 let arr = mkTickArray (assocs ticks)
2851 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2852 return arr
2853
2854 discardTickArrays :: GHCi ()
2855 discardTickArrays = do
2856 st <- getGHCiState
2857 setGHCiState st{tickarrays = emptyModuleEnv}
2858
2859 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2860 mkTickArray ticks
2861 = accumArray (flip (:)) [] (1, max_line)
2862 [ (line, (nm,pan)) | (nm,pan) <- ticks,
2863 let pan' = toRealSpan pan,
2864 line <- srcSpanLines pan' ]
2865 where
2866 max_line = foldr max 0 (map (GHC.srcSpanEndLine . toRealSpan . snd) ticks)
2867 srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ]
2868 toRealSpan (RealSrcSpan pan) = pan
2869 toRealSpan (UnhelpfulSpan _) = panic "mkTickArray UnhelpfulSpan"
2870
2871 -- don't reset the counter back to zero?
2872 discardActiveBreakPoints :: GHCi ()
2873 discardActiveBreakPoints = do
2874 st <- getGHCiState
2875 mapM_ (turnOffBreak.snd) (breaks st)
2876 setGHCiState $ st { breaks = [] }
2877
2878 deleteBreak :: Int -> GHCi ()
2879 deleteBreak identity = do
2880 st <- getGHCiState
2881 let oldLocations = breaks st
2882 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2883 if null this
2884 then printForUser (text "Breakpoint" <+> ppr identity <+>
2885 text "does not exist")
2886 else do
2887 mapM_ (turnOffBreak.snd) this
2888 setGHCiState $ st { breaks = rest }
2889
2890 turnOffBreak :: BreakLocation -> GHCi Bool
2891 turnOffBreak loc = do
2892 (arr, _) <- getModBreak (breakModule loc)
2893 liftIO $ setBreakFlag False arr (breakTick loc)
2894
2895 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2896 getModBreak m = do
2897 Just mod_info <- GHC.getModuleInfo m
2898 let modBreaks = GHC.modInfoModBreaks mod_info
2899 let arr = GHC.modBreaks_flags modBreaks
2900 let ticks = GHC.modBreaks_locs modBreaks
2901 return (arr, ticks)
2902
2903 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2904 setBreakFlag toggle arr i
2905 | toggle = GHC.setBreakOn arr i
2906 | otherwise = GHC.setBreakOff arr i
2907
2908
2909 -- ---------------------------------------------------------------------------
2910 -- User code exception handling
2911
2912 -- This is the exception handler for exceptions generated by the
2913 -- user's code and exceptions coming from children sessions;
2914 -- it normally just prints out the exception. The
2915 -- handler must be recursive, in case showing the exception causes
2916 -- more exceptions to be raised.
2917 --
2918 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
2919 -- raising another exception. We therefore don't put the recursive
2920 -- handler arond the flushing operation, so if stderr is closed
2921 -- GHCi will just die gracefully rather than going into an infinite loop.
2922 handler :: SomeException -> GHCi Bool
2923
2924 handler exception = do
2925 flushInterpBuffers
2926 liftIO installSignalHandlers
2927 ghciHandle handler (showException exception >> return False)
2928
2929 showException :: SomeException -> GHCi ()
2930 showException se =
2931 liftIO $ case fromException se of
2932 -- omit the location for CmdLineError:
2933 Just (CmdLineError s) -> putException s
2934 -- ditto:
2935 Just ph@(PhaseFailed {}) -> putException (showGhcException ph "")
2936 Just other_ghc_ex -> putException (show other_ghc_ex)
2937 Nothing ->
2938 case fromException se of
2939 Just UserInterrupt -> putException "Interrupted."
2940 _ -> putException ("*** Exception: " ++ show se)
2941 where
2942 putException = hPutStrLn stderr
2943
2944
2945 -----------------------------------------------------------------------------
2946 -- recursive exception handlers
2947
2948 -- Don't forget to unblock async exceptions in the handler, or if we're
2949 -- in an exception loop (eg. let a = error a in a) the ^C exception
2950 -- may never be delivered. Thanks to Marcin for pointing out the bug.
2951
2952 ghciHandle :: ExceptionMonad m => (SomeException -> m a) -> m a -> m a
2953 ghciHandle h m = gcatch m $ \e -> gunblock (h e)
2954
2955 ghciTry :: GHCi a -> GHCi (Either SomeException a)
2956 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
2957
2958 tryBool :: GHCi a -> GHCi Bool
2959 tryBool m = do
2960 r <- ghciTry m
2961 case r of
2962 Left _ -> return False
2963 Right _ -> return True
2964
2965 -- ----------------------------------------------------------------------------
2966 -- Utils
2967
2968 lookupModule :: GHC.GhcMonad m => String -> m Module
2969 lookupModule mName = lookupModuleName (GHC.mkModuleName mName)
2970
2971 lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module
2972 lookupModuleName mName = GHC.lookupModule mName Nothing
2973
2974 isHomeModule :: Module -> Bool
2975 isHomeModule m = GHC.modulePackageId m == mainPackageId
2976
2977 -- TODO: won't work if home dir is encoded.
2978 -- (changeDirectory may not work either in that case.)
2979 expandPath :: MonadIO m => String -> InputT m String
2980 expandPath = liftIO . expandPathIO
2981
2982 expandPathIO :: String -> IO String
2983 expandPathIO p =
2984 case dropWhile isSpace p of
2985 ('~':d) -> do
2986 tilde <- getHomeDirectory -- will fail if HOME not defined
2987 return (tilde ++ '/':d)
2988 other ->
2989 return other
2990
2991 wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
2992 wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str)
2993
2994 wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module
2995 wantInterpretedModuleName modname = do
2996 modl <- lookupModuleName modname
2997 let str = moduleNameString modname
2998 dflags <- getDynFlags
2999 when (GHC.modulePackageId modl /= thisPackage dflags) $
3000 ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
3001 is_interpreted <- GHC.moduleIsInterpreted modl
3002 when (not is_interpreted) $
3003 ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
3004 return modl
3005
3006 wantNameFromInterpretedModule :: GHC.GhcMonad m
3007 => (Name -> SDoc -> m ())
3008 -> String
3009 -> (Name -> m ())
3010 -> m ()
3011 wantNameFromInterpretedModule noCanDo str and_then =
3012 handleSourceError GHC.printException $ do
3013 names <- GHC.parseName str
3014 case names of
3015 [] -> return ()
3016 (n:_) -> do
3017 let modl = ASSERT( isExternalName n ) GHC.nameModule n
3018 if not (GHC.isExternalName n)
3019 then noCanDo n $ ppr n <>
3020 text " is not defined in an interpreted module"
3021 else do
3022 is_interpreted <- GHC.moduleIsInterpreted modl
3023 if not is_interpreted
3024 then noCanDo n $ text "module " <> ppr modl <>
3025 text " is not interpreted"
3026 else and_then n