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