InteractiveUI.hs 56.4 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
-- these are needed by the new ghci debugger
import ByteCodeLink (HValue)
import ByteCodeInstr (BreakInfo (..))
import BreakArray

93
94
-----------------------------------------------------------------------------

95
96
97
98
99
100
ghciWelcomeMsg =
 "   ___         ___ _\n"++
 "  / _ \\ /\\  /\\/ __(_)\n"++
 " / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
 "/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n"++
 "\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
101

102
103
type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
cmdName (n,_,_,_) = n
104

Simon Marlow's avatar
Simon Marlow committed
105
106
107
GLOBAL_VAR(commands, builtin_commands, [Command])

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

142
143
144
keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
keepGoing a str = a str >> return False

sof's avatar
sof committed
145
146
147
keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
keepGoingPaths a str = a (toArgs str) >> return False

148
149
shortHelpText = "use :? for help.\n"

150
-- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
151
152
153
154
155
156
157
158
helpText =
 " Commands available from the prompt:\n" ++
 "\n" ++
 "   <stmt>                      evaluate/run <stmt>\n" ++
 "   :add <filename> ...         add module(s) to the current target set\n" ++
 "   :browse [*]<module>         display the names defined by <module>\n" ++
 "   :cd <dir>                   change directory to <dir>\n" ++
 "   :def <cmd> <expr>           define a command :<cmd>\n" ++
Simon Marlow's avatar
Simon Marlow committed
159
160
 "   :edit <file>                edit file\n" ++
 "   :edit                       edit last module\n" ++
161
162
 "   :help, :?                   display this list of commands\n" ++
 "   :info [<name> ...]          display information about the given names\n" ++
mnislaih's avatar
mnislaih committed
163
 "   :print [<name> ...]         prints a value without forcing its computation\n" ++
164
 "   :sprint [<name> ...]        simplified version of :print\n" ++
165
166
 "   :load <filename> ...        load module(s) and their dependents\n" ++
 "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
167
 "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
168
169
170
171
172
 "   :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
173
 "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
Ian Lynagh's avatar
Ian Lynagh committed
174
 "   :set editor <cmd>           set the command used for :edit\n" ++
175
176
177
178
 "\n" ++
 "   :show modules               show the currently loaded modules\n" ++
 "   :show bindings              show the current bindings made at the prompt\n" ++
 "\n" ++
179
 "   :ctags [<file>]             create tags file for Vi (default: \"tags\")\n" ++
180
 "   :etags [<file>]             create tags file for Emacs (default: \"TAGS\")\n" ++
181
182
183
184
185
186
187
188
189
190
191
192
193
 "   :type <expr>                show the type of <expr>\n" ++
 "   :kind <type>                show the kind of <type>\n" ++
 "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
 "   :unset <option> ...         unset options\n" ++
 "   :quit                       exit GHCi\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
194
 "                         (eg. -v2, -fglasgow-exts, etc.)\n" ++
195
196
 "\n" 
-- Todo: add help for breakpoint commands here
197

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

208
interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
209
interactiveUI session srcs maybe_expr = do
210
211
212
213
214
215
216
217
218
219
220
221
   -- 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

222
	-- Initialise buffering for the *interpreted* I/O system
223
   initInterpBuffering session
224

225
226
227
228
229
230
231
   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
232
233
	-- We don't want the cmd line to buffer any input that might be
	-- intended for the program, so unbuffer stdin.
234
	hSetBuffering stdin NoBuffering
235

236
	-- initial context is just the Prelude
237
   prel_mod <- GHC.findModule session prel_name (Just basePackageId)
Simon Marlow's avatar
Simon Marlow committed
238
   GHC.setContext session [] [prel_mod]
239

240
#ifdef USE_READLINE
241
   Readline.initialize
Simon Marlow's avatar
Simon Marlow committed
242
243
244
245
246
247
248
249
250
251
   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
252
253
#endif

Simon Marlow's avatar
Simon Marlow committed
254
255
   default_editor <- findEditor

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

269
#ifdef USE_READLINE
rrt's avatar
rrt committed
270
271
272
   Readline.resetTerminal Nothing
#endif

273
274
   return ()

Simon Marlow's avatar
Simon Marlow committed
275
276
prel_name = GHC.mkModuleName "Prelude"

277
runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
278
runGHCi paths maybe_expr = do
279
  let read_dot_files = not opt_IgnoreDotGhci
280
281
282
283
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

  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
309

310
  -- Perform a :load for files given on the GHCi command line
311
312
313
314
315
316
317
  -- 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))
318

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

325
326
  case maybe_expr of
	Nothing -> 
sof's avatar
sof committed
327
          do
