InteractiveUI.hs 33.1 KB
Newer Older
1
{-# OPTIONS -#include "Linker.h" #-}
2
-----------------------------------------------------------------------------
3
-- $Id: InteractiveUI.hs,v 1.147 2003/02/20 13:12:40 simonpj Exp $
4
5
6
7
8
9
--
-- GHC Interactive User Interface
--
-- (c) The GHC Team 2000
--
-----------------------------------------------------------------------------
10
11
12
13
module InteractiveUI ( 
	interactiveUI,  -- :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
	ghciWelcomeMsg
   ) where
14

15
#include "../includes/config.h"
16
17
#include "HsVersions.h"

18
import CompManager
19
20
import HscTypes		( TyThing(..), HomeModInfo(hm_linkable), HomePackageTable,
			  isObjectLinkable )
21
import HsSyn		( TyClDecl(..), ConDecl(..), Sig(..) )
22
import MkIface		( ifaceTyThing )
23
import DriverFlags
24
import DriverState
25
import DriverUtil	( remove_spaces, handle )
26
27
import Linker		( initLinker, showLinkerState, linkLibraries, 
			  linkPackages )
28
import Util
29
import IdInfo		( GlobalIdDetails(..) )
30
import Id		( isImplicitId, idName, globalIdDetails )
31
import Class		( className )
32
import TyCon		( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) )
33
import DataCon		( dataConName )
34
import FieldLabel	( fieldLabelTyCon )
35
import SrcLoc		( isGoodSrcLoc )
36
import Module		( showModMsg, lookupModuleEnv )
37
38
39
import Name		( Name, isHomePackageName, nameSrcLoc, nameOccName,
			  NamedThing(..) )
import OccName		( isSymOcc )
40
import BasicTypes	( defaultFixity, SuccessFlag(..) )
41
import Packages
42
import Outputable
43
import CmdLineOpts	( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags,
44
			  restoreDynFlags, dopt_unset )
45
import Panic 		hiding ( showException )
46
import Config
47

sof's avatar
sof committed
48
#ifndef mingw32_TARGET_OS
49
import System.Posix
sof's avatar
sof committed
50
51
#endif

52
#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
53
import Control.Concurrent	( yield )	-- Used in readline loop
54
import System.Console.Readline as Readline
55
#endif
56
57
58
59
60
61

--import SystemExts

import Control.Exception as Exception
import Data.Dynamic
import Control.Concurrent
62

63
import Numeric
64
65
66
67
68
69
70
71
import Data.List
import System.Cmd
import System.CPUTime
import System.Environment
import System.Directory
import System.IO as IO
import Data.Char
import Control.Monad as Monad
72

73
import GHC.Exts		( unsafeCoerce# )
74

75
76
import Data.IORef	( IORef, newIORef, readIORef, writeIORef )

77
78
import GHC.Posix	( setNonBlockingFD )

79
80
81
-----------------------------------------------------------------------------

ghciWelcomeMsg = "\ 
82
\   ___         ___ _\n\ 
83
\  / _ \\ /\\  /\\/ __(_)\n\ 
84
\ / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\ 
85
\/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n\ 
86
\\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
87

88
89
90
91
GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])

builtin_commands :: [(String, String -> GHCi Bool)]
builtin_commands = [
sof's avatar
sof committed
92
  ("add",	keepGoingPaths addModule),
93
  ("browse",    keepGoing browseCmd),
94
  ("cd",    	keepGoing changeDirectory),
95
  ("def",	keepGoing defineMacro),
96
97
  ("help",	keepGoing help),
  ("?",		keepGoing help),
rrt's avatar
rrt committed
98
  ("info",      keepGoing info),
sof's avatar
sof committed
99
  ("load",	keepGoingPaths loadModule),
100
101
  ("module",	keepGoing setContext),
  ("reload",	keepGoing reloadModule),
102
  ("set",	keepGoing setCmd),
103
  ("show",	keepGoing showCmd),
104
105
  ("type",	keepGoing typeOfExpr),
  ("unset",	keepGoing unsetOptions),
106
  ("undef",     keepGoing undefineMacro),
107
  ("quit",	quit)
108
109
  ]

110
111
112
keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
keepGoing a str = a str >> return False

sof's avatar
sof committed
113
114
115
keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
keepGoingPaths a str = a (toArgs str) >> return False

116
117
shortHelpText = "use :? for help.\n"

