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

14
15
#include "HsVersions.h"

16
17
18
19
-- The GHC interface
import qualified GHC
import GHC		( Session, verbosity, dopt, DynFlag(..),
			  mkModule, pprModule, Type, Module, SuccessFlag(..),
20
21
			  TyThing(..), Name, LoadHowMuch(..),
			  GhcException(..), showGhcException )
22
23
24
import Outputable

-- following all needed for :info... ToDo: remove
25
26
import IfaceSyn		( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..),
			  IfaceConDecl(..), IfaceType,
27
		   	  pprIfaceDeclHead, pprParendIfaceType,
28
			  pprIfaceForAllPart, pprIfaceType )
29
import FunDeps		( pprFundeps )
30
import SrcLoc		( SrcLoc, isGoodSrcLoc )
31
import OccName		( OccName, parenSymOcc, occNameUserString )
32
33
34
import BasicTypes	( StrictnessMark(..), defaultFixity )

-- Other random utilities
35
import Panic 		( panic, installSignalHandlers )
36
import Config
37
import StaticFlags	( opt_IgnoreDotGhci )
38
39
40
import Linker		( showLinkerState )
import Util		( removeSpaces, handle, global, toArgs,
			  looksLikeModuleName, prefixMatch )
41

42
#ifndef mingw32_HOST_OS
43
import Util		( handle )
ross's avatar
ross committed
44
import System.Posix
45
46
47
#if __GLASGOW_HASKELL__ > 504
	hiding (getEnv)
#endif
sof's avatar
sof committed
48
49
#endif

50
#ifdef USE_READLINE
51
import Control.Concurrent	( yield )	-- Used in readline loop
52
import System.Console.Readline as Readline
53
#endif
54
55
56
57
58

--import SystemExts

import Control.Exception as Exception
import Data.Dynamic
59
-- import Control.Concurrent
60

61
import Numeric
62
import Data.List
63
import Data.Int		( Int64 )
64
65
66
import System.Cmd
import System.CPUTime
import System.Environment
67
import System.Exit	( exitWith, ExitCode(..) )
68
import System.Directory
ross's avatar
ross committed
69
70
import System.IO
import System.IO.Error as IO
71
72
import Data.Char
import Control.Monad as Monad
73
import Foreign.StablePtr	( newStablePtr )
74

75
import GHC.Exts		( unsafeCoerce# )
76
import GHC.IOBase	( IOErrorType(InvalidArgument) )
77

78
79
import Data.IORef	( IORef, newIORef, readIORef, writeIORef )

80
import System.Posix.Internals ( setNonBlockingFD )
81

82
83
-----------------------------------------------------------------------------

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

91
92
93
94
GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])

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

114
115
116
keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
keepGoing a str = a str >> return False

sof's avatar
sof committed
117
118
119
keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
keepGoingPaths a str = a (toArgs str) >> return False

120
121
shortHelpText = "use :? for help.\n"

122
-- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
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" ++
 "   :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" ++
 "\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" ++
 "\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" ++
 "   :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" ++
 "                         (eg. -v2, -fglasgow-exts, etc.)\n"

159

160
161
interactiveUI :: Session -> [FilePath] -> Maybe String -> IO ()
interactiveUI session srcs maybe_expr = do
162

163
164
165
166
167
168
169
170
171
172
173
174
   -- 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

175
176
   hFlush stdout
   hSetBuffering stdout NoBuffering
177
178

	-- Initialise buffering for the *interpreted* I/O system
179
   initInterpBuffering session
180

181
182
	-- We don't want the cmd line to buffer any input that might be
	-- intended for the program, so unbuffer stdin.
183
   hSetBuffering stdin NoBuffering
184

185
	-- initial context is just the Prelude
186
   GHC.setContext session [] [prelude_mod]
187

188
#ifdef USE_READLINE
189
190
191
   Readline.initialize
#endif

192
   startGHCi (runGHCi srcs maybe_expr)
