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