118
-- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
119
helpText = "\ 
120
\ Commands available from the prompt:\n\ 
121
\\n\ 
122
123
124
125
126
127
128
129
130
131
\   <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\ 
\   :help, :?		       display this list of commands\n\ 
\   :info [<name> ...]         display information about the given names\n\ 
\   :load <filename> ...       load module(s) and their dependents\n\ 
\   :module [+/-] [*]<mod> ... set the context for expression evaluation\n\ 
\   :reload		       reload the current module set\n\ 
132
\\n\ 
133
134
135
136
137
138
139
140
141
142
143
144
\   :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\ 
\\n\ 
\   :show modules	       show the currently loaded modules\n\ 
\   :show bindings	       show the current bindings made at the prompt\n\ 
\\n\ 
\   :type <expr>	       show the type of <expr>\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\ 
145
\\n\ 
146
\ Options for `:set' and `:unset':\n\ 
147
\\n\ 
148
\    +r			revert top-level expressions after each evaluation\n\ 
149
150
151
152
\    +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\ 
\                         (eg. -v2, -fglasgow-exts, etc.)\n\ 
153
154
\"

155
156
interactiveUI :: CmState -> [FilePath] -> [FilePath] -> IO ()
interactiveUI cmstate paths cmdline_objs = do
157
158
   hFlush stdout
   hSetBuffering stdout NoBuffering
159

160
161
   dflags <- getDynFlags

162
   initLinker
163
164
165
166
167
168

	-- link packages requested explicitly on the command-line
   expl <- readIORef v_ExplicitPackages
   linkPackages dflags expl

	-- link libraries from the command-line
169
170
171
172
   linkLibraries dflags cmdline_objs

	-- Initialise buffering for the *interpreted* I/O system
   cmstate <- initInterpBuffering cmstate dflags
173

174
175
	-- We don't want the cmd line to buffer any input that might be
	-- intended for the program, so unbuffer stdin.
176
   hSetBuffering stdin NoBuffering
177

178
179
180
	-- initial context is just the Prelude
   cmstate <- cmSetContext cmstate dflags [] ["Prelude"]

181
182
183
184
#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
   Readline.initialize
#endif

185
   startGHCi (runGHCi paths dflags) 
186
187
188
189
190
	GHCiState{ progname = "<interactive>",
		   args = [],
		   targets = paths,
		   cmstate = cmstate,
		   options = [] }
rrt's avatar
rrt committed
191
192
193
194
195

#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
   Readline.resetTerminal Nothing
#endif

196
197
   return ()

198
199
runGHCi :: [FilePath] -> DynFlags -> GHCi ()
runGHCi paths dflags = do
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
  read_dot_files <- io (readIORef v_Read_DotGHCi)

  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
230

231
  -- perform a :load for files given on the GHCi command line
232
  when (not (null paths)) $
233
     ghciHandle showException $
sof's avatar
sof committed
234
	loadModule paths
235
236

  -- enter the interactive loop
sof's avatar
sof committed
237
238
239
240
241
#if defined(mingw32_TARGET_OS)
   -- always show prompt, since hIsTerminalDevice returns True for Consoles
   -- only, which we may or may not be running under (cf. Emacs sub-shells.)
  interactiveLoop True
#else
242
243
  is_tty <- io (hIsTerminalDevice stdin)
  interactiveLoop is_tty
sof's avatar
sof committed
244
#endif
245
246

  -- and finally, exit
247
  io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
248
249


250
interactiveLoop is_tty = do
251
  -- ignore ^C exceptions caught here
252
253
254
  ghciHandleDyn (\e -> case e of 
			Interrupted -> ghciUnblock (interactiveLoop is_tty)
			_other      -> return ()) $ do
255

256
  -- read commands from stdin
257
#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
258
259
260
  if (is_tty) 
	then readlineLoop
	else fileLoop stdin False  -- turn off prompt for non-TTY input
261
#else
262
  fileLoop stdin is_tty
263
#endif
264
265


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

rrt's avatar
rrt committed
270
271
272
273
-- 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.
274
275
276

checkPerms :: String -> IO Bool
checkPerms name =
sof's avatar
sof committed
277
#ifdef mingw32_TARGET_OS
278
  return True
sof's avatar
sof committed
279
#else
280
  DriverUtil.handle (\_ -> return False) $ do
281
282
283
284
285
286
287
288
289
290
291
292
293
294
     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
295
#endif
296

297
298
fileLoop :: Handle -> Bool -> GHCi ()
fileLoop hdl prompt = do
299
300
   cmstate <- getCmState
   (mod,imports) <- io (cmGetContext cmstate)