193
194
	GHCiState{ progname = "<interactive>",
		   args = [],
195
		   session = session,
196
		   options = [] }
rrt's avatar
rrt committed
197

198
#ifdef USE_READLINE
rrt's avatar
rrt committed
199
200
201
   Readline.resetTerminal Nothing
#endif

202
203
   return ()

204
205
runGHCi :: [FilePath] -> Maybe String -> GHCi ()
runGHCi paths maybe_expr = do
206
  let read_dot_files = not opt_IgnoreDotGhci
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235

  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
236

237
  -- Perform a :load for files given on the GHCi command line
238
239
240
  when (not (null paths)) $
     ghciHandle showException $
	loadModule paths
241

242
243
  -- if verbosity is greater than 0, or we are connected to a
  -- terminal, display the prompt in the interactive loop.
244
  is_tty <- io (hIsTerminalDevice stdin)
245
  dflags <- getDynFlags
246
247
  let show_prompt = verbosity dflags > 0 || is_tty

248
249
250
251
252
253
  case maybe_expr of
	Nothing -> 
	    -- enter the interactive loop
	    interactiveLoop is_tty show_prompt
	Just expr -> do
	    -- just evaluate the expression we were given
254
	    runCommandEval expr
255
	    return ()
256
257

  -- and finally, exit
258
  io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
259
260


261
interactiveLoop is_tty show_prompt = do
262
  -- Ignore ^C exceptions caught here
263
  ghciHandleDyn (\e -> case e of 
264
			Interrupted -> ghciUnblock (interactiveLoop is_tty show_prompt)
265
			_other      -> return ()) $ do
266

267
  -- read commands from stdin
268
#ifdef USE_READLINE
269
  if (is_tty) 
270
	then readlineLoop
271
	else fileLoop stdin show_prompt
272
#else
273
  fileLoop stdin show_prompt
274
#endif
275
276


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

rrt's avatar
rrt committed
281
282
283
284
-- 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.
285
286
287

checkPerms :: String -> IO Bool
checkPerms name =
288
#ifdef mingw32_HOST_OS
289
  return True
sof's avatar
sof committed
290
#else
291
  Util.handle (\_ -> return False) $ do
292
293
294
295
296
297
298
299
300
301
302
303
304
305
     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
306
#endif
307

308
309
fileLoop :: Handle -> Bool -> GHCi ()
fileLoop hdl prompt = do
310
311
   session <- getSession
   (mod,imports) <- io (GHC.getContext session)
312
   when prompt (io (putStr (mkPrompt mod imports)))
313
314
   l <- io (IO.try (hGetLine hdl))
   case l of
315
316
317
318
319
320
321
322
	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.
323
	Right l -> 
324
	  case removeSpaces l of
325
326
327
	    "" -> fileLoop hdl prompt
	    l  -> do quit <- runCommand l
          	     if quit then return () else fileLoop hdl prompt
328

329
330
331
stringLoop :: [String] -> GHCi ()
stringLoop [] = return ()
stringLoop (s:ss) = do
332
   case removeSpaces s of
333
334
335
336
	"" -> stringLoop ss
	l  -> do quit <- runCommand l
                 if quit then return () else stringLoop ss

337
mkPrompt toplevs exports
338
339
340
  = showSDoc (hsep (map (\m -> char '*' <> pprModule m) toplevs)
	     <+> hsep (map pprModule exports)
	     <> text "> ")
341

342
#ifdef USE_READLINE
343
344
readlineLoop :: GHCi ()
readlineLoop = do
345
346
   session <- getSession
   (mod,imports) <- io (GHC.getContext session)
347
   io yield
348
349
350
351
   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
352
353
354
   case l of
	Nothing -> return ()
	Just l  ->
355
	  case removeSpaces l of
356
357
358
359
360
361
	    "" -> readlineLoop
	    l  -> do
        	  io (addHistory l)
  	  	  quit <- runCommand l
          	  if quit then return () else readlineLoop
#endif
362

