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