301
   when prompt (io (putStr (mkPrompt mod imports)))
302
303
304
   l <- io (IO.try (hGetLine hdl))
   case l of
	Left e | isEOFError e -> return ()
ross's avatar
ross committed
305
	       | otherwise    -> io (ioError e)
306
307
308
309
310
	Right l -> 
	  case remove_spaces l of
	    "" -> fileLoop hdl prompt
	    l  -> do quit <- runCommand l
          	     if quit then return () else fileLoop hdl prompt
311

312
313
314
315
316
317
318
319
stringLoop :: [String] -> GHCi ()
stringLoop [] = return ()
stringLoop (s:ss) = do
   case remove_spaces s of
	"" -> stringLoop ss
	l  -> do quit <- runCommand l
                 if quit then return () else stringLoop ss

320
mkPrompt toplevs exports
321
   = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
322

323
#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
324
325
readlineLoop :: GHCi ()
readlineLoop = do
326
327
   cmstate <- getCmState
   (mod,imports) <- io (cmGetContext cmstate)
328
   io yield
329
330
331
332
   l <- io (readline (mkPrompt mod imports)
	  	`finally` setNonBlockingFD 0)
		-- readline sometimes puts stdin into blocking mode,
		-- so we need to put it back for the IO library
333
334
335
336
337
338
339
340
341
342
   case l of
	Nothing -> return ()
	Just l  ->
	  case remove_spaces l of
	    "" -> readlineLoop
	    l  -> do
        	  io (addHistory l)
  	  	  quit <- runCommand l
          	  if quit then return () else readlineLoop
#endif
343

344
runCommand :: String -> GHCi Bool
345
346
347
348
349
350
351
352
353
354
355
356
357
358
runCommand c = ghciHandle handler (doCommand c)

-- This is the exception handler for exceptions generated by the
-- user's code; it normally just prints out the exception.  The
-- handler must be recursive, in case showing the exception causes
-- more exceptions to be raised.
--
-- Bugfix: if the user closed stdout or stderr, the flushing will fail,
-- raising another exception.  We therefore don't put the recursive
-- handler arond the flushing operation, so if stderr is closed
-- GHCi will just die gracefully rather than going into an infinite loop.
handler :: Exception -> GHCi Bool
handler exception = do
  flushInterpBuffers
359
  io installSignalHandlers
360
  ghciHandle handler (showException exception >> return False)
361
362
363

showException (DynException dyn) =
  case fromDynamic dyn of
sof's avatar
sof committed
364
365
366
    Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
    Just Interrupted      -> io (putStrLn "Interrupted.")
    Just (CmdLineError s) -> io (putStrLn s)	 -- omit the location for CmdLineError
sof's avatar
sof committed
367
    Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
sof's avatar
sof committed
368
369
    Just other_ghc_ex     -> io (print other_ghc_ex)

370
371
showException other_exception
  = io (putStrLn ("*** Exception: " ++ show other_exception))
372
373

doCommand (':' : command) = specialCommand command
374
doCommand stmt
375
   = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
376
377
        return False

378
runStmt :: String -> GHCi [Name]
379
runStmt stmt
380
 | null (filter (not.isSpace) stmt) = return []
381
 | otherwise
382
 = do st <- getGHCiState
383
      dflags <- io getDynFlags
384
      let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
385
      (new_cmstate, result) <- 
386
387
	io $ withProgName (progname st) $ withArgs (args st) $
	cmRunStmt (cmstate st) dflags' stmt
388
      setGHCiState st{cmstate = new_cmstate}
389
390
391
392
      case result of
	CmRunFailed      -> return []
	CmRunException e -> showException e >> return []
	CmRunOk names    -> return names
393
394

-- possibly print the type and revert CAFs after evaluating an expression
395
finishEvalExpr names
396
 = do b <- isOptionSet ShowType
397
398
      cmstate <- getCmState
      when b (mapM_ (showTypeOfName cmstate) names)
399

400
      flushInterpBuffers
401
      io installSignalHandlers
402
403
404
      b <- isOptionSet RevertCAFs
      io (when b revertCAFs)
      return True
405

406
407
408
409
410
411
412
showTypeOfName :: CmState -> Name -> GHCi ()
showTypeOfName cmstate n
   = do maybe_str <- io (cmTypeOfName cmstate n)
	case maybe_str of
	  Nothing  -> return ()
	  Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))

413
specialCommand :: String -> GHCi Bool
414
specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
415
416
specialCommand str = do
  let (cmd,rest) = break isSpace str
