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