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