417
418
  cmds <- io (readIORef commands)
  case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
419
420
     []      -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n" 
		                    ++ shortHelpText) >> return False)
421
     [(_,f)] -> f (dropWhile isSpace rest)
422
423
     cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++ 
			    	      " matches multiple commands (" ++ 
424
	         	     	       foldr1 (\a b -> a ++ ',':b) (map fst cs)
425
					 ++ ")") >> return False)
426

427
noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
428

429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468

-----------------------------------------------------------------------------
-- To flush buffers for the *interpreted* computation we need
-- to refer to *its* stdout/stderr handles

GLOBAL_VAR(flush_interp,       error "no flush_interp", IO ())
GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())

no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++
	     " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
flush_cmd  = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr"

initInterpBuffering :: CmState -> DynFlags -> IO CmState
initInterpBuffering cmstate dflags
 = do (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags no_buf_cmd
	
      case maybe_hval of
	Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
	other	  -> panic "interactiveUI:setBuffering"
	
      (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags flush_cmd
      case maybe_hval of
	Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
	_         -> panic "interactiveUI:flush"

      turnOffBuffering	-- Turn it off right now

      return cmstate


flushInterpBuffers :: GHCi ()
flushInterpBuffers
 = io $ do Monad.join (readIORef flush_interp)
           return ()

turnOffBuffering :: IO ()
turnOffBuffering
 = do Monad.join (readIORef turn_off_buffering)
      return ()

469
470
471
472
473
474
-----------------------------------------------------------------------------
-- Commands

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

rrt's avatar
rrt committed
475
info :: String -> GHCi ()
476
info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
rrt's avatar
rrt committed
477
478
info s = do
  let names = words s
479
  init_cms <- getCmState
rrt's avatar
rrt committed
480
  dflags <- io getDynFlags
481
482
483
  let 
    infoThings cms [] = return cms
    infoThings cms (name:names) = do
484
      (cms, stuff) <- io (cmInfoThing cms dflags name)
485
      io (putStrLn (showSDocForUser unqual (
486
	    vcat (intersperse (text "") (map showThing stuff))))
487
488
489
         )
      infoThings cms names

490
491
    unqual = cmGetPrintUnqual init_cms

492
493
494
    showThing (ty_thing, fixity) 
	= vcat [ text "-- " <> showTyThing ty_thing, 
		 showFixity fixity (getName ty_thing),
495
	         ppr (ifaceTyThing ty_thing) ]
496
497
498

    showFixity fix name
	| fix == defaultFixity = empty
499
500
501
502
	| otherwise            = ppr fix <+> 
				 (if isSymOcc (nameOccName name)
					then ppr name
					else char '`' <> ppr name <> char '`')
503

504
    showTyThing (AClass cl)
505
       = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
506
507
    showTyThing (ADataCon dc)
       = hcat [ppr dc, text " is a data constructor", showSrcLoc (dataConName dc)]
508
    showTyThing (ATyCon ty)
509
510
511
       | isPrimTyCon ty
       = hcat [ppr ty, text " is a primitive type constructor"]
       | otherwise
512
513
       = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
    showTyThing (AnId   id)
514
       = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
515
516

    idDescr id
517
518
519
520
       = case globalIdDetails id of
	    RecordSelId lbl -> text "record selector for type" <+> ppr (fieldLabelTyCon lbl)
	    ClassOpId cls   -> text "method in class" <+> ppr cls
       	    otherwise       -> text "variable"
521
522
523
524
525
526
527
528
529

	-- also print out the source location for home things
    showSrcLoc name
	| isHomePackageName name && isGoodSrcLoc loc
	= hsep [ text ", defined at", ppr loc ]
	| otherwise
	= empty
	where loc = nameSrcLoc name

530
531
  cms <- infoThings init_cms names
  setCmState cms
532
533
  return ()

sof's avatar
sof committed
534
535
addModule :: [FilePath] -> GHCi ()
addModule files = do
536
537
538
  state <- getGHCiState
  dflags <- io (getDynFlags)
  io (revertCAFs)			-- always revert CAFs on load/add.
539
  let new_targets = files ++ targets state 
540
541
  graph <- io (cmDepAnal (cmstate state) dflags new_targets)
  (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
542
  setGHCiState state{ cmstate = cmstate1, targets = new_targets }
543
  setContextAfterLoad mods
544
  modulesLoadedMsg ok mods dflags
545

546
changeDirectory :: String -> GHCi ()
547
548
549
changeDirectory ('~':d) = do
   tilde <- io (getEnv "HOME")	-- will fail if HOME not defined
   io (setCurrentDirectory (tilde ++ '/':d))
550
changeDirectory d = io (setCurrentDirectory d)
551

552
553
554
555
556
defineMacro :: String -> GHCi ()
defineMacro s = do
  let (macro_name, definition) = break isSpace s
  cmds <- io (readIORef commands)
  if (null macro_name) 
557
	then throwDyn (CmdLineError "invalid macro name") 
558
559
	else do
  if (macro_name `elem` map fst cmds) 
560
	then throwDyn (CmdLineError 
561
		("command `" ++ macro_name ++ "' is already defined"))
562
563
564
565
566
567
568
	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
569
  cms <- getCmState
570
  dflags <- io getDynFlags
571
572
  (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
  setCmState new_cmstate
573
  case maybe_hv of
574
575
576
     Nothing -> return ()
     Just hv -> io (writeIORef commands --
		    ((macro_name, keepGoing (runMacro hv)) : cmds))
577
578
579
580
581
582
583
584
585
586

runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
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)
  if (macro_name `elem` map fst builtin_commands) 
587
	then throwDyn (CmdLineError
588
589
590
		("command `" ++ macro_name ++ "' cannot be undefined"))
	else do
  if (macro_name `notElem` map fst cmds) 
591
	then throwDyn (CmdLineError 
592
593
594
595
		("command `" ++ macro_name ++ "' not defined"))
	else do
  io (writeIORef commands (filter ((/= macro_name) . fst) cmds))

596

sof's avatar
sof committed
597
598
loadModule :: [FilePath] -> GHCi ()
loadModule fs = timeIt (loadModule' fs)
599

sof's avatar
sof committed
600
601
loadModule' :: [FilePath] -> GHCi ()
loadModule' files = do
602
  state <- getGHCiState
603
  dflags <- io getDynFlags
604
605
606
607
608
609

  -- do the dependency anal first, so that if it fails we don't throw
  -- away the current set of modules.
  graph <- io (cmDepAnal (cmstate state) dflags files)

  -- Dependency anal ok, now unload everything
610
  cmstate1 <- io (cmUnload (cmstate state) dflags)
611
  setGHCiState state{ cmstate = cmstate1, targets = [] }
612
613
614

  io (revertCAFs)  -- always revert CAFs on load.
  (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
615
  setGHCiState state{ cmstate = cmstate2, targets = files }
616
617

  setContextAfterLoad mods
618
  modulesLoadedMsg ok mods dflags
619

620

621
622
623
reloadModule :: String -> GHCi ()
reloadModule "" = do
  state <- getGHCiState
624
  dflags <- io getDynFlags
625
626
  case targets state of
   [] -> io (putStr "no current target\n")
627
628
629
630
631
632
   paths -> do
	-- do the dependency anal first, so that if it fails we don't throw
	-- away the current set of modules.
	graph <- io (cmDepAnal (cmstate state) dflags paths)

	io (revertCAFs)		-- always revert CAFs on reload.
633
	(cmstate1, ok, mods) 
634
		<- io (cmLoadModules (cmstate state) dflags graph)
635
636
        setGHCiState state{ cmstate=cmstate1 }
	setContextAfterLoad mods
637
	modulesLoadedMsg ok mods dflags
638

639
640
reloadModule _ = noArgs ":reload"

641
setContextAfterLoad [] = setContext prel
642
643
644
setContextAfterLoad (m:_) = do
  cmstate <- getCmState
  b <- io (cmModuleIsInterpreted cmstate m)
645
  if b then setContext ('*':m) else setContext m
646

647
648
649
modulesLoadedMsg ok mods dflags =
  when (verbosity dflags > 0) $ do
   let mod_commas 
650
651
652
	| null mods = text "none."
	| otherwise = hsep (
	    punctuate comma (map text mods)) <> text "."
653
   case ok of
654
    Failed ->
655
       io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
656
    Succeeded  ->
657
658
659
       io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))


660
typeOfExpr :: String -> GHCi ()
661
typeOfExpr str 
662
  = do cms <- getCmState
663
       dflags <- io getDynFlags
664
665
       (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
       setCmState new_cmstate
666
667
668
       case maybe_tystr of
	  Nothing    -> return ()
	  Just tystr -> io (putStrLn tystr)
669

670
671
quit :: String -> GHCi Bool
quit _ = return True
672

673
674
shellEscape :: String -> GHCi Bool
shellEscape str = io (system str >> return False)
675

676
677
678
679
680
681
-----------------------------------------------------------------------------
-- Browing a module's contents

browseCmd :: String -> GHCi ()
browseCmd m = 
  case words m of
682
683
    ['*':m] | looksLikeModuleName m -> browseModule m False
    [m]     | looksLikeModuleName m -> browseModule m True
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
    _ -> throwDyn (CmdLineError "syntax:  :browse <module>")

browseModule m exports_only = do
  cms <- getCmState
  dflags <- io getDynFlags

  is_interpreted <- io (cmModuleIsInterpreted cms m)
  when (not is_interpreted && not exports_only) $
	throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))

  -- temporarily set the context to the module we're interested in,
  -- just so we can get an appropriate PrintUnqualified
  (as,bs) <- io (cmGetContext cms)
  cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m]
			      else cmSetContext cms dflags [m] [])
  cms2 <- io (cmSetContext cms1 dflags as bs)

  (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)

  setCmState cms3

  let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context

      things' = filter wantToSee things