363
runCommand :: String -> GHCi Bool
364
365
runCommand c = ghciHandle handler (doCommand c)

366
367
368
369
370
371
372
373
374
-- 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)
    handleEval e                    = do showException e
				         io (exitWith (ExitFailure 1))

375
376
377
378
379
380
381
382
383
384
385
386
-- 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
387
  io installSignalHandlers
388
  ghciHandle handler (showException exception >> return False)
389
390
391

showException (DynException dyn) =
  case fromDynamic dyn of
sof's avatar
sof committed
392
393
394
    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
395
    Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
sof's avatar
sof committed
396
397
    Just other_ghc_ex     -> io (print other_ghc_ex)

398
399
showException other_exception
  = io (putStrLn ("*** Exception: " ++ show other_exception))
400
401

doCommand (':' : command) = specialCommand command
402
doCommand stmt
403
   = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
404
405
        return False

406
runStmt :: String -> GHCi [Name]
407
runStmt stmt
408
 | null (filter (not.isSpace) stmt) = return []
409
 | otherwise
410
 = do st <- getGHCiState
411
412
413
      session <- getSession
      result <- io $ withProgName (progname st) $ withArgs (args st) $
	     	     GHC.runStmt session stmt
414
      case result of
415
416
417
	GHC.RunFailed      -> return []
	GHC.RunException e -> throw e  -- this is caught by runCommand(Eval)
	GHC.RunOk names    -> return names
418
419

-- possibly print the type and revert CAFs after evaluating an expression
420
finishEvalExpr names
421
 = do b <- isOptionSet ShowType
422
423
      session <- getSession
      when b (mapM_ (showTypeOfName session) names)
424

425
      flushInterpBuffers
426
      io installSignalHandlers
427
428
429
      b <- isOptionSet RevertCAFs
      io (when b revertCAFs)
      return True
430

431
432
433
434
435
436
437
438
439
440
441
442
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

showForUser :: SDoc -> GHCi String
showForUser doc = do
  session <- getSession
  unqual <- io (GHC.getPrintUnqual session)
  return $! showSDocForUser unqual doc
443

444
specialCommand :: String -> GHCi Bool
445
specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
446
447
specialCommand str = do
  let (cmd,rest) = break isSpace str
448
449
  cmds <- io (readIORef commands)
  case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
450
     []      -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n" 
451
		                    ++ shortHelpText) >> return False)
452
     [(_,f)] -> f (dropWhile isSpace rest)
453
454
     cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++ 
			    	      " matches multiple commands (" ++ 
455
	         	     	       foldr1 (\a b -> a ++ ',':b) (map fst cs)
456
					 ++ ")") >> return False)
457

458
noArgs c = throwDyn (CmdLineError ("command '" ++ c ++ "' takes no arguments"))
459

460
461
462
463
464
465
466
467

-----------------------------------------------------------------------------
-- 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 ())

468
469
470
no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
	     " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
flush_cmd  = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
471

472
473
474
initInterpBuffering :: Session -> IO ()
initInterpBuffering session
 = do maybe_hval <- GHC.compileExpr session no_buf_cmd
475
476
477
478
479
	
      case maybe_hval of
	Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
	other	  -> panic "interactiveUI:setBuffering"
	
480
      maybe_hval <- GHC.compileExpr session flush_cmd
481
482
483
484
485
486
      case maybe_hval of
	Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
	_         -> panic "interactiveUI:flush"

      turnOffBuffering	-- Turn it off right now

487
      return ()
488
489
490
491
492
493
494
495
496
497
498
499


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

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

500
501
502
503
504
505
-----------------------------------------------------------------------------
-- Commands

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

rrt's avatar
rrt committed
506
info :: String -> GHCi ()
507
info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
508
info s  = do { let names = words s
509
	     ; session <- getSession
510
511
	     ; dflags <- getDynFlags
	     ; let exts = dopt Opt_GlasgowExts dflags
512
	     ; mapM_ (infoThing exts session) names }
