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