709
710
711
      wantToSee (AnId id)    = not (isImplicitId id)
      wantToSee (ADataCon _) = False	-- They'll come via their TyCon
      wantToSee _ 	     = True
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728

      thing_names = map getName things

      thingDecl thing@(AnId id)  = ifaceTyThing thing

      thingDecl thing@(AClass c) =
        let rn_decl = ifaceTyThing thing in
	case rn_decl of
	  ClassDecl { tcdSigs = cons } -> 
		rn_decl{ tcdSigs = filter methodIsVisible cons }
	  other -> other
        where
           methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names

      thingDecl thing@(ATyCon t) =
        let rn_decl = ifaceTyThing thing in
	case rn_decl of
729
730
	  TyData { tcdCons = DataCons cons } -> 
		rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
731
732
	  other -> other
        where
733
	  conIsVisible (ConDecl n _ _ _ _) = n `elem` thing_names
734
735
736
737
738
739
740

  io (putStrLn (showSDocForUser unqual (
   	 vcat (map (ppr . thingDecl) things')))
   )

  where

741
742
743
744
-----------------------------------------------------------------------------
-- Setting the module context

setContext str
745
746
747
748
749
750
751
752
  | all sensible mods = fn mods
  | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
  where
    (fn, mods) = case str of 
			'+':stuff -> (addToContext,      words stuff)
			'-':stuff -> (removeFromContext, words stuff)
			stuff     -> (newContext,        words stuff) 

753
754
    sensible ('*':m) = looksLikeModuleName m
    sensible m       = looksLikeModuleName m
755
756

newContext mods = do
757
  cms <- getCmState
758
  dflags <- io getDynFlags
759
  (as,bs) <- separate cms mods [] []
760
  let bs' = if null as && prel `notElem` bs then prel:bs else bs
761
762
763
764
  cms' <- io (cmSetContext cms dflags as bs')
  setCmState cms'

separate cmstate []           as bs = return (as,bs)
765
separate cmstate (('*':m):ms) as bs = do
766
   b <- io (cmModuleIsInterpreted cmstate m)
767
   if b then separate cmstate ms (m:as) bs
768
   	else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
769
770
separate cmstate (m:ms)       as bs = separate cmstate ms as (m:bs)

771
772
prel = "Prelude"

773
774
775

addToContext mods = do
  cms <- getCmState
776
  dflags <- io getDynFlags
777
  (as,bs) <- io (cmGetContext cms)
778

779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
  (as',bs') <- separate cms mods [] []

  let as_to_add = as' \\ (as ++ bs)
      bs_to_add = bs' \\ (as ++ bs)

  cms' <- io (cmSetContext cms dflags 
			(as ++ as_to_add) (bs ++ bs_to_add))
  setCmState cms'


removeFromContext mods = do
  cms <- getCmState
  dflags <- io getDynFlags
  (as,bs) <- io (cmGetContext cms)

  (as_to_remove,bs_to_remove) <- separate cms mods [] []

  let as' = as \\ (as_to_remove ++ bs_to_remove)
      bs' = bs \\ (as_to_remove ++ bs_to_remove)

  cms' <- io (cmSetContext cms dflags as' bs')
  setCmState cms'
801

802
803
804
805
806
807
808
809
810
811
----------------------------------------------------------------------------
-- Code for `:set'

-- set options in the interpreter.  Syntax is exactly the same as the
-- ghc command line, except that certain options aren't available (-C,
-- -E etc.)
--
-- This is pretty fragile: most options won't work as expected.  ToDo:
-- figure out which ones & disallow them.

812
813
setCmd :: String -> GHCi ()
setCmd ""
814
815
816
817
818
819
820
821
  = do st <- getGHCiState
       let opts = options st
       io $ putStrLn (showSDoc (
   	      text "options currently set: " <> 
   	      if null opts
   		   then text "none."
   		   else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
   	   ))
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
setCmd str
  = case words str of
	("args":args) -> setArgs args
	("prog":prog) -> setProg prog
	wds -> setOptions wds

setArgs args = do
  st <- getGHCiState
  setGHCiState st{ args = args }

setProg [prog] = do
  st <- getGHCiState
  setGHCiState st{ progname = prog }
setProg _ = do
  io (hPutStrLn stderr "syntax: :set prog <progname>")

setOptions wds =
   do -- first, deal with the GHCi opts (+s, +t, etc.)
      let (plus_opts, minus_opts)  = partition isPlus wds
sof's avatar
sof committed
841
      mapM_ setOpt plus_opts
842
843

      -- now, the GHC flags
844
      pkgs_before <- io (readIORef v_ExplicitPackages)
845
      leftovers   <- io (processArgs static_flags minus_opts [])
846
      pkgs_after  <- io (readIORef v_ExplicitPackages)
847
848

      -- update things if the users wants more packages
849
850
851
852
853
854
855
856
857
      let new_packages = pkgs_after \\ pkgs_before
      when (not (null new_packages)) $
	 newPackages new_packages

      -- don't forget about the extra command-line flags from the 
      -- extra_ghc_opts fields in the new packages
      new_package_details <- io (getPackageDetails new_packages)
      let pkg_extra_opts = concatMap extra_ghc_opts new_package_details
      pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts [])
858
859
860

      -- then, dynamic flags
      io $ do 
861
	restoreDynFlags
862
        leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) []
863
	saveDynFlags
864

865
        if (not (null leftovers))
866
		then throwDyn (CmdLineError ("unrecognised flags: " ++ 
867
						unwords leftovers))
868
869
		else return ()

870
871
872
873
874
875
876
877

unsetOptions :: String -> GHCi ()
unsetOptions str
  = do -- first, deal with the GHCi opts (+s, +t, etc.)
       let opts = words str
	   (minus_opts, rest1) = partition isMinus opts
	   (plus_opts, rest2)  = partition isPlus rest1

878
       if (not (null rest2)) 
879
880
881
	  then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
	  else do

sof's avatar
sof committed
882
       mapM_ unsetOpt plus_opts
883
884
 
       -- can't do GHC flags for now
885
       if (not (null minus_opts))
886
	  then throwDyn (CmdLineError "can't unset GHC command-line flags")
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
	  else return ()

isMinus ('-':s) = True
isMinus _ = False

isPlus ('+':s) = True
isPlus _ = False

setOpt ('+':str)
  = case strToGHCiOpt str of
	Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
	Just o  -> setOption o

unsetOpt ('+':str)
  = case strToGHCiOpt str of
	Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
	Just o  -> unsetOption o

strToGHCiOpt :: String -> (Maybe GHCiOption)
strToGHCiOpt "s" = Just ShowTiming
strToGHCiOpt "t" = Just ShowType
908
strToGHCiOpt "r" = Just RevertCAFs
909
910
911
912
913
strToGHCiOpt _   = Nothing

optToStr :: GHCiOption -> String
optToStr ShowTiming = "s"
optToStr ShowType   = "t"
914
optToStr RevertCAFs = "r"
915

916
917
918
newPackages new_pkgs = do	-- The new packages are already in v_Packages
  state    <- getGHCiState
  dflags   <- io getDynFlags
919
  cmstate1 <- io (cmUnload (cmstate state) dflags)
920
  setGHCiState state{ cmstate = cmstate1, targets = [] }
921
  io (linkPackages dflags new_pkgs)
922
923
  setContextAfterLoad []

924
-- ---------------------------------------------------------------------------
925
926
927
928
929
930
-- code for `:show'

showCmd str =
  case words str of
	["modules" ] -> showModules
	["bindings"] -> showBindings
931
	["linker"]   -> io showLinkerState
932
933
934
935
	_ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")

showModules = do
  cms <- getCmState
936
937
938
  let (mg, hpt) = cmGetModInfo cms
  mapM_ (showModule hpt) mg

939

940
941
942
943
944
945
946
947
948
949
showModule :: HomePackageTable -> ModSummary -> GHCi ()
showModule hpt mod_summary
  = case lookupModuleEnv hpt mod of
	Nothing	      -> panic "missing linkable"
	Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
		      where
			 obj_linkable = isObjectLinkable (hm_linkable mod_info)
  where
    mod = ms_mod mod_summary
    locn = ms_location mod_summary
950
951
952
953
954
955
956

showBindings = do
  cms <- getCmState
  let
	unqual = cmGetPrintUnqual cms
	showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))