513
  where
514
515
516
517
    infoThing exts session name
	= do { stuff <- io (GHC.getInfo session name)
	     ; unqual <- io (GHC.getPrintUnqual session)
	     ; io (putStrLn (showSDocForUser unqual $
518
     		   vcat (intersperse (text "") (map (showThing exts) stuff)))) }
519

520
showThing :: Bool -> GHC.GetInfoResult -> SDoc
521
showThing exts (wanted_str, thing, fixity, src_loc, insts) 
522
    = vcat [ showWithLoc src_loc (showDecl exts want_name thing),
523
524
	     show_fixity fixity,
	     vcat (map show_inst insts)]
525
  where
526
527
528
    want_name occ = wanted_str == occNameUserString occ

    show_fixity fix 
529
	| fix == defaultFixity = empty
530
531
	| otherwise            = ppr fix <+> text wanted_str

532
533
    show_inst (inst_ty, loc)
	= showWithLoc loc (ptext SLIT("instance") <+> ppr inst_ty)
534
535
536
537
538
539

showWithLoc :: SrcLoc -> SDoc -> SDoc
showWithLoc loc doc 
    = hang doc 2 (char '\t' <> show_loc loc)
		-- The tab tries to make them line up a bit
  where
540
541
542
543
    show_loc loc	-- The ppr function for SrcLocs is a bit wonky
	| isGoodSrcLoc loc = comment <+> ptext SLIT("Defined at") <+> ppr loc
	| otherwise	   = comment <+> ppr loc
    comment = ptext SLIT("--")
544

545

546
547
-- Now there is rather a lot of goop just to print declarations in a
-- civilised way with "..." for the parts we are less interested in.
548

549
550
showDecl :: Bool -> (OccName -> Bool) -> IfaceDecl -> SDoc
showDecl exts want_name (IfaceForeign {ifName = tc})
551
552
  = ppr tc <+> ptext SLIT("is a foreign type")

553
showDecl exts want_name (IfaceId {ifName = var, ifType = ty})
554
  = ppr var <+> dcolon <+> showIfaceType exts ty 
555

556
showDecl exts want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty})
557
558
559
  = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
       2 (equals <+> ppr mono_ty)

560
showDecl exts want_name (IfaceData {ifName = tycon, 
561
562
563
564
		     ifTyVars = tyvars, ifCons = condecls})
  = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
       2 (add_bars (ppr_trim show_con cs))
  where
565
566
    show_con (IfVanillaCon { ifConOcc = con_name, ifConInfix = is_infix, ifConArgTys = tys, 
			     ifConStricts = strs, ifConFields = flds})
567
	| want_name tycon || want_name con_name || any want_name flds
568
	= Just (show_guts con_name is_infix tys_w_strs flds)
569
570
571
	| otherwise = Nothing
	where
	  tys_w_strs = tys `zip` (strs ++ repeat NotMarkedStrict)
572
573
574
575
576
577
578
579
580
581
    show_con (IfGadtCon { ifConOcc = con_name, ifConTyVars = tvs, ifConCtxt = theta, 
			  ifConArgTys = arg_tys, ifConResTys = res_tys, ifConStricts = strs })
	| want_name tycon || want_name con_name
	= Just (ppr_bndr con_name <+> colon <+> pprIfaceForAllPart tvs theta pp_tau)
	| otherwise = Nothing
	where
	  tys_w_strs = arg_tys `zip` (strs ++ repeat NotMarkedStrict)
	  pp_tau = foldr add pp_res_ty tys_w_strs
	  pp_res_ty = ppr_bndr tycon <+> hsep (map pprParendIfaceType res_tys)
	  add bty pp_ty = ppr_bangty bty <+> arrow <+> pp_ty
