Print details of panic messages raised from GHCi (#7844)
[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.Directory
85 import System.Environment
86 import System.Exit ( exitWith, ExitCode(..) )
87 import System.FilePath
88 import System.IO
89 import System.IO.Error
90 import System.IO.Unsafe ( unsafePerformIO )
91 import System.Process
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,_ci,_fi) -> 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
1041 -> (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst GHC.Branched]) -> SDoc
1042 pprInfo pefas (thing, fixity, cls_insts, fam_insts)
1043 = pprTyThingInContextLoc pefas thing
1044 $$ show_fixity
1045 $$ vcat (map GHC.pprInstance cls_insts)
1046 $$ vcat (map GHC.pprFamInst fam_insts)
1047 where
1048 show_fixity
1049 | fixity == GHC.defaultFixity = empty
1050 | otherwise = ppr fixity <+> pprInfixName (GHC.getName thing)
1051
1052 -----------------------------------------------------------------------------
1053 -- :main
1054
1055 runMain :: String -> GHCi ()
1056 runMain s = case toArgs s of
1057 Left err -> liftIO (hPutStrLn stderr err)
1058 Right args ->
1059 do dflags <- getDynFlags
1060 case mainFunIs dflags of
1061 Nothing -> doWithArgs args "main"
1062 Just f -> doWithArgs args f
1063
1064 -----------------------------------------------------------------------------
1065 -- :run
1066
1067 runRun :: String -> GHCi ()
1068 runRun s = case toCmdArgs s of
1069 Left err -> liftIO (hPutStrLn stderr err)
1070 Right (cmd, args) -> doWithArgs args cmd
1071
1072 doWithArgs :: [String] -> String -> GHCi ()
1073 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
1074 show args ++ " (" ++ cmd ++ ")"]
1075
1076 -----------------------------------------------------------------------------
1077 -- :cd
1078
1079 changeDirectory :: String -> InputT GHCi ()
1080 changeDirectory "" = do
1081 -- :cd on its own changes to the user's home directory
1082 either_dir <- liftIO $ tryIO getHomeDirectory
1083 case either_dir of
1084 Left _e -> return ()
1085 Right dir -> changeDirectory dir
1086 changeDirectory dir = do
1087 graph <- GHC.getModuleGraph
1088 when (not (null graph)) $
1089 liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."
1090 GHC.setTargets []
1091 _ <- GHC.load LoadAllTargets
1092 lift $ setContextAfterLoad False []
1093 GHC.workingDirectoryChanged
1094 dir' <- expandPath dir
1095 liftIO $ setCurrentDirectory dir'
1096
1097 trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
1098 trySuccess act =
1099 handleSourceError (\e -> do GHC.printException e
1100 return Failed) $ do
1101 act
1102
1103 -----------------------------------------------------------------------------
1104 -- :edit
1105
1106 editFile :: String -> InputT GHCi ()
1107 editFile str =
1108 do file <- if null str then lift chooseEditFile else return str
1109 st <- lift getGHCiState
1110 let cmd = editor st
1111 when (null cmd)
1112 $ throwGhcException (CmdLineError "editor not set, use :set editor")
1113 code <- liftIO $ system (cmd ++ ' ':file)
1114 when (code == ExitSuccess)
1115 $ reloadModule ""
1116
1117 -- The user didn't specify a file so we pick one for them.
1118 -- Our strategy is to pick the first module that failed to load,
1119 -- or otherwise the first target.
1120 --
1121 -- XXX: Can we figure out what happened if the depndecy analysis fails
1122 -- (e.g., because the porgrammeer mistyped the name of a module)?
1123 -- XXX: Can we figure out the location of an error to pass to the editor?
1124 -- XXX: if we could figure out the list of errors that occured during the
1125 -- last load/reaload, then we could start the editor focused on the first
1126 -- of those.
1127 chooseEditFile :: GHCi String
1128 chooseEditFile =
1129 do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
1130
1131 graph <- GHC.getModuleGraph
1132 failed_graph <- filterM hasFailed graph
1133 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
1134 pick xs = case xs of
1135 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
1136 _ -> Nothing
1137
1138 case pick (order failed_graph) of
1139 Just file -> return file
1140 Nothing ->
1141 do targets <- GHC.getTargets
1142 case msum (map fromTarget targets) of
1143 Just file -> return file
1144 Nothing -> throwGhcException (CmdLineError "No files to edit.")
1145
1146 where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
1147 fromTarget _ = Nothing -- when would we get a module target?
1148
1149
1150 -----------------------------------------------------------------------------
1151 -- :def
1152
1153 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
1154 defineMacro _ (':':_) =
1155 liftIO $ putStrLn "macro name cannot start with a colon"
1156 defineMacro overwrite s = do
1157 let (macro_name, definition) = break isSpace s
1158 macros <- liftIO (readIORef macros_ref)
1159 let defined = map cmdName macros
1160 if (null macro_name)
1161 then if null defined
1162 then liftIO $ putStrLn "no macros defined"
1163 else liftIO $ putStr ("the following macros are defined:\n" ++
1164 unlines defined)
1165 else do
1166 if (not overwrite && macro_name `elem` defined)
1167 then throwGhcException (CmdLineError
1168 ("macro '" ++ macro_name ++ "' is already defined"))
1169 else do
1170
1171 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
1172
1173 -- give the expression a type signature, so we can be sure we're getting
1174 -- something of the right type.
1175 let new_expr = '(' : definition ++ ") :: String -> IO String"
1176
1177 -- compile the expression
1178 handleSourceError (\e -> GHC.printException e) $
1179 do
1180 hv <- GHC.compileExpr new_expr
1181 liftIO (writeIORef macros_ref -- later defined macros have precedence
1182 ((macro_name, lift . runMacro hv, noCompletion) : filtered))
1183
1184 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
1185 runMacro fun s = do
1186 str <- liftIO ((unsafeCoerce# fun :: String -> IO String) s)
1187 -- make sure we force any exceptions in the result, while we are still
1188 -- inside the exception handler for commands:
1189 seqList str (return ())
1190 enqueueCommands (lines str)
1191 return False
1192
1193
1194 -----------------------------------------------------------------------------
1195 -- :undef
1196
1197 undefineMacro :: String -> GHCi ()
1198 undefineMacro str = mapM_ undef (words str)
1199 where undef macro_name = do
1200 cmds <- liftIO (readIORef macros_ref)
1201 if (macro_name `notElem` map cmdName cmds)
1202 then throwGhcException (CmdLineError
1203 ("macro '" ++ macro_name ++ "' is not defined"))
1204 else do
1205 liftIO (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
1206
1207
1208 -----------------------------------------------------------------------------
1209 -- :cmd
1210
1211 cmdCmd :: String -> GHCi ()
1212 cmdCmd str = do
1213 let expr = '(' : str ++ ") :: IO String"
1214 handleSourceError (\e -> GHC.printException e) $
1215 do
1216 hv <- GHC.compileExpr expr
1217 cmds <- liftIO $ (unsafeCoerce# hv :: IO String)
1218 enqueueCommands (lines cmds)
1219 return ()
1220
1221
1222 -----------------------------------------------------------------------------
1223 -- :check
1224
1225 checkModule :: String -> InputT GHCi ()
1226 checkModule m = do
1227 let modl = GHC.mkModuleName m
1228 ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do
1229 r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
1230 dflags <- getDynFlags
1231 liftIO $ putStrLn $ showSDoc dflags $
1232 case GHC.moduleInfo r of
1233 cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1234 let
1235 (loc, glob) = ASSERT( all isExternalName scope )
1236 partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1237 in
1238 (text "global names: " <+> ppr glob) $$
1239 (text "local names: " <+> ppr loc)
1240 _ -> empty
1241 return True
1242 afterLoad (successIf ok) False
1243
1244
1245 -----------------------------------------------------------------------------
1246 -- :load, :add, :reload
1247
1248 loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
1249 loadModule fs = timeIt (loadModule' fs)
1250
1251 loadModule_ :: [FilePath] -> InputT GHCi ()
1252 loadModule_ fs = loadModule (zip fs (repeat Nothing)) >> return ()
1253
1254 loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
1255 loadModule' files = do
1256 let (filenames, phases) = unzip files
1257 exp_filenames <- mapM expandPath filenames
1258 let files' = zip exp_filenames phases
1259 targets <- mapM (uncurry GHC.guessTarget) files'
1260
1261 -- NOTE: we used to do the dependency anal first, so that if it
1262 -- fails we didn't throw away the current set of modules. This would
1263 -- require some re-working of the GHC interface, so we'll leave it
1264 -- as a ToDo for now.
1265
1266 -- unload first
1267 _ <- GHC.abandonAll
1268 lift discardActiveBreakPoints
1269 GHC.setTargets []
1270 _ <- GHC.load LoadAllTargets
1271
1272 GHC.setTargets targets
1273 doLoad False LoadAllTargets
1274
1275
1276 -- :add
1277 addModule :: [FilePath] -> InputT GHCi ()
1278 addModule files = do
1279 lift revertCAFs -- always revert CAFs on load/add.
1280 files' <- mapM expandPath files
1281 targets <- mapM (\m -> GHC.guessTarget m Nothing) files'
1282 -- remove old targets with the same id; e.g. for :add *M
1283 mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
1284 mapM_ GHC.addTarget targets
1285 _ <- doLoad False LoadAllTargets
1286 return ()
1287
1288
1289 -- :reload
1290 reloadModule :: String -> InputT GHCi ()
1291 reloadModule m = do
1292 _ <- doLoad True $
1293 if null m then LoadAllTargets
1294 else LoadUpTo (GHC.mkModuleName m)
1295 return ()
1296
1297
1298 doLoad :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag
1299 doLoad retain_context howmuch = do
1300 -- turn off breakpoints before we load: we can't turn them off later, because
1301 -- the ModBreaks will have gone away.
1302 lift discardActiveBreakPoints
1303 ok <- trySuccess $ GHC.load howmuch
1304 afterLoad ok retain_context
1305 return ok
1306
1307
1308 afterLoad :: SuccessFlag
1309 -> Bool -- keep the remembered_ctx, as far as possible (:reload)
1310 -> InputT GHCi ()
1311 afterLoad ok retain_context = do
1312 lift revertCAFs -- always revert CAFs on load.
1313 lift discardTickArrays
1314 loaded_mod_summaries <- getLoadedModules
1315 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1316 loaded_mod_names = map GHC.moduleName loaded_mods
1317 modulesLoadedMsg ok loaded_mod_names
1318 lift $ setContextAfterLoad retain_context loaded_mod_summaries
1319
1320
1321 setContextAfterLoad :: Bool -> [GHC.ModSummary] -> GHCi ()
1322 setContextAfterLoad keep_ctxt [] = do
1323 setContextKeepingPackageModules keep_ctxt []
1324 setContextAfterLoad keep_ctxt ms = do
1325 -- load a target if one is available, otherwise load the topmost module.
1326 targets <- GHC.getTargets
1327 case [ m | Just m <- map (findTarget ms) targets ] of
1328 [] ->
1329 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1330 load_this (last graph')
1331 (m:_) ->
1332 load_this m
1333 where
1334 findTarget mds t
1335 = case filter (`matches` t) mds of
1336 [] -> Nothing
1337 (m:_) -> Just m
1338
1339 summary `matches` Target (TargetModule m) _ _
1340 = GHC.ms_mod_name summary == m
1341 summary `matches` Target (TargetFile f _) _ _
1342 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1343 _ `matches` _
1344 = False
1345
1346 load_this summary | m <- GHC.ms_mod summary = do
1347 is_interp <- GHC.moduleIsInterpreted m
1348 dflags <- getDynFlags
1349 let star_ok = is_interp && not (safeLanguageOn dflags)
1350 -- We import the module with a * iff
1351 -- - it is interpreted, and
1352 -- - -XSafe is off (it doesn't allow *-imports)
1353 let new_ctx | star_ok = [mkIIModule (GHC.moduleName m)]
1354 | otherwise = [mkIIDecl (GHC.moduleName m)]
1355 setContextKeepingPackageModules keep_ctxt new_ctx
1356
1357
1358 -- | Keep any package modules (except Prelude) when changing the context.
1359 setContextKeepingPackageModules
1360 :: Bool -- True <=> keep all of remembered_ctx
1361 -- False <=> just keep package imports
1362 -> [InteractiveImport] -- new context
1363 -> GHCi ()
1364
1365 setContextKeepingPackageModules keep_ctx trans_ctx = do
1366
1367 st <- getGHCiState
1368 let rem_ctx = remembered_ctx st
1369 new_rem_ctx <- if keep_ctx then return rem_ctx
1370 else keepPackageImports rem_ctx
1371 setGHCiState st{ remembered_ctx = new_rem_ctx,
1372 transient_ctx = filterSubsumed new_rem_ctx trans_ctx }
1373 setGHCContextFromGHCiState
1374
1375
1376 keepPackageImports :: [InteractiveImport] -> GHCi [InteractiveImport]
1377 keepPackageImports = filterM is_pkg_import
1378 where
1379 is_pkg_import :: InteractiveImport -> GHCi Bool
1380 is_pkg_import (IIModule _) = return False
1381 is_pkg_import (IIDecl d)
1382 = do e <- gtry $ GHC.findModule mod_name (ideclPkgQual d)
1383 case e :: Either SomeException Module of
1384 Left _ -> return False
1385 Right m -> return (not (isHomeModule m))
1386 where
1387 mod_name = unLoc (ideclName d)
1388
1389
1390 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi ()
1391 modulesLoadedMsg ok mods = do
1392 dflags <- getDynFlags
1393 when (verbosity dflags > 0) $ do
1394 let mod_commas
1395 | null mods = text "none."
1396 | otherwise = hsep (
1397 punctuate comma (map ppr mods)) <> text "."
1398 case ok of
1399 Failed ->
1400 liftIO $ putStrLn $ showSDoc dflags (text "Failed, modules loaded: " <> mod_commas)
1401 Succeeded ->
1402 liftIO $ putStrLn $ showSDoc dflags (text "Ok, modules loaded: " <> mod_commas)
1403
1404
1405 -----------------------------------------------------------------------------
1406 -- :type
1407
1408 typeOfExpr :: String -> InputT GHCi ()
1409 typeOfExpr str
1410 = handleSourceError GHC.printException
1411 $ do
1412 ty <- GHC.exprType str
1413 dflags <- getDynFlags
1414 let pefas = gopt Opt_PrintExplicitForalls dflags
1415 printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]
1416
1417 -----------------------------------------------------------------------------
1418 -- :kind
1419
1420 kindOfType :: Bool -> String -> InputT GHCi ()
1421 kindOfType norm str
1422 = handleSourceError GHC.printException
1423 $ do
1424 (ty, kind) <- GHC.typeKind norm str
1425 dflags <- getDynFlags
1426 let pefas = gopt Opt_PrintExplicitForalls dflags
1427 printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser pefas kind
1428 , ppWhen norm $ equals <+> ppr ty ]
1429
1430
1431 -----------------------------------------------------------------------------
1432 -- :quit
1433
1434 quit :: String -> InputT GHCi Bool
1435 quit _ = return True
1436
1437
1438 -----------------------------------------------------------------------------
1439 -- :script
1440
1441 -- running a script file #1363
1442
1443 scriptCmd :: String -> InputT GHCi ()
1444 scriptCmd ws = do
1445 case words ws of
1446 [s] -> runScript s
1447 _ -> throwGhcException (CmdLineError "syntax: :script <filename>")
1448
1449 runScript :: String -- ^ filename
1450 -> InputT GHCi ()
1451 runScript filename = do
1452 either_script <- liftIO $ tryIO (openFile filename ReadMode)
1453 case either_script of
1454 Left _err -> throwGhcException (CmdLineError $ "IO error: \""++filename++"\" "
1455 ++(ioeGetErrorString _err))
1456 Right script -> do
1457 st <- lift $ getGHCiState
1458 let prog = progname st
1459 line = line_number st
1460 lift $ setGHCiState st{progname=filename,line_number=0}
1461 scriptLoop script
1462 liftIO $ hClose script
1463 new_st <- lift $ getGHCiState
1464 lift $ setGHCiState new_st{progname=prog,line_number=line}
1465 where scriptLoop script = do
1466 res <- runOneCommand handler $ fileLoop script
1467 case res of
1468 Nothing -> return ()
1469 Just s -> if s
1470 then scriptLoop script
1471 else return ()
1472
1473 -----------------------------------------------------------------------------
1474 -- :issafe
1475
1476 -- Displaying Safe Haskell properties of a module
1477
1478 isSafeCmd :: String -> InputT GHCi ()
1479 isSafeCmd m =
1480 case words m of
1481 [s] | looksLikeModuleName s -> do
1482 md <- lift $ lookupModule s
1483 isSafeModule md
1484 [] -> do md <- guessCurrentModule "issafe"
1485 isSafeModule md
1486 _ -> throwGhcException (CmdLineError "syntax: :issafe <module>")
1487
1488 isSafeModule :: Module -> InputT GHCi ()
1489 isSafeModule m = do
1490 mb_mod_info <- GHC.getModuleInfo m
1491 when (isNothing mb_mod_info)
1492 (throwGhcException $ CmdLineError $ "unknown module: " ++ mname)
1493
1494 dflags <- getDynFlags
1495 let iface = GHC.modInfoIface $ fromJust mb_mod_info
1496 when (isNothing iface)
1497 (throwGhcException $ CmdLineError $ "can't load interface file for module: " ++
1498 (GHC.moduleNameString $ GHC.moduleName m))
1499
1500 (msafe, pkgs) <- GHC.moduleTrustReqs m
1501 let trust = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface
1502 pkg = if packageTrusted dflags m then "trusted" else "untrusted"
1503 (good, bad) = tallyPkgs dflags pkgs
1504
1505 -- print info to user...
1506 liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")"
1507 liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off")
1508 when (not $ null good)
1509 (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++
1510 (intercalate ", " $ map packageIdString good))
1511 case msafe && null bad of
1512 True -> liftIO $ putStrLn $ mname ++ " is trusted!"
1513 False -> do
1514 when (not $ null bad)
1515 (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "
1516 ++ (intercalate ", " $ map packageIdString bad))
1517 liftIO $ putStrLn $ mname ++ " is NOT trusted!"
1518
1519 where
1520 mname = GHC.moduleNameString $ GHC.moduleName m
1521
1522 packageTrusted dflags md
1523 | thisPackage dflags == modulePackageId md = True
1524 | otherwise = trusted $ getPackageDetails (pkgState dflags) (modulePackageId md)
1525
1526 tallyPkgs dflags deps | not (packageTrustOn dflags) = ([], [])
1527 | otherwise = partition part deps
1528 where state = pkgState dflags
1529 part pkg = trusted $ getPackageDetails state pkg
1530
1531 -----------------------------------------------------------------------------
1532 -- :browse
1533
1534 -- Browsing a module's contents
1535
1536 browseCmd :: Bool -> String -> InputT GHCi ()
1537 browseCmd bang m =
1538 case words m of
1539 ['*':s] | looksLikeModuleName s -> do
1540 md <- lift $ wantInterpretedModule s
1541 browseModule bang md False
1542 [s] | looksLikeModuleName s -> do
1543 md <- lift $ lookupModule s
1544 browseModule bang md True
1545 [] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "")
1546 browseModule bang md True
1547 _ -> throwGhcException (CmdLineError "syntax: :browse <module>")
1548
1549 guessCurrentModule :: String -> InputT GHCi Module
1550 -- Guess which module the user wants to browse. Pick
1551 -- modules that are interpreted first. The most
1552 -- recently-added module occurs last, it seems.
1553 guessCurrentModule cmd
1554 = do imports <- GHC.getContext
1555 when (null imports) $ throwGhcException $
1556 CmdLineError (':' : cmd ++ ": no current module")
1557 case (head imports) of
1558 IIModule m -> GHC.findModule m Nothing
1559 IIDecl d -> GHC.findModule (unLoc (ideclName d)) (ideclPkgQual d)
1560
1561 -- without bang, show items in context of their parents and omit children
1562 -- with bang, show class methods and data constructors separately, and
1563 -- indicate import modules, to aid qualifying unqualified names
1564 -- with sorted, sort items alphabetically
1565 browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
1566 browseModule bang modl exports_only = do
1567 -- :browse reports qualifiers wrt current context
1568 unqual <- GHC.getPrintUnqual
1569
1570 mb_mod_info <- GHC.getModuleInfo modl
1571 case mb_mod_info of
1572 Nothing -> throwGhcException (CmdLineError ("unknown module: " ++
1573 GHC.moduleNameString (GHC.moduleName modl)))
1574 Just mod_info -> do
1575 dflags <- getDynFlags
1576 let names
1577 | exports_only = GHC.modInfoExports mod_info
1578 | otherwise = GHC.modInfoTopLevelScope mod_info
1579 `orElse` []
1580
1581 -- sort alphabetically name, but putting locally-defined
1582 -- identifiers first. We would like to improve this; see #1799.
1583 sorted_names = loc_sort local ++ occ_sort external
1584 where
1585 (local,external) = ASSERT( all isExternalName names )
1586 partition ((==modl) . nameModule) names
1587 occ_sort = sortBy (compare `on` nameOccName)
1588 -- try to sort by src location. If the first name in our list
1589 -- has a good source location, then they all should.
1590 loc_sort ns
1591 | n:_ <- ns, isGoodSrcSpan (nameSrcSpan n)
1592 = sortBy (compare `on` nameSrcSpan) ns
1593 | otherwise
1594 = occ_sort ns
1595
1596 mb_things <- mapM GHC.lookupName sorted_names
1597 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1598
1599 rdr_env <- GHC.getGRE
1600
1601 let pefas = gopt Opt_PrintExplicitForalls dflags
1602 things | bang = catMaybes mb_things
1603 | otherwise = filtered_things
1604 pretty | bang = pprTyThing
1605 | otherwise = pprTyThingInContext
1606
1607 labels [] = text "-- not currently imported"
1608 labels l = text $ intercalate "\n" $ map qualifier l
1609
1610 qualifier :: Maybe [ModuleName] -> String
1611 qualifier = maybe "-- defined locally"
1612 (("-- imported via "++) . intercalate ", "
1613 . map GHC.moduleNameString)
1614 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1615
1616 modNames :: [[Maybe [ModuleName]]]
1617 modNames = map (importInfo . GHC.getName) things
1618
1619 -- annotate groups of imports with their import modules
1620 -- the default ordering is somewhat arbitrary, so we group
1621 -- by header and sort groups; the names themselves should
1622 -- really come in order of source appearance.. (trac #1799)
1623 annotate mts = concatMap (\(m,ts)->labels m:ts)
1624 $ sortBy cmpQualifiers $ grp mts
1625 where cmpQualifiers =
1626 compare `on` (map (fmap (map moduleNameFS)) . fst)
1627 grp [] = []
1628 grp mts@((m,_):_) = (m,map snd g) : grp ng
1629 where (g,ng) = partition ((==m).fst) mts
1630
1631 let prettyThings, prettyThings' :: [SDoc]
1632 prettyThings = map (pretty pefas) things
1633 prettyThings' | bang = annotate $ zip modNames prettyThings
1634 | otherwise = prettyThings
1635 liftIO $ putStrLn $ showSDocForUser dflags unqual (vcat prettyThings')
1636 -- ToDo: modInfoInstances currently throws an exception for
1637 -- package modules. When it works, we can do this:
1638 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1639
1640
1641 -----------------------------------------------------------------------------
1642 -- :module
1643
1644 -- Setting the module context. For details on context handling see
1645 -- "remembered_ctx" and "transient_ctx" in GhciMonad.
1646
1647 moduleCmd :: String -> GHCi ()
1648 moduleCmd str
1649 | all sensible strs = cmd
1650 | otherwise = throwGhcException (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1651 where
1652 (cmd, strs) =
1653 case str of
1654 '+':stuff -> rest addModulesToContext stuff
1655 '-':stuff -> rest remModulesFromContext stuff
1656 stuff -> rest setContext stuff
1657
1658 rest op stuff = (op as bs, stuffs)
1659 where (as,bs) = partitionWith starred stuffs
1660 stuffs = words stuff
1661
1662 sensible ('*':m) = looksLikeModuleName m
1663 sensible m = looksLikeModuleName m
1664
1665 starred ('*':m) = Left (GHC.mkModuleName m)
1666 starred m = Right (GHC.mkModuleName m)
1667
1668
1669 -- -----------------------------------------------------------------------------
1670 -- Four ways to manipulate the context:
1671 -- (a) :module +<stuff>: addModulesToContext
1672 -- (b) :module -<stuff>: remModulesFromContext
1673 -- (c) :module <stuff>: setContext
1674 -- (d) import <module>...: addImportToContext
1675
1676 addModulesToContext :: [ModuleName] -> [ModuleName] -> GHCi ()
1677 addModulesToContext starred unstarred = restoreContextOnFailure $ do
1678 addModulesToContext_ starred unstarred
1679
1680 addModulesToContext_ :: [ModuleName] -> [ModuleName] -> GHCi ()
1681 addModulesToContext_ starred unstarred = do
1682 mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)
1683 setGHCContextFromGHCiState
1684
1685 remModulesFromContext :: [ModuleName] -> [ModuleName] -> GHCi ()
1686 remModulesFromContext starred unstarred = do
1687 -- we do *not* call restoreContextOnFailure here. If the user
1688 -- is trying to fix up a context that contains errors by removing
1689 -- modules, we don't want GHC to silently put them back in again.
1690 mapM_ rm (starred ++ unstarred)
1691 setGHCContextFromGHCiState
1692 where
1693 rm :: ModuleName -> GHCi ()
1694 rm str = do
1695 m <- moduleName <$> lookupModuleName str
1696 let filt = filter ((/=) m . iiModuleName)
1697 modifyGHCiState $ \st ->
1698 st { remembered_ctx = filt (remembered_ctx st)
1699 , transient_ctx = filt (transient_ctx st) }
1700
1701 setContext :: [ModuleName] -> [ModuleName] -> GHCi ()
1702 setContext starred unstarred = restoreContextOnFailure $ do
1703 modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] }
1704 -- delete the transient context
1705 addModulesToContext_ starred unstarred
1706
1707 addImportToContext :: String -> GHCi ()
1708 addImportToContext str = restoreContextOnFailure $ do
1709 idecl <- GHC.parseImportDecl str
1710 addII (IIDecl idecl) -- #5836
1711 setGHCContextFromGHCiState
1712
1713 -- Util used by addImportToContext and addModulesToContext
1714 addII :: InteractiveImport -> GHCi ()
1715 addII iidecl = do
1716 checkAdd iidecl
1717 modifyGHCiState $ \st ->
1718 st { remembered_ctx = addNotSubsumed iidecl (remembered_ctx st)
1719 , transient_ctx = filter (not . (iidecl `iiSubsumes`))
1720 (transient_ctx st)
1721 }
1722
1723 -- Sometimes we can't tell whether an import is valid or not until
1724 -- we finally call 'GHC.setContext'. e.g.
1725 --
1726 -- import System.IO (foo)
1727 --
1728 -- will fail because System.IO does not export foo. In this case we
1729 -- don't want to store the import in the context permanently, so we
1730 -- catch the failure from 'setGHCContextFromGHCiState' and set the
1731 -- context back to what it was.
1732 --
1733 -- See #6007
1734 --
1735 restoreContextOnFailure :: GHCi a -> GHCi a
1736 restoreContextOnFailure do_this = do
1737 st <- getGHCiState
1738 let rc = remembered_ctx st; tc = transient_ctx st
1739 do_this `gonException` (modifyGHCiState $ \st' ->
1740 st' { remembered_ctx = rc, transient_ctx = tc })
1741
1742 -- -----------------------------------------------------------------------------
1743 -- Validate a module that we want to add to the context
1744
1745 checkAdd :: InteractiveImport -> GHCi ()
1746 checkAdd ii = do
1747 dflags <- getDynFlags
1748 let safe = safeLanguageOn dflags
1749 case ii of
1750 IIModule modname
1751 | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell"
1752 | otherwise -> wantInterpretedModuleName modname >> return ()
1753
1754 IIDecl d -> do
1755 let modname = unLoc (ideclName d)
1756 pkgqual = ideclPkgQual d
1757 m <- GHC.lookupModule modname pkgqual
1758 when safe $ do
1759 t <- GHC.isModuleTrusted m
1760 when (not t) $ throwGhcException $ ProgramError $ ""
1761
1762 -- -----------------------------------------------------------------------------
1763 -- Update the GHC API's view of the context
1764
1765 -- | Sets the GHC context from the GHCi state. The GHC context is
1766 -- always set this way, we never modify it incrementally.
1767 --
1768 -- We ignore any imports for which the ModuleName does not currently
1769 -- exist. This is so that the remembered_ctx can contain imports for
1770 -- modules that are not currently loaded, perhaps because we just did
1771 -- a :reload and encountered errors.
1772 --
1773 -- Prelude is added if not already present in the list. Therefore to
1774 -- override the implicit Prelude import you can say 'import Prelude ()'
1775 -- at the prompt, just as in Haskell source.
1776 --
1777 setGHCContextFromGHCiState :: GHCi ()
1778 setGHCContextFromGHCiState = do
1779 st <- getGHCiState
1780 -- re-use checkAdd to check whether the module is valid. If the
1781 -- module does not exist, we do *not* want to print an error
1782 -- here, we just want to silently keep the module in the context
1783 -- until such time as the module reappears again. So we ignore
1784 -- the actual exception thrown by checkAdd, using tryBool to
1785 -- turn it into a Bool.
1786 iidecls <- filterM (tryBool.checkAdd) (transient_ctx st ++ remembered_ctx st)
1787 dflags <- GHC.getSessionDynFlags
1788 GHC.setContext $
1789 if xopt Opt_ImplicitPrelude dflags && not (any isPreludeImport iidecls)
1790 then iidecls ++ [implicitPreludeImport]
1791 else iidecls
1792 -- XXX put prel at the end, so that guessCurrentModule doesn't pick it up.
1793
1794
1795 -- -----------------------------------------------------------------------------
1796 -- Utils on InteractiveImport
1797
1798 mkIIModule :: ModuleName -> InteractiveImport
1799 mkIIModule = IIModule
1800
1801 mkIIDecl :: ModuleName -> InteractiveImport
1802 mkIIDecl = IIDecl . simpleImportDecl
1803
1804 iiModules :: [InteractiveImport] -> [ModuleName]
1805 iiModules is = [m | IIModule m <- is]
1806
1807 iiModuleName :: InteractiveImport -> ModuleName
1808 iiModuleName (IIModule m) = m
1809 iiModuleName (IIDecl d) = unLoc (ideclName d)
1810
1811 preludeModuleName :: ModuleName
1812 preludeModuleName = GHC.mkModuleName "Prelude"
1813
1814 implicitPreludeImport :: InteractiveImport
1815 implicitPreludeImport = IIDecl (simpleImportDecl preludeModuleName)
1816
1817 isPreludeImport :: InteractiveImport -> Bool
1818 isPreludeImport (IIModule {}) = True
1819 isPreludeImport (IIDecl d) = unLoc (ideclName d) == preludeModuleName
1820
1821 addNotSubsumed :: InteractiveImport
1822 -> [InteractiveImport] -> [InteractiveImport]
1823 addNotSubsumed i is
1824 | any (`iiSubsumes` i) is = is
1825 | otherwise = i : filter (not . (i `iiSubsumes`)) is
1826
1827 -- | @filterSubsumed is js@ returns the elements of @js@ not subsumed
1828 -- by any of @is@.
1829 filterSubsumed :: [InteractiveImport] -> [InteractiveImport]
1830 -> [InteractiveImport]
1831 filterSubsumed is js = filter (\j -> not (any (`iiSubsumes` j) is)) js
1832
1833 -- | Returns True if the left import subsumes the right one. Doesn't
1834 -- need to be 100% accurate, conservatively returning False is fine.
1835 -- (EXCEPT: (IIModule m) *must* subsume itself, otherwise a panic in
1836 -- plusProv will ensue (#5904))
1837 --
1838 -- Note that an IIModule does not necessarily subsume an IIDecl,
1839 -- because e.g. a module might export a name that is only available
1840 -- qualified within the module itself.
1841 --
1842 -- Note that 'import M' does not necessarily subsume 'import M(foo)',
1843 -- because M might not export foo and we want an error to be produced
1844 -- in that case.
1845 --
1846 iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool
1847 iiSubsumes (IIModule m1) (IIModule m2) = m1==m2
1848 iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude
1849 = unLoc (ideclName d1) == unLoc (ideclName d2)
1850 && ideclAs d1 == ideclAs d2
1851 && (not (ideclQualified d1) || ideclQualified d2)
1852 && (ideclHiding d1 `hidingSubsumes` ideclHiding d2)
1853 where
1854 _ `hidingSubsumes` Just (False,[]) = True
1855 Just (False, xs) `hidingSubsumes` Just (False,ys) = all (`elem` xs) ys
1856 h1 `hidingSubsumes` h2 = h1 == h2
1857 iiSubsumes _ _ = False
1858
1859
1860 ----------------------------------------------------------------------------
1861 -- :set
1862
1863 -- set options in the interpreter. Syntax is exactly the same as the
1864 -- ghc command line, except that certain options aren't available (-C,
1865 -- -E etc.)
1866 --
1867 -- This is pretty fragile: most options won't work as expected. ToDo:
1868 -- figure out which ones & disallow them.
1869
1870 setCmd :: String -> GHCi ()
1871 setCmd "" = showOptions False
1872 setCmd "-a" = showOptions True
1873 setCmd str
1874 = case getCmd str of
1875 Right ("args", rest) ->
1876 case toArgs rest of
1877 Left err -> liftIO (hPutStrLn stderr err)
1878 Right args -> setArgs args
1879 Right ("prog", rest) ->
1880 case toArgs rest of
1881 Right [prog] -> setProg prog
1882 _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")
1883 Right ("prompt", rest) -> setPrompt $ Just $ dropWhile isSpace rest
1884 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1885 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1886 _ -> case toArgs str of
1887 Left err -> liftIO (hPutStrLn stderr err)
1888 Right wds -> setOptions wds
1889
1890 setiCmd :: String -> GHCi ()
1891 setiCmd "" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False
1892 setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True
1893 setiCmd str =
1894 case toArgs str of
1895 Left err -> liftIO (hPutStrLn stderr err)
1896 Right wds -> newDynFlags True wds
1897
1898 showOptions :: Bool -> GHCi ()
1899 showOptions show_all
1900 = do st <- getGHCiState
1901 dflags <- getDynFlags
1902 let opts = options st
1903 liftIO $ putStrLn (showSDoc dflags (
1904 text "options currently set: " <>
1905 if null opts
1906 then text "none."
1907 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1908 ))
1909 getDynFlags >>= liftIO . showDynFlags show_all
1910
1911
1912 showDynFlags :: Bool -> DynFlags -> IO ()
1913 showDynFlags show_all dflags = do
1914 showLanguages' show_all dflags
1915 putStrLn $ showSDoc dflags $
1916 text "GHCi-specific dynamic flag settings:" $$
1917 nest 2 (vcat (map (setting gopt) ghciFlags))
1918 putStrLn $ showSDoc dflags $
1919 text "other dynamic, non-language, flag settings:" $$
1920 nest 2 (vcat (map (setting gopt) others))
1921 putStrLn $ showSDoc dflags $
1922 text "warning settings:" $$
1923 nest 2 (vcat (map (setting wopt) DynFlags.fWarningFlags))
1924 where
1925 setting test (str, f, _)
1926 | quiet = empty
1927 | is_on = fstr str
1928 | otherwise = fnostr str
1929 where is_on = test f dflags
1930 quiet = not show_all && test f default_dflags == is_on
1931
1932 default_dflags = defaultDynFlags (settings dflags)
1933
1934 fstr str = text "-f" <> text str
1935 fnostr str = text "-fno-" <> text str
1936
1937 (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flgs)
1938 DynFlags.fFlags
1939 flgs = [Opt_PrintExplicitForalls
1940 ,Opt_PrintBindResult
1941 ,Opt_BreakOnException
1942 ,Opt_BreakOnError
1943 ,Opt_PrintEvldWithShow
1944 ]
1945
1946 setArgs, setOptions :: [String] -> GHCi ()
1947 setProg, setEditor, setStop :: String -> GHCi ()
1948
1949 setArgs args = do
1950 st <- getGHCiState
1951 setGHCiState st{ GhciMonad.args = args }
1952
1953 setProg prog = do
1954 st <- getGHCiState
1955 setGHCiState st{ progname = prog }
1956
1957 setEditor cmd = do
1958 st <- getGHCiState
1959 setGHCiState st{ editor = cmd }
1960
1961 setStop str@(c:_) | isDigit c
1962 = do let (nm_str,rest) = break (not.isDigit) str
1963 nm = read nm_str
1964 st <- getGHCiState
1965 let old_breaks = breaks st
1966 if all ((/= nm) . fst) old_breaks
1967 then printForUser (text "Breakpoint" <+> ppr nm <+>
1968 text "does not exist")
1969 else do
1970 let new_breaks = map fn old_breaks
1971 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1972 | otherwise = (i,loc)
1973 setGHCiState st{ breaks = new_breaks }
1974 setStop cmd = do
1975 st <- getGHCiState
1976 setGHCiState st{ stop = cmd }
1977
1978 setPrompt :: Maybe String -> GHCi ()
1979 setPrompt Nothing = do
1980 st <- getGHCiState
1981 setGHCiState ( st { prompt = def_prompt st } )
1982
1983 setPrompt (Just value) = do
1984 st <- getGHCiState
1985 if null value
1986 then liftIO $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1987 else case value of
1988 '\"' : _ -> case reads value of
1989 [(value', xs)] | all isSpace xs ->
1990 setGHCiState (st { prompt = value' })
1991 _ ->
1992 liftIO $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
1993 _ -> setGHCiState (st { prompt = value })
1994
1995 setOptions wds =
1996 do -- first, deal with the GHCi opts (+s, +t, etc.)
1997 let (plus_opts, minus_opts) = partitionWith isPlus wds
1998 mapM_ setOpt plus_opts
1999 -- then, dynamic flags
2000 newDynFlags False minus_opts
2001
2002 newDynFlags :: Bool -> [String] -> GHCi ()
2003 newDynFlags interactive_only minus_opts = do
2004 let lopts = map noLoc minus_opts
2005
2006 idflags0 <- GHC.getInteractiveDynFlags
2007 (idflags1, leftovers, warns) <- GHC.parseDynamicFlags idflags0 lopts
2008
2009 liftIO $ handleFlagWarnings idflags1 warns
2010 when (not $ null leftovers)
2011 (throwGhcException . CmdLineError
2012 $ "Some flags have not been recognized: "
2013 ++ (concat . intersperse ", " $ map unLoc leftovers))
2014
2015 when (interactive_only &&
2016 packageFlags idflags1 /= packageFlags idflags0) $ do
2017 liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"
2018 GHC.setInteractiveDynFlags idflags1
2019 installInteractivePrint (interactivePrint idflags1) False
2020
2021 dflags0 <- getDynFlags
2022 when (not interactive_only) $ do
2023 (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags dflags0 lopts
2024 new_pkgs <- GHC.setProgramDynFlags dflags1
2025
2026 -- if the package flags changed, reset the context and link
2027 -- the new packages.
2028 dflags2 <- getDynFlags
2029 when (packageFlags dflags2 /= packageFlags dflags0) $ do
2030 when (verbosity dflags2 > 0) $
2031 liftIO . putStrLn $
2032 "package flags have changed, resetting and loading new packages..."
2033 GHC.setTargets []
2034 _ <- GHC.load LoadAllTargets
2035 liftIO $ linkPackages dflags2 new_pkgs
2036 -- package flags changed, we can't re-use any of the old context
2037 setContextAfterLoad False []
2038 -- and copy the package state to the interactive DynFlags
2039 idflags <- GHC.getInteractiveDynFlags
2040 GHC.setInteractiveDynFlags
2041 idflags{ pkgState = pkgState dflags2
2042 , pkgDatabase = pkgDatabase dflags2
2043 , packageFlags = packageFlags dflags2 }
2044
2045 return ()
2046
2047
2048 unsetOptions :: String -> GHCi ()
2049 unsetOptions str
2050 = -- first, deal with the GHCi opts (+s, +t, etc.)
2051 let opts = words str
2052 (minus_opts, rest1) = partition isMinus opts
2053 (plus_opts, rest2) = partitionWith isPlus rest1
2054 (other_opts, rest3) = partition (`elem` map fst defaulters) rest2
2055
2056 defaulters =
2057 [ ("args" , setArgs default_args)
2058 , ("prog" , setProg default_progname)
2059 , ("prompt", setPrompt Nothing)
2060 , ("editor", liftIO findEditor >>= setEditor)
2061 , ("stop" , setStop default_stop)
2062 ]
2063
2064 no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
2065 no_flag f = throwGhcException (ProgramError ("don't know how to reverse " ++ f))
2066
2067 in if (not (null rest3))
2068 then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))
2069 else do
2070 mapM_ (fromJust.flip lookup defaulters) other_opts
2071
2072 mapM_ unsetOpt plus_opts
2073
2074 no_flags <- mapM no_flag minus_opts
2075 newDynFlags False no_flags
2076
2077 isMinus :: String -> Bool
2078 isMinus ('-':_) = True
2079 isMinus _ = False
2080
2081 isPlus :: String -> Either String String
2082 isPlus ('+':opt) = Left opt
2083 isPlus other = Right other
2084
2085 setOpt, unsetOpt :: String -> GHCi ()
2086
2087 setOpt str
2088 = case strToGHCiOpt str of
2089 Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
2090 Just o -> setOption o
2091
2092 unsetOpt str
2093 = case strToGHCiOpt str of
2094 Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
2095 Just o -> unsetOption o
2096
2097 strToGHCiOpt :: String -> (Maybe GHCiOption)
2098 strToGHCiOpt "m" = Just Multiline
2099 strToGHCiOpt "s" = Just ShowTiming
2100 strToGHCiOpt "t" = Just ShowType
2101 strToGHCiOpt "r" = Just RevertCAFs
2102 strToGHCiOpt _ = Nothing
2103
2104 optToStr :: GHCiOption -> String
2105 optToStr Multiline = "m"
2106 optToStr ShowTiming = "s"
2107 optToStr ShowType = "t"
2108 optToStr RevertCAFs = "r"
2109
2110
2111 -- ---------------------------------------------------------------------------
2112 -- :show
2113
2114 showCmd :: String -> GHCi ()
2115 showCmd "" = showOptions False
2116 showCmd "-a" = showOptions True
2117 showCmd str = do
2118 st <- getGHCiState
2119 case words str of
2120 ["args"] -> liftIO $ putStrLn (show (GhciMonad.args st))
2121 ["prog"] -> liftIO $ putStrLn (show (progname st))
2122 ["prompt"] -> liftIO $ putStrLn (show (prompt st))
2123 ["editor"] -> liftIO $ putStrLn (show (editor st))
2124 ["stop"] -> liftIO $ putStrLn (show (stop st))
2125 ["imports"] -> showImports
2126 ["modules" ] -> showModules
2127 ["bindings"] -> showBindings
2128 ["linker"] ->
2129 do dflags <- getDynFlags
2130 liftIO $ showLinkerState dflags
2131 ["breaks"] -> showBkptTable
2132 ["context"] -> showContext
2133 ["packages"] -> showPackages
2134 ["languages"] -> showLanguages -- backwards compat
2135 ["language"] -> showLanguages
2136 ["lang"] -> showLanguages -- useful abbreviation
2137 _ -> throwGhcException (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
2138 " | breaks | context | packages | language ]"))
2139
2140 showiCmd :: String -> GHCi ()
2141 showiCmd str = do
2142 case words str of
2143 ["languages"] -> showiLanguages -- backwards compat
2144 ["language"] -> showiLanguages
2145 ["lang"] -> showiLanguages -- useful abbreviation
2146 _ -> throwGhcException (CmdLineError ("syntax: :showi language"))
2147
2148 showImports :: GHCi ()
2149 showImports = do
2150 st <- getGHCiState
2151 dflags <- getDynFlags
2152 let rem_ctx = reverse (remembered_ctx st)
2153 trans_ctx = transient_ctx st
2154
2155 show_one (IIModule star_m)
2156 = ":module +*" ++ moduleNameString star_m
2157 show_one (IIDecl imp) = showPpr dflags imp
2158
2159 prel_imp
2160 | any isPreludeImport (rem_ctx ++ trans_ctx) = []
2161 | otherwise = ["import Prelude -- implicit"]
2162
2163 trans_comment s = s ++ " -- added automatically"
2164 --
2165 liftIO $ mapM_ putStrLn (prel_imp ++ map show_one rem_ctx
2166 ++ map (trans_comment . show_one) trans_ctx)
2167
2168 showModules :: GHCi ()
2169 showModules = do
2170 loaded_mods <- getLoadedModules
2171 -- we want *loaded* modules only, see #1734
2172 let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)
2173 mapM_ show_one loaded_mods
2174
2175 getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
2176 getLoadedModules = do
2177 graph <- GHC.getModuleGraph
2178 filterM (GHC.isLoaded . GHC.ms_mod_name) graph
2179
2180 showBindings :: GHCi ()
2181 showBindings = do
2182 bindings <- GHC.getBindings
2183 (insts, finsts) <- GHC.getInsts
2184 docs <- mapM makeDoc (reverse bindings)
2185 -- reverse so the new ones come last
2186 let idocs = map GHC.pprInstanceHdr insts
2187 fidocs = map GHC.pprFamInst finsts
2188 mapM_ printForUserPartWay (docs ++ idocs ++ fidocs)
2189 where
2190 makeDoc (AnId i) = pprTypeAndContents i
2191 makeDoc tt = do
2192 dflags <- getDynFlags
2193 let pefas = gopt Opt_PrintExplicitForalls dflags
2194 mb_stuff <- GHC.getInfo False (getName tt)
2195 return $ maybe (text "") (pprTT pefas) mb_stuff
2196
2197 pprTT :: PrintExplicitForalls
2198 -> (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst GHC.Branched]) -> SDoc
2199 pprTT pefas (thing, fixity, _cls_insts, _fam_insts) =
2200 pprTyThing pefas thing
2201 $$ show_fixity
2202 where
2203 show_fixity
2204 | fixity == GHC.defaultFixity = empty
2205 | otherwise = ppr fixity <+> ppr (GHC.getName thing)
2206
2207
2208 printTyThing :: TyThing -> GHCi ()
2209 printTyThing tyth = do dflags <- getDynFlags
2210 let pefas = gopt Opt_PrintExplicitForalls dflags
2211 printForUser (pprTyThing pefas tyth)
2212
2213 showBkptTable :: GHCi ()
2214 showBkptTable = do
2215 st <- getGHCiState
2216 printForUser $ prettyLocations (breaks st)
2217
2218 showContext :: GHCi ()
2219 showContext = do
2220 resumes <- GHC.getResumeContext
2221 printForUser $ vcat (map pp_resume (reverse resumes))
2222 where
2223 pp_resume res =
2224 ptext (sLit "--> ") <> text (GHC.resumeStmt res)
2225 $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan res))
2226
2227 showPackages :: GHCi ()
2228 showPackages = do
2229 dflags <- getDynFlags
2230 let pkg_flags = packageFlags dflags
2231 liftIO $ putStrLn $ showSDoc dflags $ vcat $
2232 text ("active package flags:"++if null pkg_flags then " none" else "")
2233 : map showFlag pkg_flags
2234 where showFlag (ExposePackage p) = text $ " -package " ++ p
2235 showFlag (HidePackage p) = text $ " -hide-package " ++ p
2236 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
2237 showFlag (ExposePackageId p) = text $ " -package-id " ++ p
2238 showFlag (TrustPackage p) = text $ " -trust " ++ p
2239 showFlag (DistrustPackage p) = text $ " -distrust " ++ p
2240
2241 showLanguages :: GHCi ()
2242 showLanguages = getDynFlags >>= liftIO . showLanguages' False
2243
2244 showiLanguages :: GHCi ()
2245 showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False
2246
2247 showLanguages' :: Bool -> DynFlags -> IO ()
2248 showLanguages' show_all dflags =
2249 putStrLn $ showSDoc dflags $ vcat
2250 [ text "base language is: " <>
2251 case language dflags of
2252 Nothing -> text "Haskell2010"
2253 Just Haskell98 -> text "Haskell98"
2254 Just Haskell2010 -> text "Haskell2010"
2255 , (if show_all then text "all active language options:"
2256 else text "with the following modifiers:") $$
2257 nest 2 (vcat (map (setting xopt) DynFlags.xFlags))
2258 ]
2259 where
2260 setting test (str, f, _)
2261 | quiet = empty
2262 | is_on = text "-X" <> text str
2263 | otherwise = text "-XNo" <> text str
2264 where is_on = test f dflags
2265 quiet = not show_all && test f default_dflags == is_on
2266
2267 default_dflags =
2268 defaultDynFlags (settings dflags) `lang_set`
2269 case language dflags of
2270 Nothing -> Just Haskell2010
2271 other -> other
2272
2273 -- -----------------------------------------------------------------------------
2274 -- Completion
2275
2276 completeCmd, completeMacro, completeIdentifier, completeModule,
2277 completeSetModule, completeSeti, completeShowiOptions,
2278 completeHomeModule, completeSetOptions, completeShowOptions,
2279 completeHomeModuleOrFile, completeExpression
2280 :: CompletionFunc GHCi
2281
2282 ghciCompleteWord :: CompletionFunc GHCi
2283 ghciCompleteWord line@(left,_) = case firstWord of
2284 ':':cmd | null rest -> completeCmd line
2285 | otherwise -> do
2286 completion <- lookupCompletion cmd
2287 completion line
2288 "import" -> completeModule line
2289 _ -> completeExpression line
2290 where
2291 (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
2292 lookupCompletion ('!':_) = return completeFilename
2293 lookupCompletion c = do
2294 maybe_cmd <- lookupCommand' c
2295 case maybe_cmd of
2296 Just (_,_,f) -> return f
2297 Nothing -> return completeFilename
2298
2299 completeCmd = wrapCompleter " " $ \w -> do
2300 macros <- liftIO $ readIORef macros_ref
2301 cmds <- ghci_commands `fmap` getGHCiState
2302 let macro_names = map (':':) . map cmdName $ macros
2303 let command_names = map (':':) . map cmdName $ cmds
2304 let{ candidates = case w of
2305 ':' : ':' : _ -> map (':':) command_names
2306 _ -> nub $ macro_names ++ command_names }
2307 return $ filter (w `isPrefixOf`) candidates
2308
2309 completeMacro = wrapIdentCompleter $ \w -> do
2310 cmds <- liftIO $ readIORef macros_ref
2311 return (filter (w `isPrefixOf`) (map cmdName cmds))
2312
2313 completeIdentifier = wrapIdentCompleter $ \w -> do
2314 rdrs <- GHC.getRdrNamesInScope
2315 dflags <- GHC.getSessionDynFlags
2316 return (filter (w `isPrefixOf`) (map (showPpr dflags) rdrs))
2317
2318 completeModule = wrapIdentCompleter $ \w -> do
2319 dflags <- GHC.getSessionDynFlags
2320 let pkg_mods = allExposedModules dflags
2321 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
2322 return $ filter (w `isPrefixOf`)
2323 $ map (showPpr dflags) $ loaded_mods ++ pkg_mods
2324
2325 completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
2326 dflags <- GHC.getSessionDynFlags
2327 modules <- case m of
2328 Just '-' -> do
2329 imports <- GHC.getContext
2330 return $ map iiModuleName imports
2331 _ -> do
2332 let pkg_mods = allExposedModules dflags
2333 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
2334 return $ loaded_mods ++ pkg_mods
2335 return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules
2336
2337 completeHomeModule = wrapIdentCompleter listHomeModules
2338
2339 listHomeModules :: String -> GHCi [String]
2340 listHomeModules w = do
2341 g <- GHC.getModuleGraph
2342 let home_mods = map GHC.ms_mod_name g
2343 dflags <- getDynFlags
2344 return $ sort $ filter (w `isPrefixOf`)
2345 $ map (showPpr dflags) home_mods
2346
2347 completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
2348 return (filter (w `isPrefixOf`) opts)
2349 where opts = "args":"prog":"prompt":"editor":"stop":flagList
2350 flagList = map head $ group $ sort allFlags
2351
2352 completeSeti = wrapCompleter flagWordBreakChars $ \w -> do
2353 return (filter (w `isPrefixOf`) flagList)
2354 where flagList = map head $ group $ sort allFlags
2355
2356 completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
2357 return (filter (w `isPrefixOf`) opts)
2358 where opts = ["args", "prog", "prompt", "editor", "stop",
2359 "modules", "bindings", "linker", "breaks",
2360 "context", "packages", "language"]
2361
2362 completeShowiOptions = wrapCompleter flagWordBreakChars $ \w -> do
2363 return (filter (w `isPrefixOf`) ["language"])
2364
2365 completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
2366 $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
2367 listFiles
2368
2369 unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
2370 unionComplete f1 f2 line = do
2371 cs1 <- f1 line
2372 cs2 <- f2 line
2373 return (cs1 ++ cs2)
2374
2375 wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
2376 wrapCompleter breakChars fun = completeWord Nothing breakChars
2377 $ fmap (map simpleCompletion) . fmap sort . fun
2378
2379 wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
2380 wrapIdentCompleter = wrapCompleter word_break_chars
2381
2382 wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi
2383 wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars
2384 $ \rest -> fmap (map simpleCompletion) . fmap sort . fun (getModifier rest)
2385 where
2386 getModifier = find (`elem` modifChars)
2387
2388 allExposedModules :: DynFlags -> [ModuleName]
2389 allExposedModules dflags
2390 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
2391 where
2392 pkg_db = pkgIdMap (pkgState dflags)
2393
2394 completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
2395 completeIdentifier
2396
2397
2398 -- -----------------------------------------------------------------------------
2399 -- commands for debugger
2400
2401 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
2402 sprintCmd = pprintCommand False False
2403 printCmd = pprintCommand True False
2404 forceCmd = pprintCommand False True
2405
2406 pprintCommand :: Bool -> Bool -> String -> GHCi ()
2407 pprintCommand bind force str = do
2408 pprintClosureCommand bind force str
2409
2410 stepCmd :: String -> GHCi ()
2411 stepCmd arg = withSandboxOnly ":step" $ step arg
2412 where
2413 step [] = doContinue (const True) GHC.SingleStep
2414 step expression = runStmt expression GHC.SingleStep >> return ()
2415
2416 stepLocalCmd :: String -> GHCi ()
2417 stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg
2418 where
2419 step expr
2420 | not (null expr) = stepCmd expr
2421 | otherwise = do
2422 mb_span <- getCurrentBreakSpan
2423 case mb_span of
2424 Nothing -> stepCmd []
2425 Just loc -> do
2426 Just md <- getCurrentBreakModule
2427 current_toplevel_decl <- enclosingTickSpan md loc
2428 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
2429
2430 stepModuleCmd :: String -> GHCi ()
2431 stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg
2432 where
2433 step expr
2434 | not (null expr) = stepCmd expr
2435 | otherwise = do
2436 mb_span <- getCurrentBreakSpan
2437 case mb_span of
2438 Nothing -> stepCmd []
2439 Just pan -> do
2440 let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span
2441 doContinue f GHC.SingleStep
2442
2443 -- | Returns the span of the largest tick containing the srcspan given
2444 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
2445 enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
2446 enclosingTickSpan md (RealSrcSpan src) = do
2447 ticks <- getTickArray md
2448 let line = srcSpanStartLine src
2449 ASSERT (inRange (bounds ticks) line) do
2450 let toRealSrcSpan (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
2451 toRealSrcSpan (RealSrcSpan s) = s
2452 enclosing_spans = [ pan | (_,pan) <- ticks ! line
2453 , realSrcSpanEnd (toRealSrcSpan pan) >= realSrcSpanEnd src]
2454 return . head . sortBy leftmost_largest $ enclosing_spans
2455
2456 traceCmd :: String -> GHCi ()
2457 traceCmd arg
2458 = withSandboxOnly ":trace" $ tr arg
2459 where
2460 tr [] = doContinue (const True) GHC.RunAndLogSteps
2461 tr expression = runStmt expression GHC.RunAndLogSteps >> return ()
2462
2463 continueCmd :: String -> GHCi ()
2464 continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion
2465
2466 -- doContinue :: SingleStep -> GHCi ()
2467 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
2468 doContinue pre step = do
2469 runResult <- resume pre step
2470 _ <- afterRunStmt pre runResult
2471 return ()
2472
2473 abandonCmd :: String -> GHCi ()
2474 abandonCmd = noArgs $ withSandboxOnly ":abandon" $ do
2475 b <- GHC.abandon -- the prompt will change to indicate the new context
2476 when (not b) $ liftIO $ putStrLn "There is no computation running."
2477
2478 deleteCmd :: String -> GHCi ()
2479 deleteCmd argLine = withSandboxOnly ":delete" $ do
2480 deleteSwitch $ words argLine
2481 where
2482 deleteSwitch :: [String] -> GHCi ()
2483 deleteSwitch [] =
2484 liftIO $ putStrLn "The delete command requires at least one argument."
2485 -- delete all break points
2486 deleteSwitch ("*":_rest) = discardActiveBreakPoints
2487 deleteSwitch idents = do
2488 mapM_ deleteOneBreak idents
2489 where
2490 deleteOneBreak :: String -> GHCi ()
2491 deleteOneBreak str
2492 | all isDigit str = deleteBreak (read str)
2493 | otherwise = return ()
2494
2495 historyCmd :: String -> GHCi ()
2496 historyCmd arg
2497 | null arg = history 20
2498 | all isDigit arg = history (read arg)
2499 | otherwise = liftIO $ putStrLn "Syntax: :history [num]"
2500 where
2501 history num = do
2502 resumes <- GHC.getResumeContext
2503 case resumes of
2504 [] -> liftIO $ putStrLn "Not stopped at a breakpoint"
2505 (r:_) -> do
2506 let hist = GHC.resumeHistory r
2507 (took,rest) = splitAt num hist
2508 case hist of
2509 [] -> liftIO $ putStrLn $
2510 "Empty history. Perhaps you forgot to use :trace?"
2511 _ -> do
2512 pans <- mapM GHC.getHistorySpan took
2513 let nums = map (printf "-%-3d:") [(1::Int)..]
2514 names = map GHC.historyEnclosingDecls took
2515 printForUser (vcat(zipWith3
2516 (\x y z -> x <+> y <+> z)
2517 (map text nums)
2518 (map (bold . hcat . punctuate colon . map text) names)
2519 (map (parens . ppr) pans)))
2520 liftIO $ putStrLn $ if null rest then "<end of history>" else "..."
2521
2522 bold :: SDoc -> SDoc
2523 bold c | do_bold = text start_bold <> c <> text end_bold
2524 | otherwise = c
2525
2526 backCmd :: String -> GHCi ()
2527 backCmd = noArgs $ withSandboxOnly ":back" $ do
2528 (names, _, pan) <- GHC.back
2529 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan
2530 printTypeOfNames names
2531 -- run the command set with ":set stop <cmd>"
2532 st <- getGHCiState
2533 enqueueCommands [stop st]
2534
2535 forwardCmd :: String -> GHCi ()
2536 forwardCmd = noArgs $ withSandboxOnly ":forward" $ do
2537 (names, ix, pan) <- GHC.forward
2538 printForUser $ (if (ix == 0)
2539 then ptext (sLit "Stopped at")
2540 else ptext (sLit "Logged breakpoint at")) <+> ppr pan
2541 printTypeOfNames names
2542 -- run the command set with ":set stop <cmd>"
2543 st <- getGHCiState
2544 enqueueCommands [stop st]
2545
2546 -- handle the "break" command
2547 breakCmd :: String -> GHCi ()
2548 breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine
2549
2550 breakSwitch :: [String] -> GHCi ()
2551 breakSwitch [] = do
2552 liftIO $ putStrLn "The break command requires at least one argument."
2553 breakSwitch (arg1:rest)
2554 | looksLikeModuleName arg1 && not (null rest) = do
2555 md <- wantInterpretedModule arg1
2556 breakByModule md rest
2557 | all isDigit arg1 = do
2558 imports <- GHC.getContext
2559 case iiModules imports of
2560 (mn : _) -> do
2561 md <- lookupModuleName mn
2562 breakByModuleLine md (read arg1) rest
2563 [] -> do
2564 liftIO $ putStrLn "No modules are loaded with debugging support."
2565 | otherwise = do -- try parsing it as an identifier
2566 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
2567 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2568 case loc of
2569 RealSrcLoc l ->
2570 ASSERT( isExternalName name )
2571 findBreakAndSet (GHC.nameModule name) $
2572 findBreakByCoord (Just (GHC.srcLocFile l))
2573 (GHC.srcLocLine l,
2574 GHC.srcLocCol l)
2575 UnhelpfulLoc _ ->
2576 noCanDo name $ text "can't find its location: " <> ppr loc
2577 where
2578 noCanDo n why = printForUser $
2579 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
2580
2581 breakByModule :: Module -> [String] -> GHCi ()
2582 breakByModule md (arg1:rest)
2583 | all isDigit arg1 = do -- looks like a line number
2584 breakByModuleLine md (read arg1) rest
2585 breakByModule _ _
2586 = breakSyntax
2587
2588 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
2589 breakByModuleLine md line args
2590 | [] <- args = findBreakAndSet md $ findBreakByLine line
2591 | [col] <- args, all isDigit col =
2592 findBreakAndSet md $ findBreakByCoord Nothing (line, read col)
2593 | otherwise = breakSyntax
2594
2595 breakSyntax :: a
2596 breakSyntax = throwGhcException (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
2597
2598 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
2599 findBreakAndSet md lookupTickTree = do
2600 dflags <- getDynFlags
2601 tickArray <- getTickArray md
2602 (breakArray, _) <- getModBreak md
2603 case lookupTickTree tickArray of
2604 Nothing -> liftIO $ putStrLn $ "No breakpoints found at that location."
2605 Just (tick, pan) -> do
2606 success <- liftIO $ setBreakFlag dflags True breakArray tick
2607 if success
2608 then do
2609 (alreadySet, nm) <-
2610 recordBreak $ BreakLocation
2611 { breakModule = md
2612 , breakLoc = pan
2613 , breakTick = tick
2614 , onBreakCmd = ""
2615 }
2616 printForUser $
2617 text "Breakpoint " <> ppr nm <>
2618 if alreadySet
2619 then text " was already set at " <> ppr pan
2620 else text " activated at " <> ppr pan
2621 else do
2622 printForUser $ text "Breakpoint could not be activated at"
2623 <+> ppr pan
2624
2625 -- When a line number is specified, the current policy for choosing
2626 -- the best breakpoint is this:
2627 -- - the leftmost complete subexpression on the specified line, or
2628 -- - the leftmost subexpression starting on the specified line, or
2629 -- - the rightmost subexpression enclosing the specified line
2630 --
2631 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2632 findBreakByLine line arr
2633 | not (inRange (bounds arr) line) = Nothing
2634 | otherwise =
2635 listToMaybe (sortBy (leftmost_largest `on` snd) comp) `mplus`
2636 listToMaybe (sortBy (leftmost_smallest `on` snd) incomp) `mplus`
2637 listToMaybe (sortBy (rightmost `on` snd) ticks)
2638 where
2639 ticks = arr ! line
2640
2641 starts_here = [ tick | tick@(_,pan) <- ticks,
2642 GHC.srcSpanStartLine (toRealSpan pan) == line ]
2643
2644 (comp, incomp) = partition ends_here starts_here
2645 where ends_here (_,pan) = GHC.srcSpanEndLine (toRealSpan pan) == line
2646 toRealSpan (RealSrcSpan pan) = pan
2647 toRealSpan (UnhelpfulSpan _) = panic "findBreakByLine UnhelpfulSpan"
2648
2649 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2650 -> Maybe (BreakIndex,SrcSpan)
2651 findBreakByCoord mb_file (line, col) arr
2652 | not (inRange (bounds arr) line) = Nothing
2653 | otherwise =
2654 listToMaybe (sortBy (rightmost `on` snd) contains ++
2655 sortBy (leftmost_smallest `on` snd) after_here)
2656 where
2657 ticks = arr ! line
2658
2659 -- the ticks that span this coordinate
2660 contains = [ tick | tick@(_,pan) <- ticks, pan `spans` (line,col),
2661 is_correct_file pan ]
2662
2663 is_correct_file pan
2664 | Just f <- mb_file = GHC.srcSpanFile (toRealSpan pan) == f
2665 | otherwise = True
2666
2667 after_here = [ tick | tick@(_,pan) <- ticks,
2668 let pan' = toRealSpan pan,
2669 GHC.srcSpanStartLine pan' == line,
2670 GHC.srcSpanStartCol pan' >= col ]
2671
2672 toRealSpan (RealSrcSpan pan) = pan
2673 toRealSpan (UnhelpfulSpan _) = panic "findBreakByCoord UnhelpfulSpan"
2674
2675 -- For now, use ANSI bold on terminals that we know support it.
2676 -- Otherwise, we add a line of carets under the active expression instead.
2677 -- In particular, on Windows and when running the testsuite (which sets
2678 -- TERM to vt100 for other reasons) we get carets.
2679 -- We really ought to use a proper termcap/terminfo library.
2680 do_bold :: Bool
2681 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2682 where mTerm = System.Environment.getEnv "TERM"
2683 `catchIO` \_ -> return "TERM not set"
2684
2685 start_bold :: String
2686 start_bold = "\ESC[1m"
2687 end_bold :: String
2688 end_bold = "\ESC[0m"
2689
2690
2691 -----------------------------------------------------------------------------
2692 -- :list
2693
2694 listCmd :: String -> InputT GHCi ()
2695 listCmd c = listCmd' c
2696
2697 listCmd' :: String -> InputT GHCi ()
2698 listCmd' "" = do
2699 mb_span <- lift getCurrentBreakSpan
2700 case mb_span of
2701 Nothing ->
2702 printForUser $ text "Not stopped at a breakpoint; nothing to list"
2703 Just (RealSrcSpan pan) ->
2704 listAround pan True
2705 Just pan@(UnhelpfulSpan _) ->
2706 do resumes <- GHC.getResumeContext
2707 case resumes of
2708 [] -> panic "No resumes"
2709 (r:_) ->
2710 do let traceIt = case GHC.resumeHistory r of
2711 [] -> text "rerunning with :trace,"
2712 _ -> empty
2713 doWhat = traceIt <+> text ":back then :list"
2714 printForUser (text "Unable to list source for" <+>
2715 ppr pan
2716 $$ text "Try" <+> doWhat)
2717 listCmd' str = list2 (words str)
2718
2719 list2 :: [String] -> InputT GHCi ()
2720 list2 [arg] | all isDigit arg = do
2721 imports <- GHC.getContext
2722 case iiModules imports of
2723 [] -> liftIO $ putStrLn "No module to list"
2724 (mn : _) -> do
2725 md <- lift $ lookupModuleName mn
2726 listModuleLine md (read arg)
2727 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2728 md <- wantInterpretedModule arg1
2729 listModuleLine md (read arg2)
2730 list2 [arg] = do
2731 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2732 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2733 case loc of
2734 RealSrcLoc l ->
2735 do tickArray <- ASSERT( isExternalName name )
2736 lift $ getTickArray (GHC.nameModule name)
2737 let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))
2738 (GHC.srcLocLine l, GHC.srcLocCol l)
2739 tickArray
2740 case mb_span of
2741 Nothing -> listAround (realSrcLocSpan l) False
2742 Just (_, UnhelpfulSpan _) -> panic "list2 UnhelpfulSpan"
2743 Just (_, RealSrcSpan pan) -> listAround pan False
2744 UnhelpfulLoc _ ->
2745 noCanDo name $ text "can't find its location: " <>
2746 ppr loc
2747 where
2748 noCanDo n why = printForUser $
2749 text "cannot list source code for " <> ppr n <> text ": " <> why
2750 list2 _other =
2751 liftIO $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2752
2753 listModuleLine :: Module -> Int -> InputT GHCi ()
2754 listModuleLine modl line = do
2755 graph <- GHC.getModuleGraph
2756 let this = filter ((== modl) . GHC.ms_mod) graph
2757 case this of
2758 [] -> panic "listModuleLine"
2759 summ:_ -> do
2760 let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
2761 loc = mkRealSrcLoc (mkFastString (filename)) line 0
2762 listAround (realSrcLocSpan loc) False
2763
2764 -- | list a section of a source file around a particular SrcSpan.
2765 -- If the highlight flag is True, also highlight the span using
2766 -- start_bold\/end_bold.
2767
2768 -- GHC files are UTF-8, so we can implement this by:
2769 -- 1) read the file in as a BS and syntax highlight it as before
2770 -- 2) convert the BS to String using utf-string, and write it out.
2771 -- It would be better if we could convert directly between UTF-8 and the
2772 -- console encoding, of course.
2773 listAround :: MonadIO m => RealSrcSpan -> Bool -> InputT m ()
2774 listAround pan do_highlight = do
2775 contents <- liftIO $ BS.readFile (unpackFS file)
2776 let ls = BS.split '\n' contents
2777 ls' = take (line2 - line1 + 1 + pad_before + pad_after) $
2778 drop (line1 - 1 - pad_before) $ ls
2779 fst_line = max 1 (line1 - pad_before)
2780 line_nos = [ fst_line .. ]
2781
2782 highlighted | do_highlight = zipWith highlight line_nos ls'
2783 | otherwise = [\p -> BS.concat[p,l] | l <- ls']
2784
2785 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2786 prefixed = zipWith ($) highlighted bs_line_nos
2787 output = BS.intercalate (BS.pack "\n") prefixed
2788
2789 utf8Decoded <- liftIO $ BS.useAsCStringLen output
2790 $ \(p,n) -> utf8DecodeString (castPtr p) n
2791 liftIO $ putStrLn utf8Decoded
2792 where
2793 file = GHC.srcSpanFile pan
2794 line1 = GHC.srcSpanStartLine pan
2795 col1 = GHC.srcSpanStartCol pan - 1
2796 line2 = GHC.srcSpanEndLine pan
2797 col2 = GHC.srcSpanEndCol pan - 1
2798
2799 pad_before | line1 == 1 = 0
2800 | otherwise = 1
2801 pad_after = 1
2802
2803 highlight | do_bold = highlight_bold
2804 | otherwise = highlight_carets
2805
2806 highlight_bold no line prefix
2807 | no == line1 && no == line2
2808 = let (a,r) = BS.splitAt col1 line
2809 (b,c) = BS.splitAt (col2-col1) r
2810 in
2811 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2812 | no == line1
2813 = let (a,b) = BS.splitAt col1 line in
2814 BS.concat [prefix, a, BS.pack start_bold, b]
2815 | no == line2
2816 = let (a,b) = BS.splitAt col2 line in
2817 BS.concat [prefix, a, BS.pack end_bold, b]
2818 | otherwise = BS.concat [prefix, line]
2819
2820 highlight_carets no line prefix
2821 | no == line1 && no == line2
2822 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2823 BS.replicate (col2-col1) '^']
2824 | no == line1
2825 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2826 prefix, line]
2827 | no == line2
2828 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2829 BS.pack "^^"]
2830 | otherwise = BS.concat [prefix, line]
2831 where
2832 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2833 nl = BS.singleton '\n'
2834
2835
2836 -- --------------------------------------------------------------------------
2837 -- Tick arrays
2838
2839 getTickArray :: Module -> GHCi TickArray
2840 getTickArray modl = do
2841 st <- getGHCiState
2842 let arrmap = tickarrays st
2843 case lookupModuleEnv arrmap modl of
2844 Just arr -> return arr
2845 Nothing -> do
2846 (_breakArray, ticks) <- getModBreak modl
2847 let arr = mkTickArray (assocs ticks)
2848 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2849 return arr
2850
2851 discardTickArrays :: GHCi ()
2852 discardTickArrays = do
2853 st <- getGHCiState
2854 setGHCiState st{tickarrays = emptyModuleEnv}
2855
2856 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2857 mkTickArray ticks
2858 = accumArray (flip (:)) [] (1, max_line)
2859 [ (line, (nm,pan)) | (nm,pan) <- ticks,
2860 let pan' = toRealSpan pan,
2861 line <- srcSpanLines pan' ]
2862 where
2863 max_line = foldr max 0 (map (GHC.srcSpanEndLine . toRealSpan . snd) ticks)
2864 srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ]
2865 toRealSpan (RealSrcSpan pan) = pan
2866 toRealSpan (UnhelpfulSpan _) = panic "mkTickArray UnhelpfulSpan"
2867
2868 -- don't reset the counter back to zero?
2869 discardActiveBreakPoints :: GHCi ()
2870 discardActiveBreakPoints = do
2871 st <- getGHCiState
2872 mapM_ (turnOffBreak.snd) (breaks st)
2873 setGHCiState $ st { breaks = [] }
2874
2875 deleteBreak :: Int -> GHCi ()
2876 deleteBreak identity = do
2877 st <- getGHCiState
2878 let oldLocations = breaks st
2879 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2880 if null this
2881 then printForUser (text "Breakpoint" <+> ppr identity <+>
2882 text "does not exist")
2883 else do
2884 mapM_ (turnOffBreak.snd) this
2885 setGHCiState $ st { breaks = rest }
2886
2887 turnOffBreak :: BreakLocation -> GHCi Bool
2888 turnOffBreak loc = do
2889 dflags <- getDynFlags
2890 (arr, _) <- getModBreak (breakModule loc)
2891 liftIO $ setBreakFlag dflags False arr (breakTick loc)
2892
2893 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2894 getModBreak m = do
2895 Just mod_info <- GHC.getModuleInfo m
2896 let modBreaks = GHC.modInfoModBreaks mod_info
2897 let arr = GHC.modBreaks_flags modBreaks
2898 let ticks = GHC.modBreaks_locs modBreaks
2899 return (arr, ticks)
2900
2901 setBreakFlag :: DynFlags -> Bool -> GHC.BreakArray -> Int -> IO Bool
2902 setBreakFlag dflags toggle arr i
2903 | toggle = GHC.setBreakOn dflags arr i
2904 | otherwise = GHC.setBreakOff dflags arr i
2905
2906
2907 -- ---------------------------------------------------------------------------
2908 -- User code exception handling
2909
2910 -- This is the exception handler for exceptions generated by the
2911 -- user's code and exceptions coming from children sessions;
2912 -- it normally just prints out the exception. The
2913 -- handler must be recursive, in case showing the exception causes
2914 -- more exceptions to be raised.
2915 --
2916 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
2917 -- raising another exception. We therefore don't put the recursive
2918 -- handler arond the flushing operation, so if stderr is closed
2919 -- GHCi will just die gracefully rather than going into an infinite loop.
2920 handler :: SomeException -> GHCi Bool
2921
2922 handler exception = do
2923 flushInterpBuffers
2924 liftIO installSignalHandlers
2925 ghciHandle handler (showException exception >> return False)
2926
2927 showException :: SomeException -> GHCi ()
2928 showException se =
2929 liftIO $ case fromException se of
2930 -- omit the location for CmdLineError:
2931 Just (CmdLineError s) -> putException s
2932 -- ditto:
2933 Just ph@(PhaseFailed {}) -> putException (showGhcException ph "")
2934 Just other_ghc_ex -> putException (show other_ghc_ex)
2935 Nothing ->
2936 case fromException se of
2937 Just UserInterrupt -> putException "Interrupted."
2938 _ -> putException ("*** Exception: " ++ show se)
2939 where
2940 putException = hPutStrLn stderr
2941
2942
2943 -----------------------------------------------------------------------------
2944 -- recursive exception handlers
2945
2946 -- Don't forget to unblock async exceptions in the handler, or if we're
2947 -- in an exception loop (eg. let a = error a in a) the ^C exception
2948 -- may never be delivered. Thanks to Marcin for pointing out the bug.
2949
2950 ghciHandle :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a
2951 ghciHandle h m = gmask $ \restore -> do
2952 dflags <- getDynFlags
2953 gcatch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e)
2954
2955 ghciTry :: GHCi a -> GHCi (Either SomeException a)
2956 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
2957
2958 tryBool :: GHCi a -> GHCi Bool
2959 tryBool m = do
2960 r <- ghciTry m
2961 case r of
2962 Left _ -> return False
2963 Right _ -> return True
2964
2965 -- ----------------------------------------------------------------------------
2966 -- Utils
2967
2968 lookupModule :: GHC.GhcMonad m => String -> m Module
2969 lookupModule mName = lookupModuleName (GHC.mkModuleName mName)
2970
2971 lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module
2972 lookupModuleName mName = GHC.lookupModule mName Nothing
2973
2974 isHomeModule :: Module -> Bool
2975 isHomeModule m = GHC.modulePackageId m == mainPackageId
2976
2977 -- TODO: won't work if home dir is encoded.
2978 -- (changeDirectory may not work either in that case.)
2979 expandPath :: MonadIO m => String -> InputT m String
2980 expandPath = liftIO . expandPathIO
2981
2982 expandPathIO :: String -> IO String
2983 expandPathIO p =
2984 case dropWhile isSpace p of
2985 ('~':d) -> do
2986 tilde <- getHomeDirectory -- will fail if HOME not defined
2987 return (tilde ++ '/':d)
2988 other ->
2989 return other
2990
2991 wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
2992 wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str)
2993
2994 wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module
2995 wantInterpretedModuleName modname = do
2996 modl <- lookupModuleName modname
2997 let str = moduleNameString modname
2998 dflags <- getDynFlags
2999 when (GHC.modulePackageId modl /= thisPackage dflags) $
3000 throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
3001 is_interpreted <- GHC.moduleIsInterpreted modl
3002 when (not is_interpreted) $
3003 throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
3004 return modl
3005
3006 wantNameFromInterpretedModule :: GHC.GhcMonad m
3007 => (Name -> SDoc -> m ())
3008 -> String
3009 -> (Name -> m ())
3010 -> m ()
3011 wantNameFromInterpretedModule noCanDo str and_then =
3012 handleSourceError GHC.printException $ do
3013 names <- GHC.parseName str
3014 case names of
3015 [] -> return ()
3016 (n:_) -> do
3017 let modl = ASSERT( isExternalName n ) GHC.nameModule n
3018 if not (GHC.isExternalName n)
3019 then noCanDo n $ ppr n <>
3020 text " is not defined in an interpreted module"
3021 else do
3022 is_interpreted <- GHC.moduleIsInterpreted modl
3023 if not is_interpreted
3024 then noCanDo n $ text "module " <> ppr modl <>
3025 text " is not interpreted"
3026 else and_then n