sof's avatar
sof committed
957
  io (mapM_ showBinding (cmGetBindings cms))
958
959
  return ()

960

961
962
963
964
965
-----------------------------------------------------------------------------
-- GHCi monad

data GHCiState = GHCiState
     { 
966
967
	progname       :: String,
	args	       :: [String],
968
	targets        :: [FilePath],
969
	cmstate        :: CmState,
970
	options        :: [GHCiOption]
971
972
     }

973
974
975
976
977
data GHCiOption 
	= ShowTiming		-- show time/allocs after evaluation
	| ShowType		-- show the type of expressions
	| RevertCAFs		-- revert CAFs after every evaluation
	deriving Eq
978

979
980
981
982
newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }

startGHCi :: GHCi a -> GHCiState -> IO a
startGHCi g state = do ref <- newIORef state; unGHCi g ref
983
984

instance Monad GHCi where
985
986
  (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
  return a  = GHCi $ \s -> return a
987

988
989
990
991
ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
ghciHandleDyn h (GHCi m) = GHCi $ \s -> 
   Exception.catchDyn (m s) (\e -> unGHCi (h e) s)

992
993
getGHCiState   = GHCi $ \r -> readIORef r
setGHCiState s = GHCi $ \r -> writeIORef r s
994

995
996
997
998
-- for convenience...
getCmState = getGHCiState >>= return . cmstate
setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}

