InteractiveUI.hs 57.3 KB
Newer Older
1
{-# OPTIONS -#include "Linker.h" #-}
2
3
4
5
-----------------------------------------------------------------------------
--
-- GHC Interactive User Interface
--
6
-- (c) The GHC Team 2005-2006
7
8
--
-----------------------------------------------------------------------------
9
module InteractiveUI ( 
10
	interactiveUI,
11
12
	ghciWelcomeMsg
   ) where
13

14
15
#include "HsVersions.h"

mnislaih's avatar
mnislaih committed
16
import GhciMonad
17

18
19
-- The GHC interface
import qualified GHC
20
import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
21
22
23
                          Type, Module, ModuleName, TyThing(..), Phase,
                          BreakIndex )
import Debugger
24
25
26
27
import DynFlags
import Packages
import PackageConfig
import UniqFM
28
import PprTyThing
29
import Outputable       hiding (printForUser)
30
import Module           -- for ModuleEnv
31

32
33
34
35
-- for createtags
import Name
import OccName
import SrcLoc
36

37
-- Other random utilities
38
import Digraph
mnislaih's avatar
mnislaih committed
39
40
import BasicTypes hiding (isTopLevel)
import Panic      hiding (showException)
41
import Config
42
43
44
import StaticFlags
import Linker
import Util
45

46
#ifndef mingw32_HOST_OS
ross's avatar
ross committed
47
import System.Posix
48
49
50
#if __GLASGOW_HASKELL__ > 504
	hiding (getEnv)
#endif
sof's avatar
sof committed
51
52
#else
import GHC.ConsoleHandler ( flushConsole )
53
import System.Win32	  ( setConsoleCP, setConsoleOutputCP )
54
import qualified System.Win32
sof's avatar
sof committed
55
56
#endif

57
#ifdef USE_READLINE
58
import Control.Concurrent	( yield )	-- Used in readline loop
59
import System.Console.Readline as Readline
60
#endif
61
62
63
64

--import SystemExts

import Control.Exception as Exception
65
-- import Control.Concurrent
66

67
import Data.List
68
import Data.Maybe
69
70
import System.Cmd
import System.Environment
71
import System.Exit	( exitWith, ExitCode(..) )
72
import System.Directory
ross's avatar
ross committed
73
74
import System.IO
import System.IO.Error as IO
75
import Data.Char
mnislaih's avatar
mnislaih committed
76
import Data.Dynamic
77
import Data.Array
78
import Control.Monad as Monad
79