582
583
584
585
586
587
588
589
590
591

    show_guts con True [ty1, ty2] flds = sep [ppr_bangty ty1, ppr con, ppr_bangty ty2]
    show_guts con _ tys []   = ppr_bndr con <+> sep (map ppr_bangty tys)
    show_guts con _ tys flds 
	= ppr_bndr con <+> braces (sep (punctuate comma (ppr_trim show_fld (tys `zip` flds))))
	where
	  show_fld (bty, fld) | want_name tycon || want_name con || want_name fld
			      = Just (ppr_bndr fld <+> dcolon <+> ppr_bangty bty)
			      | otherwise = Nothing

592
593
594
595
596
    (pp_nd, context, cs) = case condecls of
		    IfAbstractTyCon 	      -> (ptext SLIT("data"), [],   [])
		    IfDataTyCon (Just cxt) cs -> (ptext SLIT("data"), cxt, cs)
		    IfDataTyCon Nothing cs    -> (ptext SLIT("data"), [],  cs)
		    IfNewTyCon c    	      -> (ptext SLIT("newtype"), [], [c])
597
598
599
600
601
602
603
604
605
606

    add_bars []      = empty
    add_bars [c]     = equals <+> c
    add_bars (c:cs)  = equals <+> sep (c : map (char '|' <+>) cs)

    ppr_bangty (ty, str) = ppr_str str <> pprParendIfaceType ty
    ppr_str MarkedStrict    = char '!'
    ppr_str MarkedUnboxed   = ptext SLIT("!!")
    ppr_str NotMarkedStrict = empty

607
showDecl exts want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, 
608
609
		      ifFDs = fds, ifSigs = sigs})
  = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars
610
		<+> pprFundeps fds <+> opt_where)
611
612
       2 (vcat (ppr_trim show_op sigs))
  where
613
614
    opt_where | null sigs = empty
	      | otherwise = ptext SLIT("where")
615
    show_op (IfaceClassOp op dm ty) 
616
	| want_name clas || want_name op 
617
	= Just (ppr_bndr op <+> dcolon <+> showIfaceType exts ty)
618
619
620
	| otherwise
	= Nothing

621
622
623
showIfaceType :: Bool -> IfaceType -> SDoc
showIfaceType True  ty = pprIfaceType ty -- -fglasgow-exts: print with the foralls
showIfaceType False ty = ppr ty	    -- otherwise, print without the foralls
624

625
626
627
628
629
630
631
632
633
634
635
ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc]
ppr_trim show xs
  = snd (foldr go (False, []) xs)
  where
    go x (eliding, so_far)
	| Just doc <- show x = (False, doc : so_far)
	| otherwise = if eliding then (True, so_far)
		                 else (True, ptext SLIT("...") : so_far)

ppr_bndr :: OccName -> SDoc
-- Wrap operators in ()
636
ppr_bndr occ = parenSymOcc occ (ppr occ)
637
638
639
640


-----------------------------------------------------------------------------
-- Commands
641

sof's avatar
sof committed
642
643
addModule :: [FilePath] -> GHCi ()
addModule files = do
644
  io (revertCAFs)			-- always revert CAFs on load/add.
645
  files <- mapM expandPath files
646
647
648
  targets <- mapM (io . GHC.guessTarget) files
  session <- getSession
  io (mapM_ (GHC.addTarget session) targets)
649
  ok <- io (GHC.load session LoadAllTargets)
650
  afterLoad ok session
651

652
changeDirectory :: String -> GHCi ()
653
changeDirectory dir = do
654
655
656
  session <- getSession
  graph <- io (GHC.getModuleGraph session)
  when (not (null graph)) $
657
	io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
658
  io (GHC.setTargets session [])
659
  io (GHC.load session LoadAllTargets)
660
  setContextAfterLoad []
661
  io (GHC.workingDirectoryChanged session)
662
663
  dir <- expandPath dir
  io (setCurrentDirectory dir)
664

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

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

707