999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
isOptionSet :: GHCiOption -> GHCi Bool
isOptionSet opt
 = do st <- getGHCiState
      return (opt `elem` options st)

setOption :: GHCiOption -> GHCi ()
setOption opt
 = do st <- getGHCiState
      setGHCiState (st{ options = opt : filter (/= opt) (options st) })

unsetOption :: GHCiOption -> GHCi ()
unsetOption opt
 = do st <- getGHCiState
      setGHCiState (st{ options = filter (/= opt) (options st) })

rrt's avatar
rrt committed
1014
1015
io :: IO a -> GHCi a
io m = GHCi { unGHCi = \s -> m >>= return }
1016

1017
-----------------------------------------------------------------------------
1018
-- recursive exception handlers
1019
1020
1021
1022
1023

-- Don't forget to unblock async exceptions in the handler, or if we're
-- in an exception loop (eg. let a = error a in a) the ^C exception
-- may never be delivered.  Thanks to Marcin for pointing out the bug.

1024
ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1025
ghciHandle h (GHCi m) = GHCi $ \s -> 
1026
   Exception.catch (m s) 
1027
	(\e -> unGHCi (ghciUnblock (h e)) s)
1028

1029
1030
ghciUnblock :: GHCi a -> GHCi a
ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1031

1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
-----------------------------------------------------------------------------
-- timing & statistics

