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