Simon Marlow's avatar
Simon Marlow committed
328
#if defined(mingw32_HOST_OS)
sof's avatar
sof committed
329
330
331
332
333
334
335
336
337
338
            -- 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
339
340
341
	    -- initialise the console if necessary
	    io setUpConsole

342
343
344
345
	    -- enter the interactive loop
	    interactiveLoop is_tty show_prompt
	Just expr -> do
	    -- just evaluate the expression we were given
346
	    runCommandEval expr
347
	    return ()
348
349

  -- and finally, exit
350
  io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
351
352


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

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

366
  -- read commands from stdin
367
#ifdef USE_READLINE
368
  if (is_tty) 
369
	then readlineLoop
370
	else fileLoop stdin show_prompt
371
#else
372
  fileLoop stdin show_prompt
373
#endif
374
375


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

rrt's avatar
rrt committed
380
381
382
383
-- 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.
384
385
386

checkPerms :: String -> IO Bool
checkPerms name =
387
#ifdef mingw32_HOST_OS
388
  return True
sof's avatar
sof committed
389
#else
390
  Util.handle (\_ -> return False) $ do
391
392
393
394
395
396
397
398
399
400
401
402
403
404
     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
405
#endif
406

407
fileLoop :: Handle -> Bool -> GHCi ()
Simon Marlow's avatar
Simon Marlow committed
408
fileLoop hdl show_prompt = do
409
410
   session <- getSession
   (mod,imports) <- io (GHC.getContext session)
Simon Marlow's avatar
Simon Marlow committed
411
412
   st <- getGHCiState
   when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
413
414
   l <- io (IO.try (hGetLine hdl))
   case l of
415
416
417
418
419
420
421
422
	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.
423
	Right l -> 
424
	  case removeSpaces l of
Simon Marlow's avatar
Simon Marlow committed
425
            "" -> fileLoop hdl show_prompt
426
	    l  -> do quit <- runCommand l
Simon Marlow's avatar
Simon Marlow committed
427
                     if quit then return () else fileLoop hdl show_prompt
428

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

Simon Marlow's avatar
Simon Marlow committed
437
438
439
440
441
442
443
444
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
    
445
446
        perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
                 hsep (map (ppr . GHC.moduleName) exports)
447

448

449
#ifdef USE_READLINE
450
451
readlineLoop :: GHCi ()
readlineLoop = do
452
453
   session <- getSession
   (mod,imports) <- io (GHC.getContext session)
454
   io yield
Simon Marlow's avatar
Simon Marlow committed
455
   saveSession -- for use by completion