708
loadModule :: [FilePath] -> GHCi ()
sof's avatar
sof committed
709
loadModule fs = timeIt (loadModule' fs)
710

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

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

719
720
  -- expand tildes
  files <- mapM expandPath files
721
  targets <- io (mapM GHC.guessTarget files)
722

723
724
725
726
  -- 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.
727

728
  io (GHC.setTargets session targets)
729
  ok <- io (GHC.load session LoadAllTargets)
730
  afterLoad ok session
731

732

733
734
reloadModule :: String -> GHCi ()
reloadModule "" = do
735
736
  io (revertCAFs)		-- always revert CAFs on reload.
  session <- getSession
737
  ok <- io (GHC.load session LoadAllTargets)
738
  afterLoad ok session
739
740
741
reloadModule m = do
  io (revertCAFs)		-- always revert CAFs on reload.
  session <- getSession
742
  ok <- io (GHC.load session (LoadUpTo (mkModule m)))
743
  afterLoad ok session
744

745
746
747
748
afterLoad ok session = do
  io (revertCAFs)  -- always revert CAFs on load.
  graph <- io (GHC.getModuleGraph session)
  let mods = map GHC.ms_mod graph
749
750
751
  mods' <- filterM (io . GHC.isLoaded session) mods
  setContextAfterLoad mods'
  modulesLoadedMsg ok mods'
752
753
754
755

setContextAfterLoad [] = do
  session <- getSession
  io (GHC.setContext session [] [prelude_mod])
756
setContextAfterLoad (m:_) = do
757
758
759
760
  session <- getSession
  b <- io (GHC.moduleIsInterpreted session m)
  if b then io (GHC.setContext session [m] []) 
       else io (GHC.setContext session []  [m])
761

762
763
764
modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi ()
modulesLoadedMsg ok mods = do
  dflags <- getDynFlags
765
766
  when (verbosity dflags > 0) $ do
   let mod_commas 
767
768
	| null mods = text "none."
	| otherwise = hsep (
769
	    punctuate comma (map pprModule mods)) <> text "."
770
   case ok of
771
    Failed ->
772
       io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
773
    Succeeded  ->
774
775
776
       io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))


777
typeOfExpr :: String -> GHCi ()
778
typeOfExpr str 
779
780
781
782
783
784
785
  = do cms <- getSession
       maybe_ty <- io (GHC.exprType cms str)
       case maybe_ty of
	  Nothing -> return ()
	  Just ty -> do ty' <- cleanType ty
			tystr <- showForUser (ppr ty')
		        io (putStrLn (str ++ " :: " ++ tystr))
786
787
788

kindOfType :: String -> GHCi ()
kindOfType str 
789
790
791
  = do cms <- getSession
       maybe_ty <- io (GHC.typeKind cms str)
       case maybe_ty of
792
	  Nothing    -> return ()
793
794
	  Just ty    -> do tystr <- showForUser (ppr ty)
		           io (putStrLn (str ++ " :: " ++ tystr))
795

796
797
quit :: String -> GHCi Bool
quit _ = return True
798

799
800
shellEscape :: String -> GHCi Bool
shellEscape str = io (system str >> return False)
801

802
-----------------------------------------------------------------------------
dons's avatar
dons committed
803
-- Browsing a module's contents
804
805
806
807

browseCmd :: String -> GHCi ()
browseCmd m = 
  case words m of
808
809
    ['*':m] | looksLikeModuleName m -> browseModule m False
    [m]     | looksLikeModuleName m -> browseModule m True
810
811
812
    _ -> throwDyn (CmdLineError "syntax:  :browse <module>")

browseModule m exports_only = do
813
  s <- getSession
814

815
816
  let modl = mkModule m
  is_interpreted <- io (GHC.moduleIsInterpreted s modl)
817
  when (not is_interpreted && not exports_only) $
818
	throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
819

820
  -- Temporarily set the context to the module we're interested in,
821
  -- just so we can get an appropriate PrintUnqualified
822
823
824
825
  (as,bs) <- io (GHC.getContext s)
  io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
		      else GHC.setContext s [modl] [])
  io (GHC.setContext s as bs)
826

