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