Simon Marlow's avatar
Simon Marlow committed
456
457
   st <- getGHCiState
   l <- io (readline (mkPrompt mod imports (prompt st))
458
459
460
	  	`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
461
   splatSavedSession
462
463
464
   case l of
	Nothing -> return ()
	Just l  ->
465
	  case removeSpaces l of
466
467
468
469
470
471
	    "" -> readlineLoop
	    l  -> do
        	  io (addHistory l)
  	  	  quit <- runCommand l
          	  if quit then return () else readlineLoop
#endif
472

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

481
482
483
484
485
486
-- 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)
487
    handleEval e                    = do handler e
488
489
				         io (exitWith (ExitFailure 1))

490
491
492
493
494
495
496
497
    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

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

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

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

522
523
   pushResume location threadId resume
   return (Just (True,names))
524
525

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

535
      flushInterpBuffers
536
      io installSignalHandlers
537
538
539
      b <- isOptionSet RevertCAFs
      io (when b revertCAFs)
      return True
540

541
542
543
544
545
546
547
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

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

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)
564
     [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
Simon Marlow's avatar
Simon Marlow committed
565
566
     		[] -> return Nothing
     		c:_ -> return (Just c)
567
568
569
570
571
572
573

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

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

rrt's avatar
rrt committed
574
info :: String -> GHCi ()
575
info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
576
info s  = do { let names = words s
577
	     ; session <- getSession
578
579
	     ; dflags <- getDynFlags
	     ; let exts = dopt Opt_GlasgowExts dflags
580
	     ; mapM_ (infoThing exts session) names }
581
  where
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
    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 
597
598
--	 | Just p <- GHC.nameParent_maybe n = p `elem` names
-- ToDo!!
599
600
601
	 | otherwise		           = False

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

-----------------------------------------------------------------------------
-- Commands
612

613
614
615
616
617
618
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
619
620
addModule :: [FilePath] -> GHCi ()
addModule files = do
621
  io (revertCAFs)			-- always revert CAFs on load/add.
622
  files <- mapM expandPath files
623
  targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
624
625
  session <- getSession
  io (mapM_ (GHC.addTarget session) targets)
626
  ok <- io (GHC.load session LoadAllTargets)
627
  afterLoad ok session
628

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

Simon Marlow's avatar
Simon Marlow committed
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
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 ()

663
664
665
666
667
defineMacro :: String -> GHCi ()
defineMacro s = do
  let (macro_name, definition) = break isSpace s
  cmds <- io (readIORef commands)
  if (null macro_name) 
668
	then throwDyn (CmdLineError "invalid macro name") 
669
	else do
Simon Marlow's avatar
Simon Marlow committed
670
  if (macro_name `elem` map cmdName cmds)
671
	then throwDyn (CmdLineError 
672
		("command '" ++ macro_name ++ "' is already defined"))
673
674
675
676
677
678
679
	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
680
681
  cms <- getSession
  maybe_hv <- io (GHC.compileExpr cms new_expr)
682
  case maybe_hv of
683
684
     Nothing -> return ()
     Just hv -> io (writeIORef commands --
685
		    (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
686

687
runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
688
689
690
691
692
693
694
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
695
  if (macro_name `elem` map cmdName builtin_commands) 
696
	then throwDyn (CmdLineError
697
		("command '" ++ macro_name ++ "' cannot be undefined"))
698
	else do
Simon Marlow's avatar
Simon Marlow committed
699
  if (macro_name `notElem` map cmdName cmds) 
700
	then throwDyn (CmdLineError 
701
		("command '" ++ macro_name ++ "' not defined"))
702
	else do
Simon Marlow's avatar
Simon Marlow committed
703
  io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
704

705

706
loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
sof's avatar
sof committed
707
loadModule fs = timeIt (loadModule' fs)
708

709
loadModule_ :: [FilePath] -> GHCi ()
710
loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
711

712
loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
sof's avatar
sof committed
713
loadModule' files = do
714
715
716
717
  session <- getSession

  -- unload first
  io (GHC.setTargets session [])
718
  io (GHC.load session LoadAllTargets)
719

720
  -- expand tildes
721
722
723
724
  let (filenames, phases) = unzip files
  exp_filenames <- mapM expandPath filenames
  let files' = zip exp_filenames phases
  targets <- io (mapM (uncurry GHC.guessTarget) files')
725

726
727
728
729
  -- 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.
730

731
  io (GHC.setTargets session targets)
732
  ok <- io (GHC.load session LoadAllTargets)
733
  afterLoad ok session
734
  return ok
735

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

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

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

776
setContextAfterLoad session [] = do
Simon Marlow's avatar
Simon Marlow committed
777
778
  prel_mod <- getPrelude
  io (GHC.setContext session [] [prel_mod])
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
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
795
	= GHC.ms_mod_name summary == m
796
797
798
799
800
801
802
803
   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
804
805
806
       	     else do
                   prel_mod <- getPrelude
                   io (GHC.setContext session []  [prel_mod,m])
807

808

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


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

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

844
845
shellEscape :: String -> GHCi Bool
shellEscape str = io (system str >> return False)
846

847
848
849
-----------------------------------------------------------------------------
-- create tags file for currently loaded modules.

850
851
852
853
854
855
856
createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()

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

createETagsFileCmd ""    = ghciCreateTagsFile ETags "TAGS"
createETagsFileCmd file  = ghciCreateTagsFile ETags file
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880

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
881
882
883
          throwDyn (CmdLineError ("module '" 
                                ++ GHC.moduleNameString (GHC.moduleName m)
                                ++ "' is not interpreted"))
884
885
886
887
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
        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

959
-----------------------------------------------------------------------------
dons's avatar
dons committed
960
-- Browsing a module's contents
961
962
963
964

browseCmd :: String -> GHCi ()
browseCmd m = 
  case words m of
965
966
    ['*':m] | looksLikeModuleName m -> browseModule m False
    [m]     | looksLikeModuleName m -> browseModule m True
967
968
969
    _ -> throwDyn (CmdLineError "syntax:  :browse <module>")

browseModule m exports_only = do
970
  s <- getSession
971
972
  modl <- if exports_only then lookupModule s m
                          else wantInterpretedModule s m
973

974
  -- Temporarily set the context to the module we're interested in,
975
  -- just so we can get an appropriate PrintUnqualified
976
  (as,bs) <- io (GHC.getContext s)
Simon Marlow's avatar
Simon Marlow committed
977
978
  prel_mod <- getPrelude
  io (if exports_only then GHC.setContext s [] [prel_mod,modl]
979
		      else GHC.setContext s [modl] [])
980
  unqual <- io (GHC.getPrintUnqual s)
simonmar's avatar