827
828
  things <- io (GHC.browseModule s modl exports_only)
  unqual <- io (GHC.getPrintUnqual s)
829

830
831
  dflags <- getDynFlags
  let exts = dopt Opt_GlasgowExts dflags
832
  io (putStrLn (showSDocForUser unqual (
833
   	 vcat (map (showDecl exts (const True)) things)
834
      )))
835

836
837
838
839
-----------------------------------------------------------------------------
-- Setting the module context

setContext str
840
841
842
843
844
845
846
847
  | 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) 

848
849
    sensible ('*':m) = looksLikeModuleName m
    sensible m       = looksLikeModuleName m
850
851

newContext mods = do
852
853
854
855
856
857
858
859
860
861
862
863
  session <- getSession
  (as,bs) <- separate session mods [] []
  let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs
  io (GHC.setContext session as bs')

separate :: Session -> [String] -> [Module] -> [Module]
  -> GHCi ([Module],[Module])
separate session []           as bs = return (as,bs)
separate session (('*':m):ms) as bs = do
   let modl = mkModule m
   b <- io (GHC.moduleIsInterpreted session modl)
   if b then separate session ms (modl:as) bs
864
   	else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
865
separate session (m:ms)       as bs = separate session ms as (mkModule m:bs)
866

867
prelude_mod = mkModule "Prelude"
868

869
870

addToContext mods = do
871
872
  cms <- getSession
  (as,bs) <- io (GHC.getContext cms)
873

874
875
876
877
878
  (as',bs') <- separate cms mods [] []

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

879
  io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add))
880
881
882


removeFromContext mods = do
883
884
  cms <- getSession
  (as,bs) <- io (GHC.getContext cms)
885
886
887
888
889
890

  (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)

891
  io (GHC.setContext cms as' bs')
892

893
894
895
896
897
898
899
900
901
902
----------------------------------------------------------------------------
-- 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.

903
904
setCmd :: String -> GHCi ()
setCmd ""
905
906
907
908
909
910
911
912
  = 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)
   	   ))
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
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
932
      mapM_ setOpt plus_opts
933
934

      -- then, dynamic flags
935
      dflags <- getDynFlags
936
      (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
937
938
939
940
941
942
943
944
945
946
      setDynFlags dflags'

        -- update things if the users wants more packages
{- TODO:
        let new_packages = pkgs_after \\ pkgs_before
        when (not (null new_packages)) $
  	   newPackages new_packages
-}

      if (not (null leftovers))
947
		then throwDyn (CmdLineError ("unrecognised flags: " ++ 
948
						unwords leftovers))
949
950
		else return ()

951
952
953
954
955
956
957
958

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

959
       if (not (null rest2)) 
960
	  then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
961
962
	  else do

sof's avatar
sof committed
963
       mapM_ unsetOpt plus_opts
964
965
 
       -- can't do GHC flags for now
966
       if (not (null minus_opts))
967
	  then throwDyn (CmdLineError "can't unset GHC command-line flags")
968
969
970
971
972
973
974
975
976
977
	  else return ()

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

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

setOpt ('+':str)
  = case strToGHCiOpt str of
978
	Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
979
980
981
982
	Just o  -> setOption o

unsetOpt ('+':str)
  = case strToGHCiOpt str of
983
	Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
984
985
986
987
988
	Just o  -> unsetOption o

strToGHCiOpt :: String -> (Maybe GHCiOption)
strToGHCiOpt "s" = Just ShowTiming
strToGHCiOpt "t" = Just ShowType
989
strToGHCiOpt "r" = Just RevertCAFs
990
991
992
993
994
strToGHCiOpt _   = Nothing

optToStr :: GHCiOption -> String
optToStr ShowTiming = "s"
optToStr ShowType   = "t"
995
optToStr RevertCAFs = "r"
996

997
{- ToDo
998
newPackages new_pkgs = do	-- The new packages are already in v_Packages
999
1000
1001
  session <- getSession
  io (GHC.setTargets session [])
  io (GHC.load session Nothing)