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