Added the new :breakpoint continue option
[ghc.git] / compiler / ghci / InteractiveUI.hs
1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
3 --
4 -- GHC Interactive User Interface
5 --
6 -- (c) The GHC Team 2005-2006
7 --
8 -----------------------------------------------------------------------------
9 module InteractiveUI (
10 interactiveUI,
11 ghciWelcomeMsg
12 ) where
13
14 #include "HsVersions.h"
15
16 import GhciMonad
17
18 -- The GHC interface
19 import qualified GHC
20 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
21 Type, Module, ModuleName, TyThing(..), Phase )
22 import DynFlags
23 import Packages
24 import PackageConfig
25 import UniqFM
26 import PprTyThing
27 import Outputable
28
29 -- for createtags
30 import Name
31 import OccName
32 import SrcLoc
33
34 -- Other random utilities
35 import Digraph
36 import BasicTypes hiding (isTopLevel)
37 import Panic hiding (showException)
38 import Config
39 import StaticFlags
40 import Linker
41 import Util
42
43 -- The debugger
44 import Breakpoints
45 import Debugger hiding ( addModule )
46 import HscTypes
47 import Id
48 import Var ( globaliseId )
49 import IdInfo
50 import NameEnv
51 import RdrName
52 import Module
53 import Type
54 import TcType
55
56 #ifndef mingw32_HOST_OS
57 import System.Posix
58 #if __GLASGOW_HASKELL__ > 504
59 hiding (getEnv)
60 #endif
61 #else
62 import GHC.ConsoleHandler ( flushConsole )
63 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
64 import qualified System.Win32
65 #endif
66
67 #ifdef USE_READLINE
68 import Control.Concurrent ( yield ) -- Used in readline loop
69 import System.Console.Readline as Readline
70 #endif
71
72 --import SystemExts
73
74 import Control.Exception as Exception
75 -- import Control.Concurrent
76
77 import Numeric
78 import Data.List
79 import Data.Int ( Int64 )
80 import Data.Maybe ( isJust, isNothing, fromMaybe, catMaybes )
81 import System.Cmd
82 import System.Environment
83 import System.Exit ( exitWith, ExitCode(..) )
84 import System.Directory
85 import System.IO
86 import System.IO.Error as IO
87 import Data.Char
88 import Data.Dynamic
89 import Control.Monad as Monad
90 import Foreign.StablePtr ( newStablePtr )
91
92 import GHC.Exts ( unsafeCoerce# )
93 import GHC.IOBase ( IOErrorType(InvalidArgument) )
94
95 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
96
97 import System.Posix.Internals ( setNonBlockingFD )
98
99 -----------------------------------------------------------------------------
100
101 ghciWelcomeMsg =
102 " ___ ___ _\n"++
103 " / _ \\ /\\ /\\/ __(_)\n"++
104 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
105 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
106 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
107
108 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
109 cmdName (n,_,_,_) = n
110
111 GLOBAL_VAR(commands, builtin_commands, [Command])
112
113 builtin_commands :: [Command]
114 builtin_commands = [
115 ("add", tlC$ keepGoingPaths addModule, False, completeFilename),
116 ("browse", keepGoing browseCmd, False, completeModule),
117 #ifdef DEBUGGER
118 -- I think that :c should mean :continue rather than :cd, makes more sense
119 -- (pepe 01.11.07)
120 ("continue", const(bkptOptions "continue"), False, completeNone),
121 #endif
122 ("cd", tlC$ keepGoing changeDirectory, False, completeFilename),
123 ("def", keepGoing defineMacro, False, completeIdentifier),
124 ("e", keepGoing editFile, False, completeFilename),
125 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
126 ("edit", keepGoing editFile, False, completeFilename),
127 ("help", keepGoing help, False, completeNone),
128 ("?", keepGoing help, False, completeNone),
129 ("info", keepGoing info, False, completeIdentifier),
130 ("load", tlC$ keepGoingPaths loadModule_,False, completeHomeModuleOrFile),
131 ("module", keepGoing setContext, False, completeModule),
132 ("main", tlC$ keepGoing runMain, False, completeIdentifier),
133 ("reload", tlC$ keepGoing reloadModule, False, completeNone),
134 ("check", keepGoing checkModule, False, completeHomeModule),
135 ("set", keepGoing setCmd, True, completeSetOptions),
136 ("show", keepGoing showCmd, False, completeNone),
137 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
138 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
139 ("type", keepGoing typeOfExpr, False, completeIdentifier),
140 #if defined(DEBUGGER)
141 ("print", keepGoing (pprintClosureCommand True False), False, completeIdentifier),
142 ("sprint", keepGoing (pprintClosureCommand False False),False, completeIdentifier),
143 ("force", keepGoing (pprintClosureCommand False True), False, completeIdentifier),
144 ("breakpoint",bkptOptions, False, completeBkpt),
145 #endif
146 ("kind", keepGoing kindOfType, False, completeIdentifier),
147 ("unset", keepGoing unsetOptions, True, completeSetOptions),
148 ("undef", keepGoing undefineMacro, False, completeMacro),
149 ("quit", quit, False, completeNone)
150 ]
151
152 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
153 keepGoing a str = a str >> return False
154
155 -- tlC: Top Level Command
156 tlC :: (String -> GHCi Bool) -> (String -> GHCi Bool)
157 tlC a str = do
158 top_level <- isTopLevel
159 if not top_level
160 then throwDyn (CmdLineError "Command only allowed at Top Level")
161 else a str
162
163 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
164 keepGoingPaths a str = a (toArgs str) >> return False
165
166 shortHelpText = "use :? for help.\n"
167
168 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
169 helpText =
170 " Commands available from the prompt:\n" ++
171 "\n" ++
172 " <stmt> evaluate/run <stmt>\n" ++
173 " :add <filename> ... add module(s) to the current target set\n" ++
174 " :breakpoint <option> commands for the GHCi debugger\n" ++
175 " :browse [*]<module> display the names defined by <module>\n" ++
176 " :cd <dir> change directory to <dir>\n" ++
177 " :continue equivalent to ':breakpoint continue'\n" ++
178 " :def <cmd> <expr> define a command :<cmd>\n" ++
179 " :edit <file> edit file\n" ++
180 " :edit edit last module\n" ++
181 " :help, :? display this list of commands\n" ++
182 " :info [<name> ...] display information about the given names\n" ++
183 " :print [<name> ...] prints a value without forcing its computation\n" ++
184 " :sprint [<name> ...] simplified version of :print\n" ++
185 " :load <filename> ... load module(s) and their dependents\n" ++
186 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
187 " :main [<arguments> ...] run the main function with the given arguments\n" ++
188 " :reload reload the current module set\n" ++
189 "\n" ++
190 " :set <option> ... set options\n" ++
191 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
192 " :set prog <progname> set the value returned by System.getProgName\n" ++
193 " :set prompt <prompt> set the prompt used in GHCi\n" ++
194 " :set editor <cmd> set the command used for :edit\n" ++
195 "\n" ++
196 " :show modules show the currently loaded modules\n" ++
197 " :show bindings show the current bindings made at the prompt\n" ++
198 "\n" ++
199 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
200 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
201 " :type <expr> show the type of <expr>\n" ++
202 " :kind <type> show the kind of <type>\n" ++
203 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
204 " :unset <option> ... unset options\n" ++
205 " :quit exit GHCi\n" ++
206 " :!<command> run the shell command <command>\n" ++
207 "\n" ++
208 " Options for ':set' and ':unset':\n" ++
209 "\n" ++
210 " +r revert top-level expressions after each evaluation\n" ++
211 " +s print timing/memory stats after each evaluation\n" ++
212 " +t print type after evaluation\n" ++
213 " -<flags> most GHC command line flags can also be set here\n" ++
214 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
215 "\n" ++
216 " Options for ':breakpoint':\n" ++
217 " list list the current breakpoints\n" ++
218 " add Module line [col] add a new breakpoint\n" ++
219 " del (breakpoint# | Module line [col]) delete a breakpoint\n" ++
220 " continue continue execution\n" ++
221 " stop Stop a computation and return to the top level\n" ++
222 " step [count] Step by step execution (DISABLED)\n"
223
224 findEditor = do
225 getEnv "EDITOR"
226 `IO.catch` \_ -> do
227 #if mingw32_HOST_OS
228 win <- System.Win32.getWindowsDirectory
229 return (win `joinFileName` "notepad.exe")
230 #else
231 return ""
232 #endif
233
234 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
235 interactiveUI session srcs maybe_expr = do
236 -- HACK! If we happen to get into an infinite loop (eg the user
237 -- types 'let x=x in x' at the prompt), then the thread will block
238 -- on a blackhole, and become unreachable during GC. The GC will
239 -- detect that it is unreachable and send it the NonTermination
240 -- exception. However, since the thread is unreachable, everything
241 -- it refers to might be finalized, including the standard Handles.
242 -- This sounds like a bug, but we don't have a good solution right
243 -- now.
244 newStablePtr stdin
245 newStablePtr stdout
246 newStablePtr stderr
247
248 -- Initialise buffering for the *interpreted* I/O system
249 initInterpBuffering session
250
251 when (isNothing maybe_expr) $ do
252 -- Only for GHCi (not runghc and ghc -e):
253 -- Turn buffering off for the compiled program's stdout/stderr
254 turnOffBuffering
255 -- Turn buffering off for GHCi's stdout
256 hFlush stdout
257 hSetBuffering stdout NoBuffering
258 -- We don't want the cmd line to buffer any input that might be
259 -- intended for the program, so unbuffer stdin.
260 hSetBuffering stdin NoBuffering
261
262 -- initial context is just the Prelude
263 prel_mod <- GHC.findModule session prel_name Nothing
264 GHC.setContext session [] [prel_mod]
265
266 #ifdef USE_READLINE
267 Readline.initialize
268 Readline.setAttemptedCompletionFunction (Just completeWord)
269 --Readline.parseAndBind "set show-all-if-ambiguous 1"
270
271 let symbols = "!#$%&*+/<=>?@\\^|-~"
272 specials = "(),;[]`{}"
273 spaces = " \t\n"
274 word_break_chars = spaces ++ specials ++ symbols
275
276 Readline.setBasicWordBreakCharacters word_break_chars
277 Readline.setCompleterWordBreakCharacters word_break_chars
278 #endif
279
280 bkptTable <- newIORef emptyBkptTable
281 GHC.setBreakpointHandler session (instrumentationBkptHandler bkptTable)
282 default_editor <- findEditor
283
284 startGHCi (runGHCi srcs maybe_expr)
285 GHCiState{ progname = "<interactive>",
286 args = [],
287 prompt = "%s> ",
288 editor = default_editor,
289 session = session,
290 options = [],
291 prelude = prel_mod,
292 bkptTable = bkptTable,
293 topLevel = True
294 }
295
296 #ifdef USE_READLINE
297 Readline.resetTerminal Nothing
298 #endif
299
300 return ()
301
302 prel_name = GHC.mkModuleName "Prelude"
303
304 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
305 runGHCi paths maybe_expr = do
306 let read_dot_files = not opt_IgnoreDotGhci
307
308 when (read_dot_files) $ do
309 -- Read in ./.ghci.
310 let file = "./.ghci"
311 exists <- io (doesFileExist file)
312 when exists $ do
313 dir_ok <- io (checkPerms ".")
314 file_ok <- io (checkPerms file)
315 when (dir_ok && file_ok) $ do
316 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
317 case either_hdl of
318 Left e -> return ()
319 Right hdl -> fileLoop hdl False
320
321 when (read_dot_files) $ do
322 -- Read in $HOME/.ghci
323 either_dir <- io (IO.try (getEnv "HOME"))
324 case either_dir of
325 Left e -> return ()
326 Right dir -> do
327 cwd <- io (getCurrentDirectory)
328 when (dir /= cwd) $ do
329 let file = dir ++ "/.ghci"
330 ok <- io (checkPerms file)
331 when ok $ do
332 either_hdl <- io (IO.try (openFile file ReadMode))
333 case either_hdl of
334 Left e -> return ()
335 Right hdl -> fileLoop hdl False
336
337 -- Perform a :load for files given on the GHCi command line
338 -- When in -e mode, if the load fails then we want to stop
339 -- immediately rather than going on to evaluate the expression.
340 when (not (null paths)) $ do
341 ok <- ghciHandle (\e -> do showException e; return Failed) $
342 loadModule paths
343 when (isJust maybe_expr && failed ok) $
344 io (exitWith (ExitFailure 1))
345
346 -- if verbosity is greater than 0, or we are connected to a
347 -- terminal, display the prompt in the interactive loop.
348 is_tty <- io (hIsTerminalDevice stdin)
349 dflags <- getDynFlags
350 let show_prompt = verbosity dflags > 0 || is_tty
351
352 case maybe_expr of
353 Nothing ->
354 do
355 #if defined(mingw32_HOST_OS)
356 -- The win32 Console API mutates the first character of
357 -- type-ahead when reading from it in a non-buffered manner. Work
358 -- around this by flushing the input buffer of type-ahead characters,
359 -- but only if stdin is available.
360 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
361 case flushed of
362 Left err | isDoesNotExistError err -> return ()
363 | otherwise -> io (ioError err)
364 Right () -> return ()
365 #endif
366 -- initialise the console if necessary
367 io setUpConsole
368
369 -- enter the interactive loop
370 interactiveLoop is_tty show_prompt
371 Just expr -> do
372 -- just evaluate the expression we were given
373 runCommandEval expr
374 return ()
375
376 -- and finally, exit
377 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
378
379
380 interactiveLoop is_tty show_prompt =
381 -- Ignore ^C exceptions caught here
382 ghciHandleDyn (\e -> case e of
383 Interrupted -> do
384 #if defined(mingw32_HOST_OS)
385 io (putStrLn "")
386 #endif
387 interactiveLoop is_tty show_prompt
388 _other -> return ()) $
389
390 ghciUnblock $ do -- unblock necessary if we recursed from the
391 -- exception handler above.
392
393 -- read commands from stdin
394 #ifdef USE_READLINE
395 if (is_tty)
396 then readlineLoop
397 else fileLoop stdin show_prompt
398 #else
399 fileLoop stdin show_prompt
400 #endif
401
402
403 -- NOTE: We only read .ghci files if they are owned by the current user,
404 -- and aren't world writable. Otherwise, we could be accidentally
405 -- running code planted by a malicious third party.
406
407 -- Furthermore, We only read ./.ghci if . is owned by the current user
408 -- and isn't writable by anyone else. I think this is sufficient: we
409 -- don't need to check .. and ../.. etc. because "." always refers to
410 -- the same directory while a process is running.
411
412 checkPerms :: String -> IO Bool
413 checkPerms name =
414 #ifdef mingw32_HOST_OS
415 return True
416 #else
417 Util.handle (\_ -> return False) $ do
418 st <- getFileStatus name
419 me <- getRealUserID
420 if fileOwner st /= me then do
421 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
422 return False
423 else do
424 let mode = fileMode st
425 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
426 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
427 then do
428 putStrLn $ "*** WARNING: " ++ name ++
429 " is writable by someone else, IGNORING!"
430 return False
431 else return True
432 #endif
433
434 fileLoop :: Handle -> Bool -> GHCi ()
435 fileLoop hdl show_prompt = do
436 session <- getSession
437 (mod,imports) <- io (GHC.getContext session)
438 st <- getGHCiState
439 when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
440 l <- io (IO.try (hGetLine hdl))
441 case l of
442 Left e | isEOFError e -> return ()
443 | InvalidArgument <- etype -> return ()
444 | otherwise -> io (ioError e)
445 where etype = ioeGetErrorType e
446 -- treat InvalidArgument in the same way as EOF:
447 -- this can happen if the user closed stdin, or
448 -- perhaps did getContents which closes stdin at
449 -- EOF.
450 Right l ->
451 case removeSpaces l of
452 "" -> fileLoop hdl show_prompt
453 l -> do quit <- runCommand l
454 if quit then return () else fileLoop hdl show_prompt
455
456 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
457 stringLoop [] = return False
458 stringLoop (s:ss) = do
459 case removeSpaces s of
460 "" -> stringLoop ss
461 l -> do quit <- runCommand l
462 if quit then return True else stringLoop ss
463
464 mkPrompt toplevs exports prompt
465 = showSDoc $ f prompt
466 where
467 f ('%':'s':xs) = perc_s <> f xs
468 f ('%':'%':xs) = char '%' <> f xs
469 f (x:xs) = char x <> f xs
470 f [] = empty
471
472 perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
473 hsep (map (ppr . GHC.moduleName) exports)
474
475
476 #ifdef USE_READLINE
477 readlineLoop :: GHCi ()
478 readlineLoop = do
479 session <- getSession
480 (mod,imports) <- io (GHC.getContext session)
481 io yield
482 saveSession -- for use by completion
483 st <- getGHCiState
484 l <- io (readline (mkPrompt mod imports (prompt st))
485 `finally` setNonBlockingFD 0)
486 -- readline sometimes puts stdin into blocking mode,
487 -- so we need to put it back for the IO library
488 splatSavedSession
489 case l of
490 Nothing -> return ()
491 Just l ->
492 case removeSpaces l of
493 "" -> readlineLoop
494 l -> do
495 io (addHistory l)
496 quit <- runCommand l
497 if quit then return () else readlineLoop
498 #endif
499
500 runCommand :: String -> GHCi Bool
501 runCommand c = ghciHandle handler (doCommand c)
502 where
503 doCommand (':' : command) = specialCommand command
504 doCommand stmt
505 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
506 return False
507
508 -- This version is for the GHC command-line option -e. The only difference
509 -- from runCommand is that it catches the ExitException exception and
510 -- exits, rather than printing out the exception.
511 runCommandEval c = ghciHandle handleEval (doCommand c)
512 where
513 handleEval (ExitException code) = io (exitWith code)
514 handleEval e = do handler e
515 io (exitWith (ExitFailure 1))
516
517 doCommand (':' : command) = specialCommand command
518 doCommand stmt
519 = do nms <- runStmt stmt
520 case nms of
521 Nothing -> io (exitWith (ExitFailure 1))
522 -- failure to run the command causes exit(1) for ghc -e.
523 _ -> finishEvalExpr nms
524
525 runStmt :: String -> GHCi (Maybe [Name])
526 runStmt stmt
527 | null (filter (not.isSpace) stmt) = return (Just [])
528 | otherwise
529 = do st <- getGHCiState
530 session <- getSession
531 result <- io $ withProgName (progname st) $ withArgs (args st) $
532 GHC.runStmt session stmt
533 case result of
534 GHC.RunFailed -> return Nothing
535 GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
536 GHC.RunOk names -> return (Just names)
537
538 -- possibly print the type and revert CAFs after evaluating an expression
539 finishEvalExpr mb_names
540 = do b <- isOptionSet ShowType
541 session <- getSession
542 case mb_names of
543 Nothing -> return ()
544 Just names -> when b (mapM_ (showTypeOfName session) names)
545
546 flushInterpBuffers
547 io installSignalHandlers
548 b <- isOptionSet RevertCAFs
549 io (when b revertCAFs)
550 return True
551
552 showTypeOfName :: Session -> Name -> GHCi ()
553 showTypeOfName session n
554 = do maybe_tything <- io (GHC.lookupName session n)
555 case maybe_tything of
556 Nothing -> return ()
557 Just thing -> showTyThing thing
558
559 specialCommand :: String -> GHCi Bool
560 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
561 specialCommand str = do
562 let (cmd,rest) = break isSpace str
563 maybe_cmd <- io (lookupCommand cmd)
564 case maybe_cmd of
565 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
566 ++ shortHelpText) >> return False)
567 Just (_,f,_,_) -> f (dropWhile isSpace rest)
568
569 lookupCommand :: String -> IO (Maybe Command)
570 lookupCommand str = do
571 cmds <- readIORef commands
572 -- look for exact match first, then the first prefix match
573 case [ c | c <- cmds, str == cmdName c ] of
574 c:_ -> return (Just c)
575 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
576 [] -> return Nothing
577 c:_ -> return (Just c)
578
579 -----------------------------------------------------------------------------
580 -- Commands
581
582 help :: String -> GHCi ()
583 help _ = io (putStr helpText)
584
585 info :: String -> GHCi ()
586 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
587 info s = do { let names = words s
588 ; session <- getSession
589 ; dflags <- getDynFlags
590 ; let exts = dopt Opt_GlasgowExts dflags
591 ; mapM_ (infoThing exts session) names }
592 where
593 infoThing exts session str = io $ do
594 names <- GHC.parseName session str
595 let filtered = filterOutChildren names
596 mb_stuffs <- mapM (GHC.getInfo session) filtered
597 unqual <- GHC.getPrintUnqual session
598 putStrLn (showSDocForUser unqual $
599 vcat (intersperse (text "") $
600 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
601
602 -- Filter out names whose parent is also there Good
603 -- example is '[]', which is both a type and data
604 -- constructor in the same type
605 filterOutChildren :: [Name] -> [Name]
606 filterOutChildren names = filter (not . parent_is_there) names
607 where parent_is_there n
608 -- | Just p <- GHC.nameParent_maybe n = p `elem` names
609 -- ToDo!!
610 | otherwise = False
611
612 pprInfo exts (thing, fixity, insts)
613 = pprTyThingInContextLoc exts thing
614 $$ show_fixity fixity
615 $$ vcat (map GHC.pprInstance insts)
616 where
617 show_fixity fix
618 | fix == GHC.defaultFixity = empty
619 | otherwise = ppr fix <+> ppr (GHC.getName thing)
620
621 -----------------------------------------------------------------------------
622 -- Commands
623
624 runMain :: String -> GHCi ()
625 runMain args = do
626 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
627 runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
628 return ()
629
630 addModule :: [FilePath] -> GHCi ()
631 addModule files = do
632 io (revertCAFs) -- always revert CAFs on load/add.
633 files <- mapM expandPath files
634 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
635 session <- getSession
636 io (mapM_ (GHC.addTarget session) targets)
637 ok <- io (GHC.load session LoadAllTargets)
638 afterLoad ok session
639
640 changeDirectory :: String -> GHCi ()
641 changeDirectory dir = do
642 session <- getSession
643 graph <- io (GHC.getModuleGraph session)
644 when (not (null graph)) $
645 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
646 io (GHC.setTargets session [])
647 io (GHC.load session LoadAllTargets)
648 setContextAfterLoad session []
649 io (GHC.workingDirectoryChanged session)
650 dir <- expandPath dir
651 io (setCurrentDirectory dir)
652
653 editFile :: String -> GHCi ()
654 editFile str
655 | null str = do
656 -- find the name of the "topmost" file loaded
657 session <- getSession
658 graph0 <- io (GHC.getModuleGraph session)
659 graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
660 let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
661 case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
662 Just file -> do_edit file
663 Nothing -> throwDyn (CmdLineError "unknown file name")
664 | otherwise = do_edit str
665 where
666 do_edit file = do
667 st <- getGHCiState
668 let cmd = editor st
669 when (null cmd) $
670 throwDyn (CmdLineError "editor not set, use :set editor")
671 io $ system (cmd ++ ' ':file)
672 return ()
673
674 defineMacro :: String -> GHCi ()
675 defineMacro s = do
676 let (macro_name, definition) = break isSpace s
677 cmds <- io (readIORef commands)
678 if (null macro_name)
679 then throwDyn (CmdLineError "invalid macro name")
680 else do
681 if (macro_name `elem` map cmdName cmds)
682 then throwDyn (CmdLineError
683 ("command '" ++ macro_name ++ "' is already defined"))
684 else do
685
686 -- give the expression a type signature, so we can be sure we're getting
687 -- something of the right type.
688 let new_expr = '(' : definition ++ ") :: String -> IO String"
689
690 -- compile the expression
691 cms <- getSession
692 maybe_hv <- io (GHC.compileExpr cms new_expr)
693 case maybe_hv of
694 Nothing -> return ()
695 Just hv -> io (writeIORef commands --
696 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
697
698 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
699 runMacro fun s = do
700 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
701 stringLoop (lines str)
702
703 undefineMacro :: String -> GHCi ()
704 undefineMacro macro_name = do
705 cmds <- io (readIORef commands)
706 if (macro_name `elem` map cmdName builtin_commands)
707 then throwDyn (CmdLineError
708 ("command '" ++ macro_name ++ "' cannot be undefined"))
709 else do
710 if (macro_name `notElem` map cmdName cmds)
711 then throwDyn (CmdLineError
712 ("command '" ++ macro_name ++ "' not defined"))
713 else do
714 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
715
716
717 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
718 loadModule fs = timeIt (loadModule' fs)
719
720 loadModule_ :: [FilePath] -> GHCi ()
721 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
722
723 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
724 loadModule' files = do
725 session <- getSession
726
727 -- unload first
728 io (GHC.setTargets session [])
729 io (GHC.load session LoadAllTargets)
730
731 -- expand tildes
732 let (filenames, phases) = unzip files
733 exp_filenames <- mapM expandPath filenames
734 let files' = zip exp_filenames phases
735 targets <- io (mapM (uncurry GHC.guessTarget) files')
736
737 -- NOTE: we used to do the dependency anal first, so that if it
738 -- fails we didn't throw away the current set of modules. This would
739 -- require some re-working of the GHC interface, so we'll leave it
740 -- as a ToDo for now.
741
742 io (GHC.setTargets session targets)
743 ok <- io (GHC.load session LoadAllTargets)
744 afterLoad ok session
745 return ok
746
747 checkModule :: String -> GHCi ()
748 checkModule m = do
749 let modl = GHC.mkModuleName m
750 session <- getSession
751 result <- io (GHC.checkModule session modl)
752 case result of
753 Nothing -> io $ putStrLn "Nothing"
754 Just r -> io $ putStrLn (showSDoc (
755 case GHC.checkedModuleInfo r of
756 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
757 let
758 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
759 in
760 (text "global names: " <+> ppr global) $$
761 (text "local names: " <+> ppr local)
762 _ -> empty))
763 afterLoad (successIf (isJust result)) session
764
765 reloadModule :: String -> GHCi ()
766 reloadModule "" = do
767 io (revertCAFs) -- always revert CAFs on reload.
768 session <- getSession
769 ok <- io (GHC.load session LoadAllTargets)
770 afterLoad ok session
771 reloadModule m = do
772 io (revertCAFs) -- always revert CAFs on reload.
773 session <- getSession
774 ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
775 afterLoad ok session
776
777 afterLoad ok session = do
778 io (revertCAFs) -- always revert CAFs on load.
779 graph <- io (GHC.getModuleGraph session)
780 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
781 setContextAfterLoad session graph'
782 refreshBkptTable graph'
783 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
784
785 setContextAfterLoad session [] = do
786 prel_mod <- getPrelude
787 io (GHC.setContext session [] [prel_mod])
788 setContextAfterLoad session ms = do
789 -- load a target if one is available, otherwise load the topmost module.
790 targets <- io (GHC.getTargets session)
791 case [ m | Just m <- map (findTarget ms) targets ] of
792 [] ->
793 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
794 load_this (last graph')
795 (m:_) ->
796 load_this m
797 where
798 findTarget ms t
799 = case filter (`matches` t) ms of
800 [] -> Nothing
801 (m:_) -> Just m
802
803 summary `matches` Target (TargetModule m) _
804 = GHC.ms_mod_name summary == m
805 summary `matches` Target (TargetFile f _) _
806 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
807 summary `matches` target
808 = False
809
810 load_this summary | m <- GHC.ms_mod summary = do
811 b <- io (GHC.moduleIsInterpreted session m)
812 if b then io (GHC.setContext session [m] [])
813 else do
814 prel_mod <- getPrelude
815 io (GHC.setContext session [] [prel_mod,m])
816
817
818 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
819 modulesLoadedMsg ok mods = do
820 dflags <- getDynFlags
821 when (verbosity dflags > 0) $ do
822 let mod_commas
823 | null mods = text "none."
824 | otherwise = hsep (
825 punctuate comma (map ppr mods)) <> text "."
826 case ok of
827 Failed ->
828 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
829 Succeeded ->
830 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
831
832
833 typeOfExpr :: String -> GHCi ()
834 typeOfExpr str
835 = do cms <- getSession
836 maybe_ty <- io (GHC.exprType cms str)
837 case maybe_ty of
838 Nothing -> return ()
839 Just ty -> do ty' <- cleanType ty
840 tystr <- showForUser (ppr ty')
841 io (putStrLn (str ++ " :: " ++ tystr))
842
843 kindOfType :: String -> GHCi ()
844 kindOfType str
845 = do cms <- getSession
846 maybe_ty <- io (GHC.typeKind cms str)
847 case maybe_ty of
848 Nothing -> return ()
849 Just ty -> do tystr <- showForUser (ppr ty)
850 io (putStrLn (str ++ " :: " ++ tystr))
851
852 quit :: String -> GHCi Bool
853 quit _ = do in_inferior_session <- liftM not isTopLevel
854 if in_inferior_session
855 then throwDyn StopParentSession
856 else return True
857
858
859 shellEscape :: String -> GHCi Bool
860 shellEscape str = io (system str >> return False)
861
862 -----------------------------------------------------------------------------
863 -- create tags file for currently loaded modules.
864
865 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
866
867 createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
868 createCTagsFileCmd file = ghciCreateTagsFile CTags file
869
870 createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
871 createETagsFileCmd file = ghciCreateTagsFile ETags file
872
873 data TagsKind = ETags | CTags
874
875 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
876 ghciCreateTagsFile kind file = do
877 session <- getSession
878 io $ createTagsFile session kind file
879
880 -- ToDo:
881 -- - remove restriction that all modules must be interpreted
882 -- (problem: we don't know source locations for entities unless
883 -- we compiled the module.
884 --
885 -- - extract createTagsFile so it can be used from the command-line
886 -- (probably need to fix first problem before this is useful).
887 --
888 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
889 createTagsFile session tagskind tagFile = do
890 graph <- GHC.getModuleGraph session
891 let ms = map GHC.ms_mod graph
892 tagModule m = do
893 is_interpreted <- GHC.moduleIsInterpreted session m
894 -- should we just skip these?
895 when (not is_interpreted) $
896 throwDyn (CmdLineError ("module '"
897 ++ GHC.moduleNameString (GHC.moduleName m)
898 ++ "' is not interpreted"))
899 mbModInfo <- GHC.getModuleInfo session m
900 let unqual
901 | Just modinfo <- mbModInfo,
902 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
903 | otherwise = GHC.alwaysQualify
904
905 case mbModInfo of
906 Just modInfo -> return $! listTags unqual modInfo
907 _ -> return []
908
909 mtags <- mapM tagModule ms
910 either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
911 case either_res of
912 Left e -> hPutStrLn stderr $ ioeGetErrorString e
913 Right _ -> return ()
914
915 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
916 listTags unqual modInfo =
917 [ tagInfo unqual name loc
918 | name <- GHC.modInfoExports modInfo
919 , let loc = nameSrcLoc name
920 , isGoodSrcLoc loc
921 ]
922
923 type TagInfo = (String -- tag name
924 ,String -- file name
925 ,Int -- line number
926 ,Int -- column number
927 )
928
929 -- get tag info, for later translation into Vim or Emacs style
930 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
931 tagInfo unqual name loc
932 = ( showSDocForUser unqual $ pprOccName (nameOccName name)
933 , showSDocForUser unqual $ ftext (srcLocFile loc)
934 , srcLocLine loc
935 , srcLocCol loc
936 )
937
938 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
939 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
940 let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
941 IO.try (writeFile file tags)
942 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
943 let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
944 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
945 tagGroups <- mapM tagFileGroup groups
946 IO.try (writeFile file $ concat tagGroups)
947 where
948 tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
949 tagFileGroup group@((_,fileName,_,_):_) = do
950 file <- readFile fileName -- need to get additional info from sources..
951 let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
952 sortedGroup = sortLe byLine group
953 tags = unlines $ perFile sortedGroup 1 0 $ lines file
954 return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
955 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
956 perFile (tagInfo:tags) (count+1) (pos+length line) lines
957 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
958 showETag tagInfo line pos : perFile tags count pos lines
959 perFile tags count pos lines = []
960
961 -- simple ctags format, for Vim et al
962 showTag :: TagInfo -> String
963 showTag (tag,file,lineNo,colNo)
964 = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
965
966 -- etags format, for Emacs/XEmacs
967 showETag :: TagInfo -> String -> Int -> String
968 showETag (tag,file,lineNo,colNo) line charPos
969 = take colNo line ++ tag
970 ++ "\x7f" ++ tag
971 ++ "\x01" ++ show lineNo
972 ++ "," ++ show charPos
973
974 -----------------------------------------------------------------------------
975 -- Browsing a module's contents
976
977 browseCmd :: String -> GHCi ()
978 browseCmd m =
979 case words m of
980 ['*':m] | looksLikeModuleName m -> browseModule m False
981 [m] | looksLikeModuleName m -> browseModule m True
982 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
983
984 browseModule m exports_only = do
985 s <- getSession
986 modl <- io $ GHC.findModule s (GHC.mkModuleName m) Nothing
987 is_interpreted <- io (GHC.moduleIsInterpreted s modl)
988 when (not is_interpreted && not exports_only) $
989 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
990
991 -- Temporarily set the context to the module we're interested in,
992 -- just so we can get an appropriate PrintUnqualified
993 (as,bs) <- io (GHC.getContext s)
994 prel_mod <- getPrelude
995 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
996 else GHC.setContext s [modl] [])
997 unqual <- io (GHC.getPrintUnqual s)
998 io (GHC.setContext s as bs)
999
1000 mb_mod_info <- io $ GHC.getModuleInfo s modl
1001 case mb_mod_info of
1002 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1003 Just mod_info -> do
1004 let names
1005 | exports_only = GHC.modInfoExports mod_info
1006 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
1007
1008 filtered = filterOutChildren names
1009
1010 things <- io $ mapM (GHC.lookupName s) filtered
1011
1012 dflags <- getDynFlags
1013 let exts = dopt Opt_GlasgowExts dflags
1014 io (putStrLn (showSDocForUser unqual (
1015 vcat (map (pprTyThingInContext exts) (catMaybes things))
1016 )))
1017 -- ToDo: modInfoInstances currently throws an exception for
1018 -- package modules. When it works, we can do this:
1019 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1020
1021 -----------------------------------------------------------------------------
1022 -- Setting the module context
1023
1024 setContext str
1025 | all sensible mods = fn mods
1026 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1027 where
1028 (fn, mods) = case str of
1029 '+':stuff -> (addToContext, words stuff)
1030 '-':stuff -> (removeFromContext, words stuff)
1031 stuff -> (newContext, words stuff)
1032
1033 sensible ('*':m) = looksLikeModuleName m
1034 sensible m = looksLikeModuleName m
1035
1036 separate :: Session -> [String] -> [Module] -> [Module]
1037 -> GHCi ([Module],[Module])
1038 separate session [] as bs = return (as,bs)
1039 separate session (('*':str):ms) as bs = do
1040 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1041 b <- io $ GHC.moduleIsInterpreted session m
1042 if b then separate session ms (m:as) bs
1043 else throwDyn (CmdLineError ("module '"
1044 ++ GHC.moduleNameString (GHC.moduleName m)
1045 ++ "' is not interpreted"))
1046 separate session (str:ms) as bs = do
1047 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1048 separate session ms as (m:bs)
1049
1050 newContext :: [String] -> GHCi ()
1051 newContext strs = do
1052 s <- getSession
1053 (as,bs) <- separate s strs [] []
1054 prel_mod <- getPrelude
1055 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1056 io $ GHC.setContext s as bs'
1057
1058
1059 addToContext :: [String] -> GHCi ()
1060 addToContext strs = do
1061 s <- getSession
1062 (as,bs) <- io $ GHC.getContext s
1063
1064 (new_as,new_bs) <- separate s strs [] []
1065
1066 let as_to_add = new_as \\ (as ++ bs)
1067 bs_to_add = new_bs \\ (as ++ bs)
1068
1069 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1070
1071
1072 removeFromContext :: [String] -> GHCi ()
1073 removeFromContext strs = do
1074 s <- getSession
1075 (as,bs) <- io $ GHC.getContext s
1076
1077 (as_to_remove,bs_to_remove) <- separate s strs [] []
1078
1079 let as' = as \\ (as_to_remove ++ bs_to_remove)
1080 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1081
1082 io $ GHC.setContext s as' bs'
1083
1084 ----------------------------------------------------------------------------
1085 -- Code for `:set'
1086
1087 -- set options in the interpreter. Syntax is exactly the same as the
1088 -- ghc command line, except that certain options aren't available (-C,
1089 -- -E etc.)
1090 --
1091 -- This is pretty fragile: most options won't work as expected. ToDo:
1092 -- figure out which ones & disallow them.
1093
1094 setCmd :: String -> GHCi ()
1095 setCmd ""
1096 = do st <- getGHCiState
1097 let opts = options st
1098 io $ putStrLn (showSDoc (
1099 text "options currently set: " <>
1100 if null opts
1101 then text "none."
1102 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1103 ))
1104 setCmd str
1105 = case toArgs str of
1106 ("args":args) -> setArgs args
1107 ("prog":prog) -> setProg prog
1108 ("prompt":prompt) -> setPrompt (after 6)
1109 ("editor":cmd) -> setEditor (after 6)
1110 wds -> setOptions wds
1111 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1112
1113 setArgs args = do
1114 st <- getGHCiState
1115 setGHCiState st{ args = args }
1116
1117 setProg [prog] = do
1118 st <- getGHCiState
1119 setGHCiState st{ progname = prog }
1120 setProg _ = do
1121 io (hPutStrLn stderr "syntax: :set prog <progname>")
1122
1123 setEditor cmd = do
1124 st <- getGHCiState
1125 setGHCiState st{ editor = cmd }
1126
1127 setPrompt value = do
1128 st <- getGHCiState
1129 if null value
1130 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1131 else setGHCiState st{ prompt = remQuotes value }
1132 where
1133 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1134 remQuotes x = x
1135
1136 setOptions wds =
1137 do -- first, deal with the GHCi opts (+s, +t, etc.)
1138 let (plus_opts, minus_opts) = partition isPlus wds
1139 mapM_ setOpt plus_opts
1140
1141 -- then, dynamic flags
1142 dflags <- getDynFlags
1143 let pkg_flags = packageFlags dflags
1144 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1145
1146 if (not (null leftovers))
1147 then throwDyn (CmdLineError ("unrecognised flags: " ++
1148 unwords leftovers))
1149 else return ()
1150
1151 new_pkgs <- setDynFlags dflags'
1152
1153 -- if the package flags changed, we should reset the context
1154 -- and link the new packages.
1155 dflags <- getDynFlags
1156 when (packageFlags dflags /= pkg_flags) $ do
1157 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1158 session <- getSession
1159 io (GHC.setTargets session [])
1160 io (GHC.load session LoadAllTargets)
1161 io (linkPackages dflags new_pkgs)
1162 setContextAfterLoad session []
1163 return ()
1164
1165
1166 unsetOptions :: String -> GHCi ()
1167 unsetOptions str
1168 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1169 let opts = words str
1170 (minus_opts, rest1) = partition isMinus opts
1171 (plus_opts, rest2) = partition isPlus rest1
1172
1173 if (not (null rest2))
1174 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1175 else do
1176
1177 mapM_ unsetOpt plus_opts
1178
1179 -- can't do GHC flags for now
1180 if (not (null minus_opts))
1181 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1182 else return ()
1183
1184 isMinus ('-':s) = True
1185 isMinus _ = False
1186
1187 isPlus ('+':s) = True
1188 isPlus _ = False
1189
1190 setOpt ('+':str)
1191 = case strToGHCiOpt str of
1192 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1193 Just o -> setOption o
1194
1195 unsetOpt ('+':str)
1196 = case strToGHCiOpt str of
1197 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1198 Just o -> unsetOption o
1199
1200 strToGHCiOpt :: String -> (Maybe GHCiOption)
1201 strToGHCiOpt "s" = Just ShowTiming
1202 strToGHCiOpt "t" = Just ShowType
1203 strToGHCiOpt "r" = Just RevertCAFs
1204 strToGHCiOpt _ = Nothing
1205
1206 optToStr :: GHCiOption -> String
1207 optToStr ShowTiming = "s"
1208 optToStr ShowType = "t"
1209 optToStr RevertCAFs = "r"
1210
1211 -- ---------------------------------------------------------------------------
1212 -- code for `:show'
1213
1214 showCmd str =
1215 case words str of
1216 ["modules" ] -> showModules
1217 ["bindings"] -> showBindings
1218 ["linker"] -> io showLinkerState
1219 ["breakpoints"] -> showBkptTable
1220 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1221
1222 showModules = do
1223 session <- getSession
1224 let show_one ms = do m <- io (GHC.showModule session ms)
1225 io (putStrLn m)
1226 graph <- io (GHC.getModuleGraph session)
1227 mapM_ show_one graph
1228
1229 showBindings = do
1230 s <- getSession
1231 unqual <- io (GHC.getPrintUnqual s)
1232 bindings <- io (GHC.getBindings s)
1233 mapM_ showTyThing bindings
1234 return ()
1235
1236 showTyThing (AnId id) = do
1237 ty' <- cleanType (GHC.idType id)
1238 str <- showForUser (ppr id <> text " :: " <> ppr ty')
1239 io (putStrLn str)
1240 showTyThing _ = return ()
1241
1242 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1243 cleanType :: Type -> GHCi Type
1244 cleanType ty = do
1245 dflags <- getDynFlags
1246 if dopt Opt_GlasgowExts dflags
1247 then return ty
1248 else return $! GHC.dropForAlls ty
1249
1250 showBkptTable :: GHCi ()
1251 showBkptTable = do
1252 bt <- getBkptTable
1253 msg <- showForUser . vcat $
1254 [ ppr mod <> colon <+> fcat
1255 [ parens(int row <> comma <> int col) | (row,col) <- sites]
1256 | (mod, sites) <- sitesList bt ]
1257 io (putStrLn msg)
1258 -- -----------------------------------------------------------------------------
1259 -- Completion
1260
1261 completeNone :: String -> IO [String]
1262 completeNone w = return []
1263
1264 #ifdef USE_READLINE
1265 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1266 completeWord w start end = do
1267 line <- Readline.getLineBuffer
1268 case w of
1269 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1270 _other
1271 | Just c <- is_cmd line -> do
1272 maybe_cmd <- lookupCommand c
1273 let (n,w') = selectWord (words' 0 line)
1274 case maybe_cmd of
1275 Nothing -> return Nothing
1276 Just (_,_,False,complete) -> wrapCompleter complete w
1277 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1278 return (map (drop n) rets)
1279 in wrapCompleter complete' w'
1280 | otherwise -> do
1281 --printf "complete %s, start = %d, end = %d\n" w start end
1282 wrapCompleter completeIdentifier w
1283 where words' _ [] = []
1284 words' n str = let (w,r) = break isSpace str
1285 (s,r') = span isSpace r
1286 in (n,w):words' (n+length w+length s) r'
1287 -- In a Haskell expression we want to parse 'a-b' as three words
1288 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1289 -- only be a single word.
1290 selectWord [] = (0,w)
1291 selectWord ((offset,x):xs)
1292 | offset+length x >= start = (start-offset,take (end-offset) x)
1293 | otherwise = selectWord xs
1294
1295 is_cmd line
1296 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1297 | otherwise = Nothing
1298
1299 completeCmd w = do
1300 cmds <- readIORef commands
1301 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1302
1303 completeMacro w = do
1304 cmds <- readIORef commands
1305 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1306 return (filter (w `isPrefixOf`) cmds')
1307
1308 completeIdentifier w = do
1309 s <- restoreSession
1310 rdrs <- GHC.getRdrNamesInScope s
1311 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1312
1313 completeModule w = do
1314 s <- restoreSession
1315 dflags <- GHC.getSessionDynFlags s
1316 let pkg_mods = allExposedModules dflags
1317 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1318
1319 completeHomeModule w = do
1320 s <- restoreSession
1321 g <- GHC.getModuleGraph s
1322 let home_mods = map GHC.ms_mod_name g
1323 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1324
1325 completeSetOptions w = do
1326 return (filter (w `isPrefixOf`) options)
1327 where options = "args":"prog":allFlags
1328
1329 completeBkpt = unionComplete completeModule completeBkptCmds
1330
1331 completeBkptCmds w = do
1332 return (filter (w `isPrefixOf`) options)
1333 where options = ["add","del","list","stop"]
1334
1335 completeFilename = Readline.filenameCompletionFunction
1336
1337 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1338
1339 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1340 unionComplete f1 f2 w = do
1341 s1 <- f1 w
1342 s2 <- f2 w
1343 return (s1 ++ s2)
1344
1345 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1346 wrapCompleter fun w = do
1347 strs <- fun w
1348 case strs of
1349 [] -> return Nothing
1350 [x] -> return (Just (x,[]))
1351 xs -> case getCommonPrefix xs of
1352 "" -> return (Just ("",xs))
1353 pref -> return (Just (pref,xs))
1354
1355 getCommonPrefix :: [String] -> String
1356 getCommonPrefix [] = ""
1357 getCommonPrefix (s:ss) = foldl common s ss
1358 where common s "" = s
1359 common "" s = ""
1360 common (c:cs) (d:ds)
1361 | c == d = c : common cs ds
1362 | otherwise = ""
1363
1364 allExposedModules :: DynFlags -> [ModuleName]
1365 allExposedModules dflags
1366 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1367 where
1368 pkg_db = pkgIdMap (pkgState dflags)
1369 #else
1370 completeCmd = completeNone
1371 completeMacro = completeNone
1372 completeIdentifier = completeNone
1373 completeModule = completeNone
1374 completeHomeModule = completeNone
1375 completeSetOptions = completeNone
1376 completeFilename = completeNone
1377 completeHomeModuleOrFile=completeNone
1378 completeBkpt = completeNone
1379 #endif
1380
1381 -- ---------------------------------------------------------------------------
1382 -- User code exception handling
1383
1384 -- This is the exception handler for exceptions generated by the
1385 -- user's code and exceptions coming from children sessions;
1386 -- it normally just prints out the exception. The
1387 -- handler must be recursive, in case showing the exception causes
1388 -- more exceptions to be raised.
1389 --
1390 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1391 -- raising another exception. We therefore don't put the recursive
1392 -- handler arond the flushing operation, so if stderr is closed
1393 -- GHCi will just die gracefully rather than going into an infinite loop.
1394 handler :: Exception -> GHCi Bool
1395 handler (DynException dyn)
1396 | Just StopChildSession <- fromDynamic dyn
1397 -- propagate to the parent session
1398 = do ASSERTM (liftM not isTopLevel)
1399 throwDyn StopChildSession
1400
1401 | Just StopParentSession <- fromDynamic dyn
1402 = do at_topLevel <- isTopLevel
1403 if at_topLevel then return True else throwDyn StopParentSession
1404
1405 | Just (ChildSessionStopped msg) <- fromDynamic dyn
1406 -- Reload modules and display some message
1407 = do ASSERTM (isTopLevel)
1408 io(putStrLn msg) >> return False
1409
1410 handler exception = do
1411 flushInterpBuffers
1412 io installSignalHandlers
1413 ghciHandle handler (showException exception >> return False)
1414
1415 showException (DynException dyn) =
1416 case fromDynamic dyn of
1417 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1418 Just Interrupted -> io (putStrLn "Interrupted.")
1419 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1420 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1421 Just other_ghc_ex -> io (print other_ghc_ex)
1422
1423 showException other_exception
1424 = io (putStrLn ("*** Exception: " ++ show other_exception))
1425
1426 -----------------------------------------------------------------------------
1427 -- recursive exception handlers
1428
1429 -- Don't forget to unblock async exceptions in the handler, or if we're
1430 -- in an exception loop (eg. let a = error a in a) the ^C exception
1431 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1432
1433 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1434 ghciHandle h (GHCi m) = GHCi $ \s ->
1435 Exception.catch (m s)
1436 (\e -> unGHCi (ghciUnblock (h e)) s)
1437
1438 ghciUnblock :: GHCi a -> GHCi a
1439 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1440
1441
1442 -- ----------------------------------------------------------------------------
1443 -- Utils
1444
1445 expandPath :: String -> GHCi String
1446 expandPath path =
1447 case dropWhile isSpace path of
1448 ('~':d) -> do
1449 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1450 return (tilde ++ '/':d)
1451 other ->
1452 return other
1453
1454 -- ----------------------------------------------------------------------------
1455 -- Windows console setup
1456
1457 setUpConsole :: IO ()
1458 setUpConsole = do
1459 #ifdef mingw32_HOST_OS
1460 -- On Windows we need to set a known code page, otherwise the characters
1461 -- we read from the console will be be in some strange encoding, and
1462 -- similarly for characters we write to the console.
1463 --
1464 -- At the moment, GHCi pretends all input is Latin-1. In the
1465 -- future we should support UTF-8, but for now we set the code pages
1466 -- to Latin-1.
1467 --
1468 -- It seems you have to set the font in the console window to
1469 -- a Unicode font in order for output to work properly,
1470 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1471 -- (see MSDN for SetConsoleOutputCP()).
1472 --
1473 setConsoleCP 28591 -- ISO Latin-1
1474 setConsoleOutputCP 28591 -- ISO Latin-1
1475 #endif
1476 return ()
1477
1478
1479 instrumentationBkptHandler :: IORef (BkptTable Module) -> BkptHandler Module
1480 instrumentationBkptHandler ref_bkptTable = BkptHandler {
1481 isAutoBkptEnabled = \sess bkptLoc -> do
1482 bktpTable <- readIORef ref_bkptTable
1483 return$ isBkptEnabled bktpTable bkptLoc
1484
1485 , handleBreakpoint = doBreakpoint ref_bkptTable
1486 }
1487
1488 doBreakpoint :: IORef (BkptTable Module)-> Session -> [(Id,HValue)] -> BkptLocation Module -> String -> b -> IO b
1489 doBreakpoint ref_bkptTable s@(Session ref) values _ locMsg b = do
1490 let (ids, hValues) = unzip values
1491 names = map idName ids
1492 ASSERT (length names == length hValues) return ()
1493 let global_ids = map globaliseAndTidy ids
1494 printScopeMsg locMsg global_ids
1495 typed_ids <- mapM instantiateIdType global_ids
1496 hsc_env <- readIORef ref
1497 let ictxt = hsc_IC hsc_env
1498 rn_env = ic_rn_local_env ictxt
1499 type_env = ic_type_env ictxt
1500 bound_names = map idName typed_ids
1501 new_rn_env = extendLocalRdrEnv rn_env bound_names
1502 -- Remove any shadowed bindings from the type_env;
1503 -- they are inaccessible but might, I suppose, cause
1504 -- a space leak if we leave them there
1505 shadowed = [ n | name <- bound_names,
1506 let rdr_name = mkRdrUnqual (nameOccName name),
1507 Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
1508 filtered_type_env = delListFromNameEnv type_env shadowed
1509 new_type_env = extendTypeEnvWithIds filtered_type_env (typed_ids)
1510 new_ic = ictxt { ic_rn_local_env = new_rn_env,
1511 ic_type_env = new_type_env }
1512 writeIORef ref (hsc_env { hsc_IC = new_ic })
1513 is_tty <- hIsTerminalDevice stdin
1514 prel_mod <- GHC.findModule s prel_name Nothing
1515 withExtendedLinkEnv (zip names hValues) $
1516 startGHCi (interactiveLoop is_tty True) GHCiState{
1517 progname = "<interactive>",
1518 args = [],
1519 prompt = locMsg ++ "> ",
1520 session = s,
1521 options = [],
1522 bkptTable= ref_bkptTable,
1523 prelude = prel_mod,
1524 topLevel = False }
1525 `catchDyn` (\e -> case e of
1526 StopChildSession -> evaluate$
1527 throwDyn (ChildSessionStopped "")
1528 StopParentSession -> throwDyn StopParentSession
1529 ) `finally` do
1530 writeIORef ref hsc_env
1531 putStrLn $ "Returning to normal execution..."
1532 return b
1533 where
1534 printScopeMsg :: String -> [Id] -> IO ()
1535 printScopeMsg location ids = do
1536 unqual <- GHC.getPrintUnqual s
1537 printForUser stdout unqual $
1538 text "Stopped at a breakpoint in " <> text (stripColumn location) <>
1539 char '.' <+> text "Local bindings in scope:" $$
1540 nest 2 (pprWithCommas showId ids)
1541 where
1542 showId id =
1543 ppr (idName id) <+> dcolon <+> ppr (idType id)
1544 stripColumn = reverse . tail . dropWhile (/= ':') . reverse
1545
1546 -- | Give the Id a Global Name, and tidy its type
1547 globaliseAndTidy :: Id -> Id
1548 globaliseAndTidy id
1549 = let tidied_type = tidyTopType$ idType id
1550 in setIdType (globaliseId VanillaGlobal id) tidied_type
1551
1552 -- | Instantiate the tyVars with GHC.Base.Unknown
1553 instantiateIdType :: Id -> IO Id
1554 instantiateIdType id = do
1555 instantiatedType <- instantiateTyVarsToUnknown s (idType id)
1556 return$ setIdType id instantiatedType
1557
1558