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