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