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