80
import Foreign.StablePtr	( newStablePtr )
81
import GHC.Exts		( unsafeCoerce# )
Simon Marlow's avatar
Simon Marlow committed
82
import GHC.IOBase	( IOErrorType(InvalidArgument) )
83

84
import Data.IORef	( IORef, readIORef, writeIORef )
85

86
import System.Posix.Internals ( setNonBlockingFD )
87

88
89
-----------------------------------------------------------------------------

90
91
92
93
94
95
ghciWelcomeMsg =
 "   ___         ___ _\n"++
 "  / _ \\ /\\  /\\/ __(_)\n"++
 " / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
 "/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n"++
 "\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
96

97
98
type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
cmdName (n,_,_,_) = n
99

Simon Marlow's avatar
Simon Marlow committed
100
101
102
GLOBAL_VAR(commands, builtin_commands, [Command])

builtin_commands :: [Command]
103
builtin_commands = [
104
105
	-- Hugs users are accustomed to :e, so make sure it doesn't overlap
  ("?",		keepGoing help,			False, completeNone),
106
  ("add",	keepGoingPaths addModule,	False, completeFilename),
107
  ("break",     breakCmd,                       False, completeIdentifier),
108
  ("browse",    keepGoing browseCmd,		False, completeModule),
109
  ("cd",    	keepGoing changeDirectory,	False, completeFilename),
110
  ("check",	keepGoing checkModule,		False, completeHomeModule),
111
  ("continue",  continueCmd,                    False, completeNone),
112
  ("ctags",	keepGoing createCTagsFileCmd, 	False, completeFilename),
113
  ("def",	keepGoing defineMacro,		False, completeIdentifier),
114
  ("delete",    deleteCmd,                      False, completeNone),
Simon Marlow's avatar
Simon Marlow committed
115
116
  ("e", 	keepGoing editFile,		False, completeFilename),
  ("edit",	keepGoing editFile,		False, completeFilename),
117
118
  ("etags",	keepGoing createETagsFileCmd,	False, completeFilename),
  ("force",     keepGoing (pprintClosureCommand False True), False, completeIdentifier),
119
120
  ("help",	keepGoing help,			False, completeNone),
  ("info",      keepGoing info,			False, completeIdentifier),
121
  ("kind",	keepGoing kindOfType,		False, completeIdentifier),
122
  ("load",	keepGoingPaths loadModule_,     False, completeHomeModuleOrFile),
123
  ("module",	keepGoing setContext,		False, completeModule),
124
  ("main",	keepGoing runMain,		False, completeIdentifier),
125
126
  ("print",     keepGoing (pprintClosureCommand True False), False, completeIdentifier),
  ("quit",	quit,				False, completeNone),
127
  ("reload", 	keepGoing reloadModule,  	False, completeNone),
128
129
  ("set",	keepGoing setCmd,		True,  completeSetOptions),
  ("show",	keepGoing showCmd,		False, completeNone),
mnislaih's avatar
mnislaih committed
130
  ("sprint",    keepGoing (pprintClosureCommand False False),False, completeIdentifier),
131
  ("step",      stepCmd,                        False, completeIdentifier), 
132
  ("type",	keepGoing typeOfExpr,		False, completeIdentifier),
133
  ("undef",     keepGoing undefineMacro,	False, completeMacro),
134
  ("unset",	keepGoing unsetOptions,		True,  completeSetOptions)
135
136
  ]

137
138
139
keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
keepGoing a str = a str >> return False

sof's avatar
sof committed
140
141
142
keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
keepGoingPaths a str = a (toArgs str) >> return False

143
144
shortHelpText = "use :? for help.\n"

145
146
147
148
149
helpText =
 " Commands available from the prompt:\n" ++
 "\n" ++
 "   <stmt>                      evaluate/run <stmt>\n" ++
 "   :add <filename> ...         add module(s) to the current target set\n" ++
Simon Marlow's avatar
Simon Marlow committed
150
151
 "   :break [<mod>] <l> [<col>]  set a breakpoint at the specified location\n" ++
 "   :break <name>               set a breakpoint on the specified function\n" ++
152
153
 "   :browse [*]<module>         display the names defined by <module>\n" ++
 "   :cd <dir>                   change directory to <dir>\n" ++
Simon Marlow's avatar
Simon Marlow committed
154
155
 "   :continue                   resume after a breakpoint\n" ++
 "   :ctags [<file>]             create tags file for Vi (default: \"tags\")\n" ++
156
 "   :def <cmd> <expr>           define a command :<cmd>\n" ++
Simon Marlow's avatar
Simon Marlow committed
157
158
 "   :delete <number>            delete the specified breakpoint\n" ++
 "   :delete *                   delete all breakpoints\n" ++
Simon Marlow's avatar
Simon Marlow committed
159
160
 "   :edit <file>                edit file\n" ++
 "   :edit                       edit last module\n" ++
Simon Marlow's avatar
Simon Marlow committed
161
162
 "   :etags [<file>]             create tags file for Emacs (default: \"TAGS\")\n" ++
-- "   :force <expr>               print <expr>, forcing unevaluated parts\n" ++
163
164
 "   :help, :?                   display this list of commands\n" ++
 "   :info [<name> ...]          display information about the given names\n" ++
Simon Marlow's avatar
Simon Marlow committed
165
 "   :kind <type>                show the kind of <type>\n" ++
166
167
 "   :load <filename> ...        load module(s) and their dependents\n" ++
 "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
168
 "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
Simon Marlow's avatar
Simon Marlow committed
169
170
 "   :print [<name> ...]         prints a value without forcing its computation\n" ++
 "   :quit                       exit GHCi\n" ++
171
172
173
174
175
 "   :reload                     reload the current module set\n" ++
 "\n" ++
 "   :set <option> ...           set options\n" ++
 "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
 "   :set prog <progname>        set the value returned by System.getProgName\n" ++
Simon Marlow's avatar
Simon Marlow committed
176
 "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
Ian Lynagh's avatar
Ian Lynagh committed
177
 "   :set editor <cmd>           set the command used for :edit\n" ++
178
 "\n" ++
Simon Marlow's avatar
Simon Marlow committed
179
180
 "   :show breaks                show active breakpoints\n" ++
 "   :show context               show the breakpoint context\n" ++
181
182
183
 "   :show modules               show the currently loaded modules\n" ++
 "   :show bindings              show the current bindings made at the prompt\n" ++
 "\n" ++
Simon Marlow's avatar
Simon Marlow committed
184
185
186
 "   :sprint [<name> ...]        simplifed version of :print\n" ++
 "   :step                       single-step after stopping at a breakpoint\n"++
 "   :step <expr>                single-step into <expr>\n"++
187
188
189
190
191
192
193
194
195
196
197
 "   :type <expr>                show the type of <expr>\n" ++
 "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
 "   :unset <option> ...         unset options\n" ++
 "   :!<command>                 run the shell command <command>\n" ++
 "\n" ++
 " Options for ':set' and ':unset':\n" ++
 "\n" ++
 "    +r            revert top-level expressions after each evaluation\n" ++
 "    +s            print timing/memory stats after each evaluation\n" ++
 "    +t            print type after evaluation\n" ++
 "    -<flags>      most GHC command line flags can also be set here\n" ++
mnislaih's avatar
mnislaih committed
198
 "                         (eg. -v2, -fglasgow-exts, etc.)\n" ++
199
200
 "\n" 
-- Todo: add help for breakpoint commands here
201

Simon Marlow's avatar
Simon Marlow committed
202
203
204
findEditor = do
  getEnv "EDITOR" 
    `IO.catch` \_ -> do
205
206
#if mingw32_HOST_OS
	win <- System.Win32.getWindowsDirectory
Simon Marlow's avatar
Simon Marlow committed
207
	return (win `joinFileName` "notepad.exe")
Simon Marlow's avatar
Simon Marlow committed
208
209
210
211
#else
	return ""
#endif

212
interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
213
interactiveUI session srcs maybe_expr = do
214
215
216
217
218
219
220
221
222
223
224
225
   -- HACK! If we happen to get into an infinite loop (eg the user
   -- types 'let x=x in x' at the prompt), then the thread will block
   -- on a blackhole, and become unreachable during GC.  The GC will
   -- detect that it is unreachable and send it the NonTermination
   -- exception.  However, since the thread is unreachable, everything
   -- it refers to might be finalized, including the standard Handles.
   -- This sounds like a bug, but we don't have a good solution right
   -- now.
   newStablePtr stdin
   newStablePtr stdout
   newStablePtr stderr

226
	-- Initialise buffering for the *interpreted* I/O system
227
   initInterpBuffering session
228

229
230
231
232
233
234
235
   when (isNothing maybe_expr) $ do
	-- Only for GHCi (not runghc and ghc -e):
	-- Turn buffering off for the compiled program's stdout/stderr
	turnOffBuffering
	-- Turn buffering off for GHCi's stdout
	hFlush stdout
	hSetBuffering stdout NoBuffering
236
237
	-- We don't want the cmd line to buffer any input that might be
	-- intended for the program, so unbuffer stdin.
238
	hSetBuffering stdin NoBuffering
239

240
	-- initial context is just the Prelude
241
   prel_mod <- GHC.findModule session prel_name (Just basePackageId)
Simon Marlow's avatar
Simon Marlow committed
242
   GHC.setContext session [] [prel_mod]
243

244
#ifdef USE_READLINE
245
   Readline.initialize
Simon Marlow's avatar
Simon Marlow committed
246
247
248
249
250
251
252
253
254
255
   Readline.setAttemptedCompletionFunction (Just completeWord)
   --Readline.parseAndBind "set show-all-if-ambiguous 1"

   let symbols = "!#$%&*+/<=>?@\\^|-~"
       specials = "(),;[]`{}"
       spaces = " \t\n"
       word_break_chars = spaces ++ specials ++ symbols

   Readline.setBasicWordBreakCharacters word_break_chars
   Readline.setCompleterWordBreakCharacters word_break_chars
256
257
#endif

Simon Marlow's avatar
Simon Marlow committed
258
259
   default_editor <- findEditor

260
   startGHCi (runGHCi srcs maybe_expr)
261
262
	GHCiState{ progname = "<interactive>",
		   args = [],
Simon Marlow's avatar
Simon Marlow committed
263
                   prompt = "%s> ",
Simon Marlow's avatar
Simon Marlow committed
264
		   editor = default_editor,
265
		   session = session,
Simon Marlow's avatar
Simon Marlow committed
266
		   options = [],
mnislaih's avatar
mnislaih committed
267
                   prelude = prel_mod,
268
                   resume = [],
269
270
                   breaks = emptyActiveBreakPoints,
                   tickarrays = emptyModuleEnv
mnislaih's avatar
mnislaih committed
271
                 }
rrt's avatar
rrt committed
272

273
#ifdef USE_READLINE
rrt's avatar
rrt committed
274
275
276
   Readline.resetTerminal Nothing
#endif

277
278
   return ()

Simon Marlow's avatar
Simon Marlow committed
279
280
prel_name = GHC.mkModuleName "Prelude"

281
runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
282
runGHCi paths maybe_expr = do
283
  let read_dot_files = not opt_IgnoreDotGhci
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312

  when (read_dot_files) $ do
    -- Read in ./.ghci.
    let file = "./.ghci"
    exists <- io (doesFileExist file)
    when exists $ do
       dir_ok  <- io (checkPerms ".")
       file_ok <- io (checkPerms file)
       when (dir_ok && file_ok) $ do
  	  either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
  	  case either_hdl of
  	     Left e    -> return ()
  	     Right hdl -> fileLoop hdl False
    
  when (read_dot_files) $ do
    -- Read in $HOME/.ghci
    either_dir <- io (IO.try (getEnv "HOME"))
    case either_dir of
       Left e -> return ()
       Right dir -> do
  	  cwd <- io (getCurrentDirectory)
  	  when (dir /= cwd) $ do
  	     let file = dir ++ "/.ghci"
  	     ok <- io (checkPerms file)
  	     when ok $ do
  	       either_hdl <- io (IO.try (openFile file ReadMode))
  	       case either_hdl of
  		  Left e    -> return ()
  		  Right hdl -> fileLoop hdl False
313

314
  -- Perform a :load for files given on the GHCi command line
315
316
317
318
319
320
321
  -- When in -e mode, if the load fails then we want to stop
  -- immediately rather than going on to evaluate the expression.
  when (not (null paths)) $ do
     ok <- ghciHandle (\e -> do showException e; return Failed) $ 
		loadModule paths
     when (isJust maybe_expr && failed ok) $
	io (exitWith (ExitFailure 1))
322

323
324
  -- if verbosity is greater than 0, or we are connected to a
  -- terminal, display the prompt in the interactive loop.
325
  is_tty <- io (hIsTerminalDevice stdin)
326
  dflags <- getDynFlags
327
328
  let show_prompt = verbosity dflags > 0 || is_tty

329
330
  case maybe_expr of
	Nothing -> 
sof's avatar
sof committed
331
          do
Simon Marlow's avatar
Simon Marlow committed
332
#if defined(mingw32_HOST_OS)
sof's avatar
sof committed
333
334
335
336
337
338
339
340
341
342
            -- The win32 Console API mutates the first character of 
            -- type-ahead when reading from it in a non-buffered manner. Work
            -- around this by flushing the input buffer of type-ahead characters,
            -- but only if stdin is available.
            flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
            case flushed of 
   	     Left err | isDoesNotExistError err -> return ()
   		      | otherwise -> io (ioError err)
   	     Right () -> return ()
#endif
343
344
345
	    -- initialise the console if necessary
	    io setUpConsole

346
347
348
349
	    -- enter the interactive loop
	    interactiveLoop is_tty show_prompt
	Just expr -> do
	    -- just evaluate the expression we were given
350
	    runCommandEval expr
351
	    return ()
352
353

  -- and finally, exit
354
  io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
355
356


357
interactiveLoop is_tty show_prompt =
358
  -- Ignore ^C exceptions caught here
359
  ghciHandleDyn (\e -> case e of 
360
			Interrupted -> do
sof's avatar
sof committed
361
#if defined(mingw32_HOST_OS)
362
				io (putStrLn "")
sof's avatar
sof committed
363
#endif
364
365
366
367
368
				interactiveLoop is_tty show_prompt
			_other      -> return ()) $ 

  ghciUnblock $ do -- unblock necessary if we recursed from the 
		   -- exception handler above.
369

370
  -- read commands from stdin
371
#ifdef USE_READLINE
372
  if (is_tty) 
373
	then readlineLoop
374
	else fileLoop stdin show_prompt
375
#else
376
  fileLoop stdin show_prompt
377
#endif
378
379


380
-- NOTE: We only read .ghci files if they are owned by the current user,
381
382
383
-- and aren't world writable.  Otherwise, we could be accidentally 
-- running code planted by a malicious third party.

rrt's avatar
rrt committed
384
385
386
387
-- Furthermore, We only read ./.ghci if . is owned by the current user
-- and isn't writable by anyone else.  I think this is sufficient: we
-- don't need to check .. and ../.. etc. because "."  always refers to
-- the same directory while a process is running.
388
389
390

checkPerms :: String -> IO Bool
checkPerms name =
391
#ifdef mingw32_HOST_OS
392
  return True
sof's avatar
sof committed
393
#else
394
  Util.handle (\_ -> return False) $ do
395
396
397
398
399
400
401
402
403
404
405
406
407
408
     st <- getFileStatus name
     me <- getRealUserID
     if fileOwner st /= me then do
   	putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
   	return False
      else do
   	let mode =  fileMode st
   	if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
   	   || (otherWriteMode == (mode `intersectFileModes` otherWriteMode)) 
   	   then do
   	       putStrLn $ "*** WARNING: " ++ name ++ 
   			  " is writable by someone else, IGNORING!"
   	       return False
   	  else return True
sof's avatar
sof committed
409
#endif
410

411
fileLoop :: Handle -> Bool -> GHCi ()
Simon Marlow's avatar
Simon Marlow committed
412
fileLoop hdl show_prompt = do
413
414
   session <- getSession
   (mod,imports) <- io (GHC.getContext session)
Simon Marlow's avatar
Simon Marlow committed
415
416
   st <- getGHCiState
   when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
417
418
   l <- io (IO.try (hGetLine hdl))
   case l of
419
420
421
422
423
424
425
426
	Left e | isEOFError e		   -> return ()
	       | InvalidArgument <- etype  -> return ()
	       | otherwise		   -> io (ioError e)
		where etype = ioeGetErrorType e
		-- treat InvalidArgument in the same way as EOF:
		-- this can happen if the user closed stdin, or
		-- perhaps did getContents which closes stdin at
		-- EOF.
427
	Right l -> 
428
	  case removeSpaces l of
Simon Marlow's avatar
Simon Marlow committed
429
            "" -> fileLoop hdl show_prompt
430
	    l  -> do quit <- runCommand l
Simon Marlow's avatar
Simon Marlow committed
431
                     if quit then return () else fileLoop hdl show_prompt
432

433
434
stringLoop :: [String] -> GHCi Bool{-True: we quit-}
stringLoop [] = return False
435
stringLoop (s:ss) = do
436
   case removeSpaces s of
437
438
	"" -> stringLoop ss
	l  -> do quit <- runCommand l
439
                 if quit then return True else stringLoop ss
440

Simon Marlow's avatar
Simon Marlow committed
441
442
443
444
445
446
447
448
mkPrompt toplevs exports prompt
  = showSDoc $ f prompt
    where
        f ('%':'s':xs) = perc_s <> f xs
        f ('%':'%':xs) = char '%' <> f xs
        f (x:xs) = char x <> f xs
        f [] = empty
    
449
450
        perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
                 hsep (map (ppr . GHC.moduleName) exports)
451

452

453
#ifdef USE_READLINE
454
455
readlineLoop :: GHCi ()
readlineLoop = do
456
457
   session <- getSession
   (mod,imports) <- io (GHC.getContext session)
458
   io yield
Simon Marlow's avatar
Simon Marlow committed
459
   saveSession -- for use by completion
Simon Marlow's avatar
Simon Marlow committed
460
461
   st <- getGHCiState
   l <- io (readline (mkPrompt mod imports (prompt st))
462
463
464
	  	`finally` setNonBlockingFD 0)
		-- readline sometimes puts stdin into blocking mode,
		-- so we need to put it back for the IO library
Simon Marlow's avatar
Simon Marlow committed
465
   splatSavedSession
466
467
468
   case l of
	Nothing -> return ()
	Just l  ->
469
	  case removeSpaces l of
470
471
472
473
474
475
	    "" -> readlineLoop
	    l  -> do
        	  io (addHistory l)
  	  	  quit <- runCommand l
          	  if quit then return () else readlineLoop
#endif
476

477
runCommand :: String -> GHCi Bool
478
runCommand c = ghciHandle handler (doCommand c)
479
480
481
482
483
  where 
    doCommand (':' : command) = specialCommand command
    doCommand stmt
       = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
            return False
484

485
486
487
488
489
490
-- This version is for the GHC command-line option -e.  The only difference
-- from runCommand is that it catches the ExitException exception and
-- exits, rather than printing out the exception.
runCommandEval c = ghciHandle handleEval (doCommand c)
  where 
    handleEval (ExitException code) = io (exitWith code)
491
    handleEval e                    = do handler e
492
493
				         io (exitWith (ExitFailure 1))

494
495
496
497
498
499
500
501
    doCommand (':' : command) = specialCommand command
    doCommand stmt
       = do nms <- runStmt stmt
	    case nms of 
		Nothing -> io (exitWith (ExitFailure 1))
		  -- failure to run the command causes exit(1) for ghc -e.
		_       -> finishEvalExpr nms

502
runStmt :: String -> GHCi (Maybe (Bool,[Name]))
503
runStmt stmt
504
 | null (filter (not.isSpace) stmt) = return (Just (False,[]))
505
 | otherwise
506
 = do st <- getGHCiState
507
508
509
      session <- getSession
      result <- io $ withProgName (progname st) $ withArgs (args st) $
	     	     GHC.runStmt session stmt
510
511
      switchOnRunResult result

512
switchOnRunResult :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
513
514
switchOnRunResult GHC.RunFailed = return Nothing
switchOnRunResult (GHC.RunException e) = throw e
515
516
switchOnRunResult (GHC.RunOk names) = return $ Just (False,names)
switchOnRunResult (GHC.RunBreak threadId names info resume) = do
517
518
519
   session <- getSession
   Just mod_info <- io $ GHC.getModuleInfo session (breakInfo_module info) 
   let modBreaks  = GHC.modInfoModBreaks mod_info
520
521
522
   let ticks      = GHC.modBreaks_locs modBreaks

   -- display information about the breakpoint
523
   let location = ticks ! breakInfo_number info
524
   printForUser $ ptext SLIT("Stopped at") <+> ppr location
525

526
527
   pushResume location threadId resume
   return (Just (True,names))
528
529

-- possibly print the type and revert CAFs after evaluating an expression
530
finishEvalExpr mb_names
531
 = do show_types <- isOptionSet ShowType
532
      session <- getSession
533
534
      case mb_names of
	Nothing    -> return ()      
535
536
537
	Just (is_break,names) -> 
                when (is_break || show_types) $
                      mapM_ (showTypeOfName session) names
538

539
      flushInterpBuffers
540
      io installSignalHandlers
541
542
543
      b <- isOptionSet RevertCAFs
      io (when b revertCAFs)
      return True
544

545
546
547
548
549
550
551
showTypeOfName :: Session -> Name -> GHCi ()
showTypeOfName session n
   = do maybe_tything <- io (GHC.lookupName session n)
	case maybe_tything of
	  Nothing    -> return ()
	  Just thing -> showTyThing thing

552
specialCommand :: String -> GHCi Bool
553
specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
554
555
specialCommand str = do
  let (cmd,rest) = break isSpace str
Simon Marlow's avatar
Simon Marlow committed
556
557
558
  maybe_cmd <- io (lookupCommand cmd)
  case maybe_cmd of
    Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n" 
559
		                    ++ shortHelpText) >> return False)