timeIt :: GHCi a -> GHCi a
timeIt action
  = do b <- isOptionSet ShowTiming
       if not b 
	  then action 
	  else do allocs1 <- io $ getAllocations
		  time1   <- io $ getCPUTime
		  a <- action
		  allocs2 <- io $ getAllocations
		  time2   <- io $ getCPUTime
		  io $ printTimes (allocs2 - allocs1) (time2 - time1)
		  return a

1048
foreign import ccall "getAllocations" getAllocations :: IO Int
1049
1050
1051
1052
1053
1054
1055
1056

printTimes :: Int -> Integer -> IO ()
printTimes allocs psecs
   = do let secs = (fromIntegral psecs / (10^12)) :: Float
	    secs_str = showFFloat (Just 2) secs
	putStrLn (showSDoc (
		 parens (text (secs_str "") <+> text "secs" <> comma <+> 
			 int allocs <+> text "bytes")))
1057
1058
1059
1060

-----------------------------------------------------------------------------
-- reverting CAFs
	
1061
1062
1063
revertCAFs :: IO ()
revertCAFs = do
  rts_revertCAFs
1064
1065
1066
  turnOffBuffering
	-- Have to turn off buffering again, because we just 
	-- reverted stdout, stderr & stdin to their defaults.
1067
1068

foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()  
1069
	-- Make it "safe", just in case