MERGED: Give PrimOps a NOINLINE pragma, to suppress silly warnings from dsRule
[ghc.git] / ghc / InteractiveUI.hs
1 {-# OPTIONS -fno-cse #-}
2 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
3
4 -----------------------------------------------------------------------------
5 --
6 -- GHC Interactive User Interface
7 --
8 -- (c) The GHC Team 2005-2006
9 --
10 -----------------------------------------------------------------------------
11
12 module InteractiveUI (
13 interactiveUI,
14 GhciSettings(..),
15 defaultGhciSettings,
16 ghciCommands,
17 ghciWelcomeMsg
18 ) where
19
20 #include "HsVersions.h"
21
22 -- GHCi
23 import qualified GhciMonad ( args, runStmt )
24 import GhciMonad hiding ( args, runStmt )
25 import GhciTags
26 import Debugger
27
28 -- The GHC interface
29 import DynFlags
30 import GhcMonad ( modifySession )
31 import qualified GHC
32 import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..),
33 TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,
34 handleSourceError )
35 import HsImpExp
36 import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,
37 setInteractivePrintName )
38 import Module
39 import Name
40 import Packages ( trusted, getPackageDetails, exposed, exposedModules, pkgIdMap )
41 import PprTyThing
42 import RdrName ( getGRE_NameQualifier_maybes )
43 import SrcLoc
44 import qualified Lexer
45
46 import StringBuffer
47 import UniqFM ( eltsUFM )
48 import Outputable hiding ( printForUser, printForUserPartWay, bold )
49
50 -- Other random utilities
51 import BasicTypes hiding ( isTopLevel )
52 import Config
53 import Digraph
54 import Encoding
55 import FastString
56 import Linker
57 import Maybes ( orElse, expectJust )
58 import NameSet
59 import Panic hiding ( showException )
60 import Util
61
62 -- Haskell Libraries
63 import System.Console.Haskeline as Haskeline
64
65 import Control.Applicative hiding (empty)
66 import Control.Monad as Monad
67 import Control.Monad.Trans.Class
68 import Control.Monad.IO.Class
69
70 import Data.Array
71 import qualified Data.ByteString.Char8 as BS
72 import Data.Char
73 import Data.Function
74 import Data.IORef ( IORef, readIORef, writeIORef )
75 import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,
76 partition, sort, sortBy )
77 import Data.Maybe
78
79 import Exception hiding (catch)
80
81 import Foreign.C
82 import Foreign.Safe
83
84 import System.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 (msafe, pkgs) <- GHC.moduleTrustReqs m
1491 let trust = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface
1492 pkg = if packageTrusted dflags m then "trusted" else "untrusted"
1493 (good, bad) = tallyPkgs dflags pkgs
1494
1495 -- print info to user...
1496 liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")"
1497 liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off")
1498 when (not $ null good)
1499 (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++
1500 (intercalate ", " $ map packageIdString good))
1501 case msafe && null bad of
1502 True -> liftIO $ putStrLn $ mname ++ " is trusted!"
1503 False -> do
1504 when (not $ null bad)
1505 (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "
1506 ++ (intercalate ", " $ map packageIdString bad))
1507 liftIO $ putStrLn $ mname ++ " is NOT trusted!"
1508
1509 where
1510 mname = GHC.moduleNameString $ GHC.moduleName m
1511
1512 packageTrusted dflags md
1513 | thisPackage dflags == modulePackageId md = True
1514 | otherwise = trusted $ getPackageDetails (pkgState dflags) (modulePackageId md)
1515
1516 tallyPkgs dflags deps | not (packageTrustOn dflags) = ([], [])
1517 | otherwise = partition part deps
1518 where state = pkgState dflags
1519 part pkg = trusted $ getPackageDetails state pkg
1520
1521 -----------------------------------------------------------------------------
1522 -- :browse
1523
1524 -- Browsing a module's contents
1525
1526 browseCmd :: Bool -> String -> InputT GHCi ()
1527 browseCmd bang m =
1528 case words m of
1529 ['*':s] | looksLikeModuleName s -> do
1530 md <- lift $ wantInterpretedModule s
1531 browseModule bang md False
1532 [s] | looksLikeModuleName s -> do
1533 md <- lift $ lookupModule s
1534 browseModule bang md True
1535 [] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "")
1536 browseModule bang md True
1537 _ -> ghcError (CmdLineError "syntax: :browse <module>")
1538
1539 guessCurrentModule :: String -> InputT GHCi Module
1540 -- Guess which module the user wants to browse. Pick
1541 -- modules that are interpreted first. The most
1542 -- recently-added module occurs last, it seems.
1543 guessCurrentModule cmd
1544 = do imports <- GHC.getContext
1545 when (null imports) $ ghcError $
1546 CmdLineError (':' : cmd ++ ": no current module")
1547 case (head imports) of
1548 IIModule m -> GHC.findModule m Nothing
1549 IIDecl d -> GHC.findModule (unLoc (ideclName d)) (ideclPkgQual d)
1550
1551 -- without bang, show items in context of their parents and omit children
1552 -- with bang, show class methods and data constructors separately, and
1553 -- indicate import modules, to aid qualifying unqualified names
1554 -- with sorted, sort items alphabetically
1555 browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
1556 browseModule bang modl exports_only = do
1557 -- :browse reports qualifiers wrt current context
1558 unqual <- GHC.getPrintUnqual
1559
1560 mb_mod_info <- GHC.getModuleInfo modl
1561 case mb_mod_info of
1562 Nothing -> ghcError (CmdLineError ("unknown module: " ++
1563 GHC.moduleNameString (GHC.moduleName modl)))
1564 Just mod_info -> do
1565 dflags <- getDynFlags
1566 let names
1567 | exports_only = GHC.modInfoExports mod_info
1568 | otherwise = GHC.modInfoTopLevelScope mod_info
1569 `orElse` []
1570
1571 -- sort alphabetically name, but putting locally-defined
1572 -- identifiers first. We would like to improve this; see #1799.
1573 sorted_names = loc_sort local ++ occ_sort external
1574 where
1575 (local,external) = ASSERT( all isExternalName names )
1576 partition ((==modl) . nameModule) names
1577 occ_sort = sortBy (compare `on` nameOccName)
1578 -- try to sort by src location. If the first name in our list
1579 -- has a good source location, then they all should.
1580 loc_sort ns
1581 | n:_ <- ns, isGoodSrcSpan (nameSrcSpan n)
1582 = sortBy (compare `on` nameSrcSpan) ns
1583 | otherwise
1584 = occ_sort ns
1585
1586 mb_things <- mapM GHC.lookupName sorted_names
1587 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1588
1589 rdr_env <- GHC.getGRE
1590
1591 let pefas = dopt Opt_PrintExplicitForalls dflags
1592 things | bang = catMaybes mb_things
1593 | otherwise = filtered_things
1594 pretty | bang = pprTyThing
1595 | otherwise = pprTyThingInContext
1596
1597 labels [] = text "-- not currently imported"
1598 labels l = text $ intercalate "\n" $ map qualifier l
1599
1600 qualifier :: Maybe [ModuleName] -> String
1601 qualifier = maybe "-- defined locally"
1602 (("-- imported via "++) . intercalate ", "
1603 . map GHC.moduleNameString)
1604 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1605
1606 modNames :: [[Maybe [ModuleName]]]
1607 modNames = map (importInfo . GHC.getName) things
1608
1609 -- annotate groups of imports with their import modules
1610 -- the default ordering is somewhat arbitrary, so we group
1611 -- by header and sort groups; the names themselves should
1612 -- really come in order of source appearance.. (trac #1799)
1613 annotate mts = concatMap (\(m,ts)->labels m:ts)
1614 $ sortBy cmpQualifiers $ grp mts
1615 where cmpQualifiers =
1616 compare `on` (map (fmap (map moduleNameFS)) . fst)
1617 grp [] = []
1618 grp mts@((m,_):_) = (m,map snd g) : grp ng
1619 where (g,ng) = partition ((==m).fst) mts
1620
1621 let prettyThings, prettyThings' :: [SDoc]
1622 prettyThings = map (pretty pefas) things
1623 prettyThings' | bang = annotate $ zip modNames prettyThings
1624 | otherwise = prettyThings
1625 liftIO $ putStrLn $ showSDocForUser dflags unqual (vcat prettyThings')
1626 -- ToDo: modInfoInstances currently throws an exception for
1627 -- package modules. When it works, we can do this:
1628 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1629
1630
1631 -----------------------------------------------------------------------------
1632 -- :module
1633
1634 -- Setting the module context. For details on context handling see
1635 -- "remembered_ctx" and "transient_ctx" in GhciMonad.
1636
1637 moduleCmd :: String -> GHCi ()
1638 moduleCmd str
1639 | all sensible strs = cmd
1640 | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1641 where
1642 (cmd, strs) =
1643 case str of
1644 '+':stuff -> rest addModulesToContext stuff
1645 '-':stuff -> rest remModulesFromContext stuff
1646 stuff -> rest setContext stuff
1647
1648 rest op stuff = (op as bs, stuffs)
1649 where (as,bs) = partitionWith starred stuffs
1650 stuffs = words stuff
1651
1652 sensible ('*':m) = looksLikeModuleName m
1653 sensible m = looksLikeModuleName m
1654
1655 starred ('*':m) = Left (GHC.mkModuleName m)
1656 starred m = Right (GHC.mkModuleName m)
1657
1658
1659 -- -----------------------------------------------------------------------------
1660 -- Four ways to manipulate the context:
1661 -- (a) :module +<stuff>: addModulesToContext
1662 -- (b) :module -<stuff>: remModulesFromContext
1663 -- (c) :module <stuff>: setContext
1664 -- (d) import <module>...: addImportToContext
1665
1666 addModulesToContext :: [ModuleName] -> [ModuleName] -> GHCi ()
1667 addModulesToContext starred unstarred = restoreContextOnFailure $ do
1668 addModulesToContext_ starred unstarred
1669
1670 addModulesToContext_ :: [ModuleName] -> [ModuleName] -> GHCi ()
1671 addModulesToContext_ starred unstarred = do
1672 mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)
1673 setGHCContextFromGHCiState
1674
1675 remModulesFromContext :: [ModuleName] -> [ModuleName] -> GHCi ()
1676 remModulesFromContext starred unstarred = do
1677 -- we do *not* call restoreContextOnFailure here. If the user
1678 -- is trying to fix up a context that contains errors by removing
1679 -- modules, we don't want GHC to silently put them back in again.
1680 mapM_ rm (starred ++ unstarred)
1681 setGHCContextFromGHCiState
1682 where
1683 rm :: ModuleName -> GHCi ()
1684 rm str = do
1685 m <- moduleName <$> lookupModuleName str
1686 let filt = filter ((/=) m . iiModuleName)
1687 modifyGHCiState $ \st ->
1688 st { remembered_ctx = filt (remembered_ctx st)
1689 , transient_ctx = filt (transient_ctx st) }
1690
1691 setContext :: [ModuleName] -> [ModuleName] -> GHCi ()
1692 setContext starred unstarred = restoreContextOnFailure $ do
1693 modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] }
1694 -- delete the transient context
1695 addModulesToContext_ starred unstarred
1696
1697 addImportToContext :: String -> GHCi ()
1698 addImportToContext str = restoreContextOnFailure $ do
1699 idecl <- GHC.parseImportDecl str
1700 addII (IIDecl idecl) -- #5836
1701 setGHCContextFromGHCiState
1702
1703 -- Util used by addImportToContext and addModulesToContext
1704 addII :: InteractiveImport -> GHCi ()
1705 addII iidecl = do
1706 checkAdd iidecl
1707 modifyGHCiState $ \st ->
1708 st { remembered_ctx = addNotSubsumed iidecl (remembered_ctx st)
1709 , transient_ctx = filter (not . (iidecl `iiSubsumes`))
1710 (transient_ctx st)
1711 }
1712
1713 -- Sometimes we can't tell whether an import is valid or not until
1714 -- we finally call 'GHC.setContext'. e.g.
1715 --
1716 -- import System.IO (foo)
1717 --
1718 -- will fail because System.IO does not export foo. In this case we
1719 -- don't want to store the import in the context permanently, so we
1720 -- catch the failure from 'setGHCContextFromGHCiState' and set the
1721 -- context back to what it was.
1722 --
1723 -- See #6007
1724 --
1725 restoreContextOnFailure :: GHCi a -> GHCi a
1726 restoreContextOnFailure do_this = do
1727 st <- getGHCiState
1728 let rc = remembered_ctx st; tc = transient_ctx st
1729 do_this `gonException` (modifyGHCiState $ \st' ->
1730 st' { remembered_ctx = rc, transient_ctx = tc })
1731
1732 -- -----------------------------------------------------------------------------
1733 -- Validate a module that we want to add to the context
1734
1735 checkAdd :: InteractiveImport -> GHCi ()
1736 checkAdd ii = do
1737 dflags <- getDynFlags
1738 let safe = safeLanguageOn dflags
1739 case ii of
1740 IIModule modname
1741 | safe -> ghcError $ CmdLineError "can't use * imports with Safe Haskell"
1742 | otherwise -> wantInterpretedModuleName modname >> return ()
1743
1744 IIDecl d -> do
1745 let modname = unLoc (ideclName d)
1746 pkgqual = ideclPkgQual d
1747 m <- GHC.lookupModule modname pkgqual
1748 when safe $ do
1749 t <- GHC.isModuleTrusted m
1750 when (not t) $ ghcError $ ProgramError $ ""
1751
1752 -- -----------------------------------------------------------------------------
1753 -- Update the GHC API's view of the context
1754
1755 -- | Sets the GHC context from the GHCi state. The GHC context is
1756 -- always set this way, we never modify it incrementally.
1757 --
1758 -- We ignore any imports for which the ModuleName does not currently
1759 -- exist. This is so that the remembered_ctx can contain imports for
1760 -- modules that are not currently loaded, perhaps because we just did
1761 -- a :reload and encountered errors.
1762 --
1763 -- Prelude is added if not already present in the list. Therefore to
1764 -- override the implicit Prelude import you can say 'import Prelude ()'
1765 -- at the prompt, just as in Haskell source.
1766 --
1767 setGHCContextFromGHCiState :: GHCi ()
1768 setGHCContextFromGHCiState = do
1769 st <- getGHCiState
1770 -- re-use checkAdd to check whether the module is valid. If the
1771 -- module does not exist, we do *not* want to print an error
1772 -- here, we just want to silently keep the module in the context
1773 -- until such time as the module reappears again. So we ignore
1774 -- the actual exception thrown by checkAdd, using tryBool to
1775 -- turn it into a Bool.
1776 iidecls <- filterM (tryBool.checkAdd) (transient_ctx st ++ remembered_ctx st)
1777 dflags <- GHC.getSessionDynFlags
1778 GHC.setContext $
1779 if xopt Opt_ImplicitPrelude dflags && not (any isPreludeImport iidecls)
1780 then iidecls ++ [implicitPreludeImport]
1781 else iidecls
1782 -- XXX put prel at the end, so that guessCurrentModule doesn't pick it up.
1783
1784
1785 -- -----------------------------------------------------------------------------
1786 -- Utils on InteractiveImport
1787
1788 mkIIModule :: ModuleName -> InteractiveImport
1789 mkIIModule = IIModule
1790
1791 mkIIDecl :: ModuleName -> InteractiveImport
1792 mkIIDecl = IIDecl . simpleImportDecl
1793
1794 iiModules :: [InteractiveImport] -> [ModuleName]
1795 iiModules is = [m | IIModule m <- is]
1796
1797 iiModuleName :: InteractiveImport -> ModuleName
1798 iiModuleName (IIModule m) = m
1799 iiModuleName (IIDecl d) = unLoc (ideclName d)
1800
1801 preludeModuleName :: ModuleName
1802 preludeModuleName = GHC.mkModuleName "Prelude"
1803
1804 implicitPreludeImport :: InteractiveImport
1805 implicitPreludeImport = IIDecl (simpleImportDecl preludeModuleName)
1806
1807 isPreludeImport :: InteractiveImport -> Bool
1808 isPreludeImport (IIModule {}) = True
1809 isPreludeImport (IIDecl d) = unLoc (ideclName d) == preludeModuleName
1810
1811 addNotSubsumed :: InteractiveImport
1812 -> [InteractiveImport] -> [InteractiveImport]
1813 addNotSubsumed i is
1814 | any (`iiSubsumes` i) is = is
1815 | otherwise = i : filter (not . (i `iiSubsumes`)) is
1816
1817 -- | @filterSubsumed is js@ returns the elements of @js@ not subsumed
1818 -- by any of @is@.
1819 filterSubsumed :: [InteractiveImport] -> [InteractiveImport]
1820 -> [InteractiveImport]
1821 filterSubsumed is js = filter (\j -> not (any (`iiSubsumes` j) is)) js
1822
1823 -- | Returns True if the left import subsumes the right one. Doesn't
1824 -- need to be 100% accurate, conservatively returning False is fine.
1825 -- (EXCEPT: (IIModule m) *must* subsume itself, otherwise a panic in
1826 -- plusProv will ensue (#5904))
1827 --
1828 -- Note that an IIModule does not necessarily subsume an IIDecl,
1829 -- because e.g. a module might export a name that is only available
1830 -- qualified within the module itself.
1831 --
1832 -- Note that 'import M' does not necessarily subsume 'import M(foo)',
1833 -- because M might not export foo and we want an error to be produced
1834 -- in that case.
1835 --
1836 iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool
1837 iiSubsumes (IIModule m1) (IIModule m2) = m1==m2
1838 iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude
1839 = unLoc (ideclName d1) == unLoc (ideclName d2)
1840 && ideclAs d1 == ideclAs d2
1841 && (not (ideclQualified d1) || ideclQualified d2)
1842 && (ideclHiding d1 `hidingSubsumes` ideclHiding d2)
1843 where
1844 _ `hidingSubsumes` Just (False,[]) = True
1845 Just (False, xs) `hidingSubsumes` Just (False,ys) = all (`elem` xs) ys
1846 h1 `hidingSubsumes` h2 = h1 == h2
1847 iiSubsumes _ _ = False
1848
1849
1850 ----------------------------------------------------------------------------
1851 -- :set
1852
1853 -- set options in the interpreter. Syntax is exactly the same as the
1854 -- ghc command line, except that certain options aren't available (-C,
1855 -- -E etc.)
1856 --
1857 -- This is pretty fragile: most options won't work as expected. ToDo:
1858 -- figure out which ones & disallow them.
1859
1860 setCmd :: String -> GHCi ()
1861 setCmd "" = showOptions False
1862 setCmd "-a" = showOptions True
1863 setCmd str
1864 = case getCmd str of
1865 Right ("args", rest) ->
1866 case toArgs rest of
1867 Left err -> liftIO (hPutStrLn stderr err)
1868 Right args -> setArgs args
1869 Right ("prog", rest) ->
1870 case toArgs rest of
1871 Right [prog] -> setProg prog
1872 _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")
1873 Right ("prompt", rest) -> setPrompt $ Just $ dropWhile isSpace rest
1874 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1875 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1876 _ -> case toArgs str of
1877 Left err -> liftIO (hPutStrLn stderr err)
1878 Right wds -> setOptions wds
1879
1880 setiCmd :: String -> GHCi ()
1881 setiCmd "" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False
1882 setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True
1883 setiCmd str =
1884 case toArgs str of
1885 Left err -> liftIO (hPutStrLn stderr err)
1886 Right wds -> newDynFlags True wds
1887
1888 showOptions :: Bool -> GHCi ()
1889 showOptions show_all
1890 = do st <- getGHCiState
1891 dflags <- getDynFlags
1892 let opts = options st
1893 liftIO $ putStrLn (showSDoc dflags (
1894 text "options currently set: " <>
1895 if null opts
1896 then text "none."
1897 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1898 ))
1899 getDynFlags >>= liftIO . showDynFlags show_all
1900
1901
1902 showDynFlags :: Bool -> DynFlags -> IO ()
1903 showDynFlags show_all dflags = do
1904 showLanguages' show_all dflags
1905 putStrLn $ showSDoc dflags $
1906 text "GHCi-specific dynamic flag settings:" $$
1907 nest 2 (vcat (map (setting dopt) ghciFlags))
1908 putStrLn $ showSDoc dflags $
1909 text "other dynamic, non-language, flag settings:" $$
1910 nest 2 (vcat (map (setting dopt) others))
1911 putStrLn $ showSDoc dflags $
1912 text "warning settings:" $$
1913 nest 2 (vcat (map (setting wopt) DynFlags.fWarningFlags))
1914 where
1915 setting test (str, f, _)
1916 | quiet = empty
1917 | is_on = fstr str
1918 | otherwise = fnostr str
1919 where is_on = test f dflags
1920 quiet = not show_all && test f default_dflags == is_on
1921
1922 default_dflags = defaultDynFlags (settings dflags)
1923
1924 fstr str = text "-f" <> text str
1925 fnostr str = text "-fno-" <> text str
1926
1927 (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flgs)
1928 DynFlags.fFlags
1929 flgs = [Opt_PrintExplicitForalls
1930 ,Opt_PrintBindResult
1931 ,Opt_BreakOnException
1932 ,Opt_BreakOnError
1933 ,Opt_PrintEvldWithShow
1934 ]
1935
1936 setArgs, setOptions :: [String] -> GHCi ()
1937 setProg, setEditor, setStop :: String -> GHCi ()
1938
1939 setArgs args = do
1940 st <- getGHCiState
1941 setGHCiState st{ GhciMonad.args = args }
1942
1943 setProg prog = do
1944 st <- getGHCiState
1945 setGHCiState st{ progname = prog }
1946
1947 setEditor cmd = do
1948 st <- getGHCiState
1949 setGHCiState st{ editor = cmd }
1950
1951 setStop str@(c:_) | isDigit c
1952 = do let (nm_str,rest) = break (not.isDigit) str
1953 nm = read nm_str
1954 st <- getGHCiState
1955 let old_breaks = breaks st
1956 if all ((/= nm) . fst) old_breaks
1957 then printForUser (text "Breakpoint" <+> ppr nm <+>
1958 text "does not exist")
1959 else do
1960 let new_breaks = map fn old_breaks
1961 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1962 | otherwise = (i,loc)
1963 setGHCiState st{ breaks = new_breaks }
1964 setStop cmd = do
1965 st <- getGHCiState
1966 setGHCiState st{ stop = cmd }
1967
1968 setPrompt :: Maybe String -> GHCi ()
1969 setPrompt Nothing = do
1970 st <- getGHCiState
1971 setGHCiState ( st { prompt = def_prompt st } )
1972
1973 setPrompt (Just value) = do
1974 st <- getGHCiState
1975 if null value
1976 then liftIO $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1977 else case value of
1978 '\"' : _ -> case reads value of
1979 [(value', xs)] | all isSpace xs ->
1980 setGHCiState (st { prompt = value' })
1981 _ ->
1982 liftIO $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
1983 _ -> setGHCiState (st { prompt = value })
1984
1985 setOptions wds =
1986 do -- first, deal with the GHCi opts (+s, +t, etc.)
1987 let (plus_opts, minus_opts) = partitionWith isPlus wds
1988 mapM_ setOpt plus_opts
1989 -- then, dynamic flags
1990 newDynFlags False minus_opts
1991
1992 newDynFlags :: Bool -> [String] -> GHCi ()
1993 newDynFlags interactive_only minus_opts = do
1994 let lopts = map noLoc minus_opts
1995
1996 idflags0 <- GHC.getInteractiveDynFlags
1997 (idflags1, leftovers, warns) <- GHC.parseDynamicFlags idflags0 lopts
1998
1999 liftIO $ handleFlagWarnings idflags1 warns
2000 when (not $ null leftovers)
2001 (ghcError . CmdLineError
2002 $ "Some flags have not been recognized: "
2003 ++ (concat . intersperse ", " $ map unLoc leftovers))
2004
2005 when (interactive_only &&
2006 packageFlags idflags1 /= packageFlags idflags0) $ do
2007 liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"
2008 GHC.setInteractiveDynFlags idflags1
2009 installInteractivePrint (interactivePrint idflags1) False
2010
2011 dflags0 <- getDynFlags
2012 when (not interactive_only) $ do
2013 (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags dflags0 lopts
2014 new_pkgs <- GHC.setProgramDynFlags dflags1
2015
2016 -- if the package flags changed, reset the context and link
2017 -- the new packages.
2018 dflags2 <- getDynFlags
2019 when (packageFlags dflags2 /= packageFlags dflags0) $ do
2020 liftIO $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
2021 GHC.setTargets []
2022 _ <- GHC.load LoadAllTargets
2023 liftIO $ linkPackages dflags2 new_pkgs
2024 -- package flags changed, we can't re-use any of the old context
2025 setContextAfterLoad False []
2026 -- and copy the package state to the interactive DynFlags
2027 idflags <- GHC.getInteractiveDynFlags
2028 GHC.setInteractiveDynFlags
2029 idflags{ pkgState = pkgState dflags2
2030 , pkgDatabase = pkgDatabase dflags2
2031 , packageFlags = packageFlags dflags2 }
2032
2033 return ()
2034
2035
2036 unsetOptions :: String -> GHCi ()
2037 unsetOptions str
2038 = -- first, deal with the GHCi opts (+s, +t, etc.)
2039 let opts = words str
2040 (minus_opts, rest1) = partition isMinus opts
2041 (plus_opts, rest2) = partitionWith isPlus rest1
2042 (other_opts, rest3) = partition (`elem` map fst defaulters) rest2
2043
2044 defaulters =
2045 [ ("args" , setArgs default_args)
2046 , ("prog" , setProg default_progname)
2047 , ("prompt", setPrompt Nothing)
2048 , ("editor", liftIO findEditor >>= setEditor)
2049 , ("stop" , setStop default_stop)
2050 ]
2051
2052 no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
2053 no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
2054
2055 in if (not (null rest3))
2056 then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))
2057 else do
2058 mapM_ (fromJust.flip lookup defaulters) other_opts
2059
2060 mapM_ unsetOpt plus_opts
2061
2062 no_flags <- mapM no_flag minus_opts
2063 newDynFlags False no_flags
2064
2065 isMinus :: String -> Bool
2066 isMinus ('-':_) = True
2067 isMinus _ = False
2068
2069 isPlus :: String -> Either String String
2070 isPlus ('+':opt) = Left opt
2071 isPlus other = Right other
2072
2073 setOpt, unsetOpt :: String -> GHCi ()
2074
2075 setOpt str
2076 = case strToGHCiOpt str of
2077 Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
2078 Just o -> setOption o
2079
2080 unsetOpt str
2081 = case strToGHCiOpt str of
2082 Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
2083 Just o -> unsetOption o
2084
2085 strToGHCiOpt :: String -> (Maybe GHCiOption)
2086 strToGHCiOpt "m" = Just Multiline
2087 strToGHCiOpt "s" = Just ShowTiming
2088 strToGHCiOpt "t" = Just ShowType
2089 strToGHCiOpt "r" = Just RevertCAFs
2090 strToGHCiOpt _ = Nothing
2091
2092 optToStr :: GHCiOption -> String
2093 optToStr Multiline = "m"
2094 optToStr ShowTiming = "s"
2095 optToStr ShowType = "t"
2096 optToStr RevertCAFs = "r"
2097
2098
2099 -- ---------------------------------------------------------------------------
2100 -- :show
2101
2102 showCmd :: String -> GHCi ()
2103 showCmd "" = showOptions False
2104 showCmd "-a" = showOptions True
2105 showCmd str = do
2106 st <- getGHCiState
2107 case words str of
2108 ["args"] -> liftIO $ putStrLn (show (GhciMonad.args st))
2109 ["prog"] -> liftIO $ putStrLn (show (progname st))
2110 ["prompt"] -> liftIO $ putStrLn (show (prompt st))
2111 ["editor"] -> liftIO $ putStrLn (show (editor st))
2112 ["stop"] -> liftIO $ putStrLn (show (stop st))
2113 ["imports"] -> showImports
2114 ["modules" ] -> showModules
2115 ["bindings"] -> showBindings
2116 ["linker"] ->
2117 do dflags <- getDynFlags
2118 liftIO $ showLinkerState dflags
2119 ["breaks"] -> showBkptTable
2120 ["context"] -> showContext
2121 ["packages"] -> showPackages
2122 ["languages"] -> showLanguages -- backwards compat
2123 ["language"] -> showLanguages
2124 ["lang"] -> showLanguages -- useful abbreviation
2125 _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
2126 " | breaks | context | packages | language ]"))
2127
2128 showiCmd :: String -> GHCi ()
2129 showiCmd str = do
2130 case words str of
2131 ["languages"] -> showiLanguages -- backwards compat
2132 ["language"] -> showiLanguages
2133 ["lang"] -> showiLanguages -- useful abbreviation
2134 _ -> ghcError (CmdLineError ("syntax: :showi language"))
2135
2136 showImports :: GHCi ()
2137 showImports = do
2138 st <- getGHCiState
2139 dflags <- getDynFlags
2140 let rem_ctx = reverse (remembered_ctx st)
2141 trans_ctx = transient_ctx st
2142
2143 show_one (IIModule star_m)
2144 = ":module +*" ++ moduleNameString star_m
2145 show_one (IIDecl imp) = showPpr dflags imp
2146
2147 prel_imp
2148 | any isPreludeImport (rem_ctx ++ trans_ctx) = []
2149 | otherwise = ["import Prelude -- implicit"]
2150
2151 trans_comment s = s ++ " -- added automatically"
2152 --
2153 liftIO $ mapM_ putStrLn (prel_imp ++ map show_one rem_ctx
2154 ++ map (trans_comment . show_one) trans_ctx)
2155
2156 showModules :: GHCi ()
2157 showModules = do
2158 loaded_mods <- getLoadedModules
2159 -- we want *loaded* modules only, see #1734
2160 let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)
2161 mapM_ show_one loaded_mods
2162
2163 getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
2164 getLoadedModules = do
2165 graph <- GHC.getModuleGraph
2166 filterM (GHC.isLoaded . GHC.ms_mod_name) graph
2167
2168 showBindings :: GHCi ()
2169 showBindings = do
2170 bindings <- GHC.getBindings
2171 (insts, finsts) <- GHC.getInsts
2172 docs <- mapM makeDoc (reverse bindings)
2173 -- reverse so the new ones come last
2174 let idocs = map GHC.pprInstanceHdr insts
2175 fidocs = map GHC.pprFamInstHdr finsts
2176 mapM_ printForUserPartWay (docs ++ idocs ++ fidocs)
2177 where
2178 makeDoc (AnId i) = pprTypeAndContents i
2179 makeDoc tt = do
2180 dflags <- getDynFlags
2181 let pefas = dopt Opt_PrintExplicitForalls dflags
2182 mb_stuff <- GHC.getInfo (getName tt)
2183 return $ maybe (text "") (pprTT pefas) mb_stuff
2184 pprTT :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.ClsInst]) -> SDoc
2185 pprTT pefas (thing, fixity, _insts) =
2186 pprTyThing pefas thing
2187 $$ show_fixity
2188 where
2189 show_fixity
2190 | fixity == GHC.defaultFixity = empty
2191 | otherwise = ppr fixity <+> ppr (GHC.getName thing)
2192
2193
2194 printTyThing :: TyThing -> GHCi ()
2195 printTyThing tyth = do dflags <- getDynFlags
2196 let pefas = dopt Opt_PrintExplicitForalls dflags
2197 printForUser (pprTyThing pefas tyth)
2198
2199 showBkptTable :: GHCi ()
2200 showBkptTable = do
2201 st <- getGHCiState
2202 printForUser $ prettyLocations (breaks st)
2203
2204 showContext :: GHCi ()
2205 showContext = do
2206 resumes <- GHC.getResumeContext
2207 printForUser $ vcat (map pp_resume (reverse resumes))
2208 where
2209 pp_resume res =
2210 ptext (sLit "--> ") <> text (GHC.resumeStmt res)
2211 $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan res))
2212
2213 showPackages :: GHCi ()
2214 showPackages = do
2215 dflags <- getDynFlags
2216 let pkg_flags = packageFlags dflags
2217 liftIO $ putStrLn $ showSDoc dflags $ vcat $
2218 text ("active package flags:"++if null pkg_flags then " none" else "")
2219 : map showFlag pkg_flags
2220 where showFlag (ExposePackage p) = text $ " -package " ++ p
2221 showFlag (HidePackage p) = text $ " -hide-package " ++ p
2222 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
2223 showFlag (ExposePackageId p) = text $ " -package-id " ++ p
2224 showFlag (TrustPackage p) = text $ " -trust " ++ p
2225 showFlag (DistrustPackage p) = text $ " -distrust " ++ p
2226
2227 showLanguages :: GHCi ()
2228 showLanguages = getDynFlags >>= liftIO . showLanguages' False
2229
2230 showiLanguages :: GHCi ()
2231 showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False
2232
2233 showLanguages' :: Bool -> DynFlags -> IO ()
2234 showLanguages' show_all dflags =
2235 putStrLn $ showSDoc dflags $ vcat
2236 [ text "base language is: " <>
2237 case language dflags of
2238 Nothing -> text "Haskell2010"
2239 Just Haskell98 -> text "Haskell98"
2240 Just Haskell2010 -> text "Haskell2010"
2241 , (if show_all then text "all active language options:"
2242 else text "with the following modifiers:") $$
2243 nest 2 (vcat (map (setting xopt) DynFlags.xFlags))
2244 ]
2245 where
2246 setting test (str, f, _)
2247 | quiet = empty
2248 | is_on = text "-X" <> text str
2249 | otherwise = text "-XNo" <> text str
2250 where is_on = test f dflags
2251 quiet = not show_all && test f default_dflags == is_on
2252
2253 default_dflags =
2254 defaultDynFlags (settings dflags) `lang_set`
2255 case language dflags of
2256 Nothing -> Just Haskell2010
2257 other -> other
2258
2259 -- -----------------------------------------------------------------------------
2260 -- Completion
2261
2262 completeCmd, completeMacro, completeIdentifier, completeModule,
2263 completeSetModule, completeSeti, completeShowiOptions,
2264 completeHomeModule, completeSetOptions, completeShowOptions,
2265 completeHomeModuleOrFile, completeExpression
2266 :: CompletionFunc GHCi
2267
2268 ghciCompleteWord :: CompletionFunc GHCi
2269 ghciCompleteWord line@(left,_) = case firstWord of
2270 ':':cmd | null rest -> completeCmd line
2271 | otherwise -> do
2272 completion <- lookupCompletion cmd
2273 completion line
2274 "import" -> completeModule line
2275 _ -> completeExpression line
2276 where
2277 (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
2278 lookupCompletion ('!':_) = return completeFilename
2279 lookupCompletion c = do
2280 maybe_cmd <- lookupCommand' c
2281 case maybe_cmd of
2282 Just (_,_,f) -> return f
2283 Nothing -> return completeFilename
2284
2285 completeCmd = wrapCompleter " " $ \w -> do
2286 macros <- liftIO $ readIORef macros_ref
2287 cmds <- ghci_commands `fmap` getGHCiState
2288 let macro_names = map (':':) . map cmdName $ macros
2289 let command_names = map (':':) . map cmdName $ cmds
2290 let{ candidates = case w of
2291 ':' : ':' : _ -> map (':':) command_names
2292 _ -> nub $ macro_names ++ command_names }
2293 return $ filter (w `isPrefixOf`) candidates
2294
2295 completeMacro = wrapIdentCompleter $ \w -> do
2296 cmds <- liftIO $ readIORef macros_ref
2297 return (filter (w `isPrefixOf`) (map cmdName cmds))
2298
2299 completeIdentifier = wrapIdentCompleter $ \w -> do
2300 rdrs <- GHC.getRdrNamesInScope
2301 dflags <- GHC.getSessionDynFlags
2302 return (filter (w `isPrefixOf`) (map (showPpr dflags) rdrs))
2303
2304 completeModule = wrapIdentCompleter $ \w -> do
2305 dflags <- GHC.getSessionDynFlags
2306 let pkg_mods = allExposedModules dflags
2307 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
2308 return $ filter (w `isPrefixOf`)
2309 $ map (showPpr dflags) $ loaded_mods ++ pkg_mods
2310
2311 completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
2312 dflags <- GHC.getSessionDynFlags
2313 modules <- case m of
2314 Just '-' -> do
2315 imports <- GHC.getContext
2316 return $ map iiModuleName imports
2317 _ -> do
2318 let pkg_mods = allExposedModules dflags
2319 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
2320 return $ loaded_mods ++ pkg_mods
2321 return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules
2322
2323 completeHomeModule = wrapIdentCompleter listHomeModules
2324
2325 listHomeModules :: String -> GHCi [String]
2326 listHomeModules w = do
2327 g <- GHC.getModuleGraph
2328 let home_mods = map GHC.ms_mod_name g
2329 dflags <- getDynFlags
2330 return $ sort $ filter (w `isPrefixOf`)
2331 $ map (showPpr dflags) home_mods
2332
2333 completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
2334 return (filter (w `isPrefixOf`) opts)
2335 where opts = "args":"prog":"prompt":"editor":"stop":flagList
2336 flagList = map head $ group $ sort allFlags
2337
2338 completeSeti = wrapCompleter flagWordBreakChars $ \w -> do
2339 return (filter (w `isPrefixOf`) flagList)
2340 where flagList = map head $ group $ sort allFlags
2341
2342 completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
2343 return (filter (w `isPrefixOf`) opts)
2344 where opts = ["args", "prog", "prompt", "editor", "stop",
2345 "modules", "bindings", "linker", "breaks",
2346 "context", "packages", "language"]
2347
2348 completeShowiOptions = wrapCompleter flagWordBreakChars $ \w -> do
2349 return (filter (w `isPrefixOf`) ["language"])
2350
2351 completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
2352 $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
2353 listFiles
2354
2355 unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
2356 unionComplete f1 f2 line = do
2357 cs1 <- f1 line
2358 cs2 <- f2 line
2359 return (cs1 ++ cs2)
2360
2361 wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
2362 wrapCompleter breakChars fun = completeWord Nothing breakChars
2363 $ fmap (map simpleCompletion) . fmap sort . fun
2364
2365 wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
2366 wrapIdentCompleter = wrapCompleter word_break_chars
2367
2368 wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi
2369 wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars
2370 $ \rest -> fmap (map simpleCompletion) . fmap sort . fun (getModifier rest)
2371 where
2372 getModifier = find (`elem` modifChars)
2373
2374 allExposedModules :: DynFlags -> [ModuleName]
2375 allExposedModules dflags
2376 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
2377 where
2378 pkg_db = pkgIdMap (pkgState dflags)
2379
2380 completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
2381 completeIdentifier
2382
2383
2384 -- -----------------------------------------------------------------------------
2385 -- commands for debugger
2386
2387 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
2388 sprintCmd = pprintCommand False False
2389 printCmd = pprintCommand True False
2390 forceCmd = pprintCommand False True
2391
2392 pprintCommand :: Bool -> Bool -> String -> GHCi ()
2393 pprintCommand bind force str = do
2394 pprintClosureCommand bind force str
2395
2396 stepCmd :: String -> GHCi ()
2397 stepCmd arg = withSandboxOnly ":step" $ step arg
2398 where
2399 step [] = doContinue (const True) GHC.SingleStep
2400 step expression = runStmt expression GHC.SingleStep >> return ()
2401
2402 stepLocalCmd :: String -> GHCi ()
2403 stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg
2404 where
2405 step expr
2406 | not (null expr) = stepCmd expr
2407 | otherwise = do
2408 mb_span <- getCurrentBreakSpan
2409 case mb_span of
2410 Nothing -> stepCmd []
2411 Just loc -> do
2412 Just md <- getCurrentBreakModule
2413 current_toplevel_decl <- enclosingTickSpan md loc
2414 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
2415
2416 stepModuleCmd :: String -> GHCi ()
2417 stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg
2418 where
2419 step expr
2420 | not (null expr) = stepCmd expr
2421 | otherwise = do
2422 mb_span <- getCurrentBreakSpan
2423 case mb_span of
2424 Nothing -> stepCmd []
2425 Just pan -> do
2426 let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span
2427 doContinue f GHC.SingleStep
2428
2429 -- | Returns the span of the largest tick containing the srcspan given
2430 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
2431 enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
2432 enclosingTickSpan md (RealSrcSpan src) = do
2433 ticks <- getTickArray md
2434 let line = srcSpanStartLine src
2435 ASSERT (inRange (bounds ticks) line) do
2436 let toRealSrcSpan (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
2437 toRealSrcSpan (RealSrcSpan s) = s
2438 enclosing_spans = [ pan | (_,pan) <- ticks ! line
2439 , realSrcSpanEnd (toRealSrcSpan pan) >= realSrcSpanEnd src]
2440 return . head . sortBy leftmost_largest $ enclosing_spans
2441
2442 traceCmd :: String -> GHCi ()
2443 traceCmd arg
2444 = withSandboxOnly ":trace" $ tr arg
2445 where
2446 tr [] = doContinue (const True) GHC.RunAndLogSteps
2447 tr expression = runStmt expression GHC.RunAndLogSteps >> return ()
2448
2449 continueCmd :: String -> GHCi ()
2450 continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion
2451
2452 -- doContinue :: SingleStep -> GHCi ()
2453 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
2454 doContinue pre step = do
2455 runResult <- resume pre step
2456 _ <- afterRunStmt pre runResult
2457 return ()
2458
2459 abandonCmd :: String -> GHCi ()
2460 abandonCmd = noArgs $ withSandboxOnly ":abandon" $ do
2461 b <- GHC.abandon -- the prompt will change to indicate the new context
2462 when (not b) $ liftIO $ putStrLn "There is no computation running."
2463
2464 deleteCmd :: String -> GHCi ()
2465 deleteCmd argLine = withSandboxOnly ":delete" $ do
2466 deleteSwitch $ words argLine
2467 where
2468 deleteSwitch :: [String] -> GHCi ()
2469 deleteSwitch [] =
2470 liftIO $ putStrLn "The delete command requires at least one argument."
2471 -- delete all break points
2472 deleteSwitch ("*":_rest) = discardActiveBreakPoints
2473 deleteSwitch idents = do
2474 mapM_ deleteOneBreak idents
2475 where
2476 deleteOneBreak :: String -> GHCi ()
2477 deleteOneBreak str
2478 | all isDigit str = deleteBreak (read str)
2479 | otherwise = return ()
2480
2481 historyCmd :: String -> GHCi ()
2482 historyCmd arg
2483 | null arg = history 20
2484 | all isDigit arg = history (read arg)
2485 | otherwise = liftIO $ putStrLn "Syntax: :history [num]"
2486 where
2487 history num = do
2488 resumes <- GHC.getResumeContext
2489 case resumes of
2490 [] -> liftIO $ putStrLn "Not stopped at a breakpoint"
2491 (r:_) -> do
2492 let hist = GHC.resumeHistory r
2493 (took,rest) = splitAt num hist
2494 case hist of
2495 [] -> liftIO $ putStrLn $
2496 "Empty history. Perhaps you forgot to use :trace?"
2497 _ -> do
2498 pans <- mapM GHC.getHistorySpan took
2499 let nums = map (printf "-%-3d:") [(1::Int)..]
2500 names = map GHC.historyEnclosingDecls took
2501 printForUser (vcat(zipWith3
2502 (\x y z -> x <+> y <+> z)
2503 (map text nums)
2504 (map (bold . hcat . punctuate colon . map text) names)
2505 (map (parens . ppr) pans)))
2506 liftIO $ putStrLn $ if null rest then "<end of history>" else "..."
2507
2508 bold :: SDoc -> SDoc
2509 bold c | do_bold = text start_bold <> c <> text end_bold
2510 | otherwise = c
2511
2512 backCmd :: String -> GHCi ()
2513 backCmd = noArgs $ withSandboxOnly ":back" $ do
2514 (names, _, pan) <- GHC.back
2515 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan
2516 printTypeOfNames names
2517 -- run the command set with ":set stop <cmd>"
2518 st <- getGHCiState
2519 enqueueCommands [stop st]
2520
2521 forwardCmd :: String -> GHCi ()
2522 forwardCmd = noArgs $ withSandboxOnly ":forward" $ do
2523 (names, ix, pan) <- GHC.forward
2524 printForUser $ (if (ix == 0)
2525 then ptext (sLit "Stopped at")
2526 else ptext (sLit "Logged breakpoint at")) <+> ppr pan
2527 printTypeOfNames names
2528 -- run the command set with ":set stop <cmd>"
2529 st <- getGHCiState
2530 enqueueCommands [stop st]
2531
2532 -- handle the "break" command
2533 breakCmd :: String -> GHCi ()
2534 breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine
2535
2536 breakSwitch :: [String] -> GHCi ()
2537 breakSwitch [] = do
2538 liftIO $ putStrLn "The break command requires at least one argument."
2539 breakSwitch (arg1:rest)
2540 | looksLikeModuleName arg1 && not (null rest) = do
2541 md <- wantInterpretedModule arg1
2542 breakByModule md rest
2543 | all isDigit arg1 = do
2544 imports <- GHC.getContext
2545 case iiModules imports of
2546 (mn : _) -> do
2547 md <- lookupModuleName mn
2548 breakByModuleLine md (read arg1) rest
2549 [] -> do
2550 liftIO $ putStrLn "No modules are loaded with debugging support."
2551 | otherwise = do -- try parsing it as an identifier
2552 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
2553 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2554 case loc of
2555 RealSrcLoc l ->
2556 ASSERT( isExternalName name )
2557 findBreakAndSet (GHC.nameModule name) $
2558 findBreakByCoord (Just (GHC.srcLocFile l))
2559 (GHC.srcLocLine l,
2560 GHC.srcLocCol l)
2561 UnhelpfulLoc _ ->
2562 noCanDo name $ text "can't find its location: " <> ppr loc
2563 where
2564 noCanDo n why = printForUser $
2565 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
2566
2567 breakByModule :: Module -> [String] -> GHCi ()
2568 breakByModule md (arg1:rest)
2569 | all isDigit arg1 = do -- looks like a line number
2570 breakByModuleLine md (read arg1) rest
2571 breakByModule _ _
2572 = breakSyntax
2573
2574 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
2575 breakByModuleLine md line args
2576 | [] <- args = findBreakAndSet md $ findBreakByLine line
2577 | [col] <- args, all isDigit col =
2578 findBreakAndSet md $ findBreakByCoord Nothing (line, read col)
2579 | otherwise = breakSyntax
2580
2581 breakSyntax :: a
2582 breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
2583
2584 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
2585 findBreakAndSet md lookupTickTree = do
2586 tickArray <- getTickArray md
2587 (breakArray, _) <- getModBreak md
2588 case lookupTickTree tickArray of
2589 Nothing -> liftIO $ putStrLn $ "No breakpoints found at that location."
2590 Just (tick, pan) -> do
2591 success <- liftIO $ setBreakFlag True breakArray tick
2592 if success
2593 then do
2594 (alreadySet, nm) <-
2595 recordBreak $ BreakLocation
2596 { breakModule = md
2597 , breakLoc = pan
2598 , breakTick = tick
2599 , onBreakCmd = ""
2600 }
2601 printForUser $
2602 text "Breakpoint " <> ppr nm <>
2603 if alreadySet
2604 then text " was already set at " <> ppr pan
2605 else text " activated at " <> ppr pan
2606 else do
2607 printForUser $ text "Breakpoint could not be activated at"
2608 <+> ppr pan
2609
2610 -- When a line number is specified, the current policy for choosing
2611 -- the best breakpoint is this:
2612 -- - the leftmost complete subexpression on the specified line, or
2613 -- - the leftmost subexpression starting on the specified line, or
2614 -- - the rightmost subexpression enclosing the specified line
2615 --
2616 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2617 findBreakByLine line arr
2618 | not (inRange (bounds arr) line) = Nothing
2619 | otherwise =
2620 listToMaybe (sortBy (leftmost_largest `on` snd) comp) `mplus`
2621 listToMaybe (sortBy (leftmost_smallest `on` snd) incomp) `mplus`
2622 listToMaybe (sortBy (rightmost `on` snd) ticks)
2623 where
2624 ticks = arr ! line
2625
2626 starts_here = [ tick | tick@(_,pan) <- ticks,
2627 GHC.srcSpanStartLine (toRealSpan pan) == line ]
2628
2629 (comp, incomp) = partition ends_here starts_here
2630 where ends_here (_,pan) = GHC.srcSpanEndLine (toRealSpan pan) == line
2631 toRealSpan (RealSrcSpan pan) = pan
2632 toRealSpan (UnhelpfulSpan _) = panic "findBreakByLine UnhelpfulSpan"
2633
2634 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2635 -> Maybe (BreakIndex,SrcSpan)
2636 findBreakByCoord mb_file (line, col) arr
2637 | not (inRange (bounds arr) line) = Nothing
2638 | otherwise =
2639 listToMaybe (sortBy (rightmost `on` snd) contains ++
2640 sortBy (leftmost_smallest `on` snd) after_here)
2641 where
2642 ticks = arr ! line
2643
2644 -- the ticks that span this coordinate
2645 contains = [ tick | tick@(_,pan) <- ticks, pan `spans` (line,col),
2646 is_correct_file pan ]
2647
2648 is_correct_file pan
2649 | Just f <- mb_file = GHC.srcSpanFile (toRealSpan pan) == f
2650 | otherwise = True
2651
2652 after_here = [ tick | tick@(_,pan) <- ticks,
2653 let pan' = toRealSpan pan,
2654 GHC.srcSpanStartLine pan' == line,
2655 GHC.srcSpanStartCol pan' >= col ]
2656
2657 toRealSpan (RealSrcSpan pan) = pan
2658 toRealSpan (UnhelpfulSpan _) = panic "findBreakByCoord UnhelpfulSpan"
2659
2660 -- For now, use ANSI bold on terminals that we know support it.
2661 -- Otherwise, we add a line of carets under the active expression instead.
2662 -- In particular, on Windows and when running the testsuite (which sets
2663 -- TERM to vt100 for other reasons) we get carets.
2664 -- We really ought to use a proper termcap/terminfo library.
2665 do_bold :: Bool
2666 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2667 where mTerm = System.Environment.getEnv "TERM"
2668 `catchIO` \_ -> return "TERM not set"
2669
2670 start_bold :: String
2671 start_bold = "\ESC[1m"
2672 end_bold :: String
2673 end_bold = "\ESC[0m"
2674
2675
2676 -----------------------------------------------------------------------------
2677 -- :list
2678
2679 listCmd :: String -> InputT GHCi ()
2680 listCmd c = listCmd' c
2681
2682 listCmd' :: String -> InputT GHCi ()
2683 listCmd' "" = do
2684 mb_span <- lift getCurrentBreakSpan
2685 case mb_span of
2686 Nothing ->
2687 printForUser $ text "Not stopped at a breakpoint; nothing to list"
2688 Just (RealSrcSpan pan) ->
2689 listAround pan True
2690 Just pan@(UnhelpfulSpan _) ->
2691 do resumes <- GHC.getResumeContext
2692 case resumes of
2693 [] -> panic "No resumes"
2694 (r:_) ->
2695 do let traceIt = case GHC.resumeHistory r of
2696 [] -> text "rerunning with :trace,"
2697 _ -> empty
2698 doWhat = traceIt <+> text ":back then :list"
2699 printForUser (text "Unable to list source for" <+>
2700 ppr pan
2701 $$ text "Try" <+> doWhat)
2702 listCmd' str = list2 (words str)
2703
2704 list2 :: [String] -> InputT GHCi ()
2705 list2 [arg] | all isDigit arg = do
2706 imports <- GHC.getContext
2707 case iiModules imports of
2708 [] -> liftIO $ putStrLn "No module to list"
2709 (mn : _) -> do
2710 md <- lift $ lookupModuleName mn
2711 listModuleLine md (read arg)
2712 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2713 md <- wantInterpretedModule arg1
2714 listModuleLine md (read arg2)
2715 list2 [arg] = do
2716 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2717 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2718 case loc of
2719 RealSrcLoc l ->
2720 do tickArray <- ASSERT( isExternalName name )
2721 lift $ getTickArray (GHC.nameModule name)
2722 let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))
2723 (GHC.srcLocLine l, GHC.srcLocCol l)
2724 tickArray
2725 case mb_span of
2726 Nothing -> listAround (realSrcLocSpan l) False
2727 Just (_, UnhelpfulSpan _) -> panic "list2 UnhelpfulSpan"
2728 Just (_, RealSrcSpan pan) -> listAround pan False
2729 UnhelpfulLoc _ ->
2730 noCanDo name $ text "can't find its location: " <>
2731 ppr loc
2732 where
2733 noCanDo n why = printForUser $
2734 text "cannot list source code for " <> ppr n <> text ": " <> why
2735 list2 _other =
2736 liftIO $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2737
2738 listModuleLine :: Module -> Int -> InputT GHCi ()
2739 listModuleLine modl line = do
2740 graph <- GHC.getModuleGraph
2741 let this = filter ((== modl) . GHC.ms_mod) graph
2742 case this of
2743 [] -> panic "listModuleLine"
2744 summ:_ -> do
2745 let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
2746 loc = mkRealSrcLoc (mkFastString (filename)) line 0
2747 listAround (realSrcLocSpan loc) False
2748
2749 -- | list a section of a source file around a particular SrcSpan.
2750 -- If the highlight flag is True, also highlight the span using
2751 -- start_bold\/end_bold.
2752
2753 -- GHC files are UTF-8, so we can implement this by:
2754 -- 1) read the file in as a BS and syntax highlight it as before
2755 -- 2) convert the BS to String using utf-string, and write it out.
2756 -- It would be better if we could convert directly between UTF-8 and the
2757 -- console encoding, of course.
2758 listAround :: MonadIO m => RealSrcSpan -> Bool -> InputT m ()
2759 listAround pan do_highlight = do
2760 contents <- liftIO $ BS.readFile (unpackFS file)
2761 let ls = BS.split '\n' contents
2762 ls' = take (line2 - line1 + 1 + pad_before + pad_after) $
2763 drop (line1 - 1 - pad_before) $ ls
2764 fst_line = max 1 (line1 - pad_before)
2765 line_nos = [ fst_line .. ]
2766
2767 highlighted | do_highlight = zipWith highlight line_nos ls'
2768 | otherwise = [\p -> BS.concat[p,l] | l <- ls']
2769
2770 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2771 prefixed = zipWith ($) highlighted bs_line_nos
2772 output = BS.intercalate (BS.pack "\n") prefixed
2773
2774 utf8Decoded <- liftIO $ BS.useAsCStringLen output
2775 $ \(p,n) -> utf8DecodeString (castPtr p) n
2776 liftIO $ putStrLn utf8Decoded
2777 where
2778 file = GHC.srcSpanFile pan
2779 line1 = GHC.srcSpanStartLine pan
2780 col1 = GHC.srcSpanStartCol pan - 1
2781 line2 = GHC.srcSpanEndLine pan
2782 col2 = GHC.srcSpanEndCol pan - 1
2783
2784 pad_before | line1 == 1 = 0
2785 | otherwise = 1
2786 pad_after = 1
2787
2788 highlight | do_bold = highlight_bold
2789 | otherwise = highlight_carets
2790
2791 highlight_bold no line prefix
2792 | no == line1 && no == line2
2793 = let (a,r) = BS.splitAt col1 line
2794 (b,c) = BS.splitAt (col2-col1) r
2795 in
2796 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2797 | no == line1
2798 = let (a,b) = BS.splitAt col1 line in
2799 BS.concat [prefix, a, BS.pack start_bold, b]
2800 | no == line2
2801 = let (a,b) = BS.splitAt col2 line in
2802 BS.concat [prefix, a, BS.pack end_bold, b]
2803 | otherwise = BS.concat [prefix, line]
2804
2805 highlight_carets no line prefix
2806 | no == line1 && no == line2
2807 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2808 BS.replicate (col2-col1) '^']
2809 | no == line1
2810 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2811 prefix, line]
2812 | no == line2
2813 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2814 BS.pack "^^"]
2815 | otherwise = BS.concat [prefix, line]
2816 where
2817 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2818 nl = BS.singleton '\n'
2819
2820
2821 -- --------------------------------------------------------------------------
2822 -- Tick arrays
2823
2824 getTickArray :: Module -> GHCi TickArray
2825 getTickArray modl = do
2826 st <- getGHCiState
2827 let arrmap = tickarrays st
2828 case lookupModuleEnv arrmap modl of
2829 Just arr -> return arr
2830 Nothing -> do
2831 (_breakArray, ticks) <- getModBreak modl
2832 let arr = mkTickArray (assocs ticks)
2833 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2834 return arr
2835
2836 discardTickArrays :: GHCi ()
2837 discardTickArrays = do
2838 st <- getGHCiState
2839 setGHCiState st{tickarrays = emptyModuleEnv}
2840
2841 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2842 mkTickArray ticks
2843 = accumArray (flip (:)) [] (1, max_line)
2844 [ (line, (nm,pan)) | (nm,pan) <- ticks,
2845 let pan' = toRealSpan pan,
2846 line <- srcSpanLines pan' ]
2847 where
2848 max_line = foldr max 0 (map (GHC.srcSpanEndLine . toRealSpan . snd) ticks)
2849 srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ]
2850 toRealSpan (RealSrcSpan pan) = pan
2851 toRealSpan (UnhelpfulSpan _) = panic "mkTickArray UnhelpfulSpan"
2852
2853 -- don't reset the counter back to zero?
2854 discardActiveBreakPoints :: GHCi ()
2855 discardActiveBreakPoints = do
2856 st <- getGHCiState
2857 mapM_ (turnOffBreak.snd) (breaks st)
2858 setGHCiState $ st { breaks = [] }
2859
2860 deleteBreak :: Int -> GHCi ()
2861 deleteBreak identity = do
2862 st <- getGHCiState
2863 let oldLocations = breaks st
2864 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2865 if null this
2866 then printForUser (text "Breakpoint" <+> ppr identity <+>
2867 text "does not exist")
2868 else do
2869 mapM_ (turnOffBreak.snd) this
2870 setGHCiState $ st { breaks = rest }
2871
2872 turnOffBreak :: BreakLocation -> GHCi Bool
2873 turnOffBreak loc = do
2874 (arr, _) <- getModBreak (breakModule loc)
2875 liftIO $ setBreakFlag False arr (breakTick loc)
2876
2877 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2878 getModBreak m = do
2879 Just mod_info <- GHC.getModuleInfo m
2880 let modBreaks = GHC.modInfoModBreaks mod_info
2881 let arr = GHC.modBreaks_flags modBreaks
2882 let ticks = GHC.modBreaks_locs modBreaks
2883 return (arr, ticks)
2884
2885 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2886 setBreakFlag toggle arr i
2887 | toggle = GHC.setBreakOn arr i
2888 | otherwise = GHC.setBreakOff arr i
2889
2890
2891 -- ---------------------------------------------------------------------------
2892 -- User code exception handling
2893
2894 -- This is the exception handler for exceptions generated by the
2895 -- user's code and exceptions coming from children sessions;
2896 -- it normally just prints out the exception. The
2897 -- handler must be recursive, in case showing the exception causes
2898 -- more exceptions to be raised.
2899 --
2900 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
2901 -- raising another exception. We therefore don't put the recursive
2902 -- handler arond the flushing operation, so if stderr is closed
2903 -- GHCi will just die gracefully rather than going into an infinite loop.
2904 handler :: SomeException -> GHCi Bool
2905
2906 handler exception = do
2907 flushInterpBuffers
2908 liftIO installSignalHandlers
2909 ghciHandle handler (showException exception >> return False)
2910
2911 showException :: SomeException -> GHCi ()
2912 showException se =
2913 liftIO $ case fromException se of
2914 -- omit the location for CmdLineError:
2915 Just (CmdLineError s) -> putException s
2916 -- ditto:
2917 Just ph@(PhaseFailed {}) -> putException (showGhcException ph "")
2918 Just other_ghc_ex -> putException (show other_ghc_ex)
2919 Nothing ->
2920 case fromException se of
2921 Just UserInterrupt -> putException "Interrupted."
2922 _ -> putException ("*** Exception: " ++ show se)
2923 where
2924 putException = hPutStrLn stderr
2925
2926
2927 -----------------------------------------------------------------------------
2928 -- recursive exception handlers
2929
2930 -- Don't forget to unblock async exceptions in the handler, or if we're
2931 -- in an exception loop (eg. let a = error a in a) the ^C exception
2932 -- may never be delivered. Thanks to Marcin for pointing out the bug.
2933
2934 ghciHandle :: ExceptionMonad m => (SomeException -> m a) -> m a -> m a
2935 ghciHandle h m = gcatch m $ \e -> gunblock (h e)
2936
2937 ghciTry :: GHCi a -> GHCi (Either SomeException a)
2938 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
2939
2940 tryBool :: GHCi a -> GHCi Bool
2941 tryBool m = do
2942 r <- ghciTry m
2943 case r of
2944 Left _ -> return False
2945 Right _ -> return True
2946
2947 -- ----------------------------------------------------------------------------
2948 -- Utils
2949
2950 lookupModule :: GHC.GhcMonad m => String -> m Module
2951 lookupModule mName = lookupModuleName (GHC.mkModuleName mName)
2952
2953 lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module
2954 lookupModuleName mName = GHC.lookupModule mName Nothing
2955
2956 isHomeModule :: Module -> Bool
2957 isHomeModule m = GHC.modulePackageId m == mainPackageId
2958
2959 -- TODO: won't work if home dir is encoded.
2960 -- (changeDirectory may not work either in that case.)
2961 expandPath :: MonadIO m => String -> InputT m String
2962 expandPath = liftIO . expandPathIO
2963
2964 expandPathIO :: String -> IO String
2965 expandPathIO p =
2966 case dropWhile isSpace p of
2967 ('~':d) -> do
2968 tilde <- getHomeDirectory -- will fail if HOME not defined
2969 return (tilde ++ '/':d)
2970 other ->
2971 return other
2972
2973 wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
2974 wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str)
2975
2976 wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module
2977 wantInterpretedModuleName modname = do
2978 modl <- lookupModuleName modname
2979 let str = moduleNameString modname
2980 dflags <- getDynFlags
2981 when (GHC.modulePackageId modl /= thisPackage dflags) $
2982 ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
2983 is_interpreted <- GHC.moduleIsInterpreted modl
2984 when (not is_interpreted) $
2985 ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
2986 return modl
2987
2988 wantNameFromInterpretedModule :: GHC.GhcMonad m
2989 => (Name -> SDoc -> m ())
2990 -> String
2991 -> (Name -> m ())
2992 -> m ()
2993 wantNameFromInterpretedModule noCanDo str and_then =
2994 handleSourceError GHC.printException $ do
2995 names <- GHC.parseName str
2996 case names of
2997 [] -> return ()
2998 (n:_) -> do
2999 let modl = ASSERT( isExternalName n ) GHC.nameModule n
3000 if not (GHC.isExternalName n)
3001 then noCanDo n $ ppr n <>
3002 text " is not defined in an interpreted module"
3003 else do
3004 is_interpreted <- GHC.moduleIsInterpreted modl
3005 if not is_interpreted
3006 then noCanDo n $ text "module " <> ppr modl <>
3007 text " is not interpreted"
3008 else and_then n