560
    Just (_,f,_,_) -> f (dropWhile isSpace rest)
Simon Marlow's avatar
Simon Marlow committed
561
562
563
564
565
566
567

lookupCommand :: String -> IO (Maybe Command)
lookupCommand str = do
  cmds <- readIORef commands
  -- look for exact match first, then the first prefix match
  case [ c | c <- cmds, str == cmdName c ] of
     c:_ -> return (Just c)
568
     [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
Simon Marlow's avatar
Simon Marlow committed
569
570
     		[] -> return Nothing
     		c:_ -> return (Just c)
571
572
573
574
575
576
577

-----------------------------------------------------------------------------
-- Commands

help :: String -> GHCi ()
help _ = io (putStr helpText)

rrt's avatar
rrt committed
578
info :: String -> GHCi ()
579
info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
580
info s  = do { let names = words s
581
	     ; session <- getSession
582
583
	     ; dflags <- getDynFlags
	     ; let exts = dopt Opt_GlasgowExts dflags
584
	     ; mapM_ (infoThing exts session) names }
585
  where
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
    infoThing exts session str = io $ do
	names <- GHC.parseName session str
	let filtered = filterOutChildren names
	mb_stuffs <- mapM (GHC.getInfo session) filtered
	unqual <- GHC.getPrintUnqual session
	putStrLn (showSDocForUser unqual $
     		   vcat (intersperse (text "") $
		   [ pprInfo exts stuff | Just stuff <-  mb_stuffs ]))

  -- Filter out names whose parent is also there Good
  -- example is '[]', which is both a type and data
  -- constructor in the same type
filterOutChildren :: [Name] -> [Name]
filterOutChildren names = filter (not . parent_is_there) names
 where parent_is_there n 
601
602
--	 | Just p <- GHC.nameParent_maybe n = p `elem` names
-- ToDo!!
603
604
605
	 | otherwise		           = False

pprInfo exts (thing, fixity, insts)
606
  =  pprTyThingInContextLoc exts thing 
607
608
  $$ show_fixity fixity
  $$ vcat (map GHC.pprInstance insts)
609
  where
610
    show_fixity fix 
611
612
	| fix == GHC.defaultFixity = empty
	| otherwise		   = ppr fix <+> ppr (GHC.getName thing)
613
614
615

-----------------------------------------------------------------------------
-- Commands
616

617
618
619
620
621
622
runMain :: String -> GHCi ()
runMain args = do
  let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
  runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
  return ()

sof's avatar
sof committed
623
624
addModule :: [FilePath] -> GHCi ()
addModule files = do
625
  io (revertCAFs)			-- always revert CAFs on load/add.
626
  files <- mapM expandPath files
627
  targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
628
629
  session <- getSession
  io (mapM_ (GHC.addTarget session) targets)
630
  ok <- io (GHC.load session LoadAllTargets)
631
  afterLoad ok session
632

633
changeDirectory :: String -> GHCi ()
634
changeDirectory dir = do
635
636
637
  session <- getSession
  graph <- io (GHC.getModuleGraph session)
  when (not (null graph)) $
638
	io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
639
  io (GHC.setTargets session [])
640
  io (GHC.load session LoadAllTargets)
641
  setContextAfterLoad session []
642
  io (GHC.workingDirectoryChanged session)
643
644
  dir <- expandPath dir
  io (setCurrentDirectory dir)
645

Simon Marlow's avatar
Simon Marlow committed
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
editFile :: String -> GHCi ()
editFile str
  | null str  = do
	-- find the name of the "topmost" file loaded
     session <- getSession
     graph0 <- io (GHC.getModuleGraph session)
     graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
     let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
     case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
	Just file -> do_edit file
	Nothing   -> throwDyn (CmdLineError "unknown file name")
  | otherwise = do_edit str
  where
	do_edit file = do
	   st <- getGHCiState
	   let cmd = editor st
	   when (null cmd) $ 
		throwDyn (CmdLineError "editor not set, use :set editor")
	   io $ system (cmd ++ ' ':file)
           return ()

667
668
669
670
671
defineMacro :: String -> GHCi ()
defineMacro s = do
  let (macro_name, definition) = break isSpace s
  cmds <- io (readIORef commands)
  if (null macro_name) 
672
	then throwDyn (CmdLineError "invalid macro name") 
673
	else do
Simon Marlow's avatar
Simon Marlow committed
674
  if (macro_name `elem` map cmdName cmds)
675
	then throwDyn (CmdLineError 
676
		("command '" ++ macro_name ++ "' is already defined"))
677
678
679
680
681
682
683
	else do

  -- give the expression a type signature, so we can be sure we're getting
  -- something of the right type.
  let new_expr = '(' : definition ++ ") :: String -> IO String"

  -- compile the expression
684
685
  cms <- getSession
  maybe_hv <- io (GHC.compileExpr cms new_expr)
686
  case maybe_hv of
687
688
     Nothing -> return ()
     Just hv -> io (writeIORef commands --
689
		    (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
690

691
runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
692
693
694
695
696
697
698
runMacro fun s = do
  str <- io ((unsafeCoerce# fun :: String -> IO String) s)
  stringLoop (lines str)

undefineMacro :: String -> GHCi ()
undefineMacro macro_name = do
  cmds <- io (readIORef commands)
Simon Marlow's avatar
Simon Marlow committed
699
  if (macro_name `elem` map cmdName builtin_commands) 
700
	then throwDyn (CmdLineError
701
		("command '" ++ macro_name ++ "' cannot be undefined"))
702
	else do
Simon Marlow's avatar
Simon Marlow committed
703
  if (macro_name `notElem` map cmdName cmds) 
704
	then throwDyn (CmdLineError 
705
		("command '" ++ macro_name ++ "' not defined"))
706
	else do
Simon Marlow's avatar
Simon Marlow committed
707
  io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
708

709

710
loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
sof's avatar
sof committed
711
loadModule fs = timeIt (loadModule' fs)
712

713
loadModule_ :: [FilePath] -> GHCi ()
714
loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
715

716
loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
sof's avatar
sof committed
717
loadModule' files = do
718
719
720
721
  session <- getSession

  -- unload first
  io (GHC.setTargets session [])
722
  io (GHC.load session LoadAllTargets)
723

724
  -- expand tildes
725
726
727
728
  let (filenames, phases) = unzip files
  exp_filenames <- mapM expandPath filenames
  let files' = zip exp_filenames phases
  targets <- io (mapM (uncurry GHC.guessTarget) files')
729

730
731
732
733
  -- NOTE: we used to do the dependency anal first, so that if it
  -- fails we didn't throw away the current set of modules.  This would
  -- require some re-working of the GHC interface, so we'll leave it
  -- as a ToDo for now.
734

735
  io (GHC.setTargets session targets)
736
  ok <- io (GHC.load session LoadAllTargets)
737
  afterLoad ok session
738
  return ok
739

740
741
checkModule :: String -> GHCi ()
checkModule m = do
Simon Marlow's avatar
Simon Marlow committed
742
  let modl = GHC.mkModuleName m
743
  session <- getSession
744
  result <- io (GHC.checkModule session modl)
745
746
747
  case result of
    Nothing -> io $ putStrLn "Nothing"
    Just r  -> io $ putStrLn (showSDoc (
748
	case GHC.checkedModuleInfo r of
749
750
	   Just cm | Just scope <- GHC.modInfoTopLevelScope cm -> 
		let
Simon Marlow's avatar
Simon Marlow committed
751
		    (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
752
753
		in
			(text "global names: " <+> ppr global) $$
754
755
		        (text "local  names: " <+> ppr local)
	   _ -> empty))
756
  afterLoad (successIf (isJust result)) session
757

758
759
reloadModule :: String -> GHCi ()
reloadModule "" = do
760
761
  io (revertCAFs)		-- always revert CAFs on reload.
  session <- getSession
762
  ok <- io (GHC.load session LoadAllTargets)
763
  afterLoad ok session
764
765
766
reloadModule m = do
  io (revertCAFs)		-- always revert CAFs on reload.
  session <- getSession
Simon Marlow's avatar
Simon Marlow committed
767
  ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
768
  afterLoad ok session
769

770
771
afterLoad ok session = do
  io (revertCAFs)  -- always revert CAFs on load.
772
773
774
  discardResumeContext
  discardTickArrays
  discardActiveBreakPoints
775
  graph <- io (GHC.getModuleGraph session)
Simon Marlow's avatar
Simon Marlow committed
776
  graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
777
  setContextAfterLoad session graph'
Simon Marlow's avatar
Simon Marlow committed
778
  modulesLoadedMsg ok (map GHC.ms_mod_name graph')
779

780
setContextAfterLoad session [] = do
Simon Marlow's avatar
Simon Marlow committed
781
782
  prel_mod <- getPrelude
  io (GHC.setContext session [] [prel_mod])
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
setContextAfterLoad session ms = do
  -- load a target if one is available, otherwise load the topmost module.
  targets <- io (GHC.getTargets session)
  case [ m | Just m <- map (findTarget ms) targets ] of
	[]    -> 
	  let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
	  load_this (last graph')	  
	(m:_) -> 
	  load_this m
 where
   findTarget ms t
    = case filter (`matches` t) ms of
	[]    -> Nothing
	(m:_) -> Just m

   summary `matches` Target (TargetModule m) _
Simon Marlow's avatar
Simon Marlow committed
799
	= GHC.ms_mod_name summary == m
800
801
802
803
804
805
806
807
   summary `matches` Target (TargetFile f _) _ 
	| Just f' <- GHC.ml_hs_file (GHC.ms_location summary)	= f == f'
   summary `matches` target
	= False

   load_this summary | m <- GHC.ms_mod summary = do
	b <- io (GHC.moduleIsInterpreted session m)
	if b then io (GHC.setContext session [m] []) 
Simon Marlow's avatar
Simon Marlow committed
808
809
810
       	     else do
                   prel_mod <- getPrelude
                   io (GHC.setContext session []  [prel_mod,m])
811

812

Simon Marlow's avatar
Simon Marlow committed
813
modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
814
815
modulesLoadedMsg ok mods = do
  dflags <- getDynFlags
816
817
  when (verbosity dflags > 0) $ do
   let mod_commas 
818
819
	| null mods = text "none."
	| otherwise = hsep (
Simon Marlow's avatar
Simon Marlow committed
820
	    punctuate comma (map ppr mods)) <> text "."
821
   case ok of
822
    Failed ->
823
       io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
824
    Succeeded  ->
825
826
827
       io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))


828
typeOfExpr :: String -> GHCi ()
829
typeOfExpr str 
830
831
832
833
834
  = do cms <- getSession
       maybe_ty <- io (GHC.exprType cms str)
       case maybe_ty of
	  Nothing -> return ()
	  Just ty -> do ty' <- cleanType ty
835
                        printForUser $ text str <> text " :: " <> ppr ty'
836
837
838

kindOfType :: String -> GHCi ()
kindOfType str 
839
840
841
  = do cms <- getSession
       maybe_ty <- io (GHC.typeKind cms str)
       case maybe_ty of
842
	  Nothing    -> return ()
843
	  Just ty    -> printForUser $ text str <> text " :: " <> ppr ty
844
          
845
846
quit :: String -> GHCi Bool
quit _ = return True
847

848
849
shellEscape :: String -> GHCi Bool
shellEscape str = io (system str >> return False)
850

851
852
853
-----------------------------------------------------------------------------
-- create tags file for currently loaded modules.

854
855
856
857
858
859
860
createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()

createCTagsFileCmd ""   = ghciCreateTagsFile CTags "tags"
createCTagsFileCmd file = ghciCreateTagsFile CTags file

createETagsFileCmd ""    = ghciCreateTagsFile ETags "TAGS"
createETagsFileCmd file  = ghciCreateTagsFile ETags file
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884

data TagsKind = ETags | CTags

ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
ghciCreateTagsFile kind file = do
  session <- getSession
  io $ createTagsFile session kind file

-- ToDo: 
-- 	- remove restriction that all modules must be interpreted
--	  (problem: we don't know source locations for entities unless
--	  we compiled the module.
--
--	- extract createTagsFile so it can be used from the command-line
--	  (probably need to fix first problem before this is useful).
--
createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
createTagsFile session tagskind tagFile = do
  graph <- GHC.getModuleGraph session
  let ms = map GHC.ms_mod graph
      tagModule m = do 
        is_interpreted <- GHC.moduleIsInterpreted session m
        -- should we just skip these?
        when (not is_interpreted) $
Simon Marlow's avatar
Simon Marlow committed
885
886
887
          throwDyn (CmdLineError ("module '" 
                                ++ GHC.moduleNameString (GHC.moduleName m)
                                ++ "' is not interpreted"))
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
        mbModInfo <- GHC.getModuleInfo session m
        let unqual 
	      | Just modinfo <- mbModInfo,
		Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
	      | otherwise = GHC.alwaysQualify

        case mbModInfo of 
          Just modInfo -> return $! listTags unqual modInfo 
          _            -> return []

  mtags <- mapM tagModule ms
  either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
  case either_res of
    Left e  -> hPutStrLn stderr $ ioeGetErrorString e
    Right _ -> return ()

listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
listTags unqual modInfo =
	   [ tagInfo unqual name loc 
           | name <- GHC.modInfoExports modInfo
           , let loc = nameSrcLoc name
           , isGoodSrcLoc loc
           ]

type TagInfo = (String -- tag name
               ,String -- file name
               ,Int    -- line number
               ,Int    -- column number
               )

-- get tag info, for later translation into Vim or Emacs style
tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
tagInfo unqual name loc
    = ( showSDocForUser unqual $ pprOccName (nameOccName name)
      , showSDocForUser unqual $ ftext (srcLocFile loc)
      , srcLocLine loc
      , srcLocCol loc
      )

collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
  let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
  IO.try (writeFile file tags)
collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
  let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
      groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
  tagGroups <- mapM tagFileGroup groups 
  IO.try (writeFile file $ concat tagGroups)
  where
    tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
    tagFileGroup group@((_,fileName,_,_):_) = do
      file <- readFile fileName -- need to get additional info from sources..
      let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
          sortedGroup = sortLe byLine group
          tags = unlines $ perFile sortedGroup 1 0 $ lines file
      return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
    perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
      perFile (tagInfo:tags) (count+1) (pos+length line) lines
    perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
      showETag tagInfo line pos : perFile tags count pos lines
    perFile tags count pos lines = []

-- simple ctags format, for Vim et al
showTag :: TagInfo -> String
showTag (tag,file,lineNo,colNo)
    =  tag ++ "\t" ++ file ++ "\t" ++ show lineNo

-- etags format, for Emacs/XEmacs
showETag :: TagInfo -> String -> Int -> String
showETag (tag,file,lineNo,colNo) line charPos
    =  take colNo line ++ tag
    ++ "\x7f" ++ tag
    ++ "\x01" ++ show lineNo
    ++ "," ++ show charPos

963
-----------------------------------------------------------------------------
dons's avatar
dons committed
964
-- Browsing a module's contents
965
966
967
968

browseCmd :: String -> GHCi ()
browseCmd m = 
  case words m of
969
970
    ['*':m] | looksLikeModuleName m -> browseModule m False
    [m]     | looksLikeModuleName m -> browseModule m True
971
972
973
    _ -> throwDyn (CmdLineError "syntax:  :browse <module>")

browseModule m exports_only = do
974
  s <- getSession
975
976
  modl <- if exports_only then lookupModule s m
                          else wantInterpretedModule s m
977

978
  -- Temporarily set the context to the module we're interested in,
979
  -- ju