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

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

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

47
#ifndef mingw32_HOST_OS
48
import DriverUtil( handle )
ross's avatar
ross committed
49
import System.Posix
50 51 52
#if __GLASGOW_HASKELL__ > 504
	hiding (getEnv)
#endif
sof's avatar
sof committed
53 54
#endif

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

--import SystemExts

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

66
import Numeric
67 68 69 70 71 72 73 74
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
75

76
import GHC.Exts		( unsafeCoerce# )
77

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

80
import System.Posix.Internals ( setNonBlockingFD )
81

82 83 84
-----------------------------------------------------------------------------

ghciWelcomeMsg = "\ 
85
\   ___         ___ _\n\ 
86
\  / _ \\ /\\  /\\/ __(_)\n\ 
87
\ / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\ 
88
\/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n\ 
89
\\\____/\\/ /_/\\____/|_|      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),
sof's avatar
sof committed
102
  ("load",	keepGoingPaths loadModule),
103 104
  ("module",	keepGoing setContext),
  ("reload",	keepGoing reloadModule),
105
  ("set",	keepGoing setCmd),
106
  ("show",	keepGoing showCmd),
107 108
  ("type",	keepGoing typeOfExpr),
  ("unset",	keepGoing unsetOptions),
109
  ("undef",     keepGoing undefineMacro),
110
  ("quit",	quit)
111 112
  ]

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

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

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

121
-- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
122
helpText = "\ 
123
\ Commands available from the prompt:\n\ 
124
\\n\ 
125 126 127 128 129 130 131 132 133 134
\   <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\ 
135
\\n\ 
136 137 138 139 140 141 142 143 144 145 146 147
\   :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\ 
148
\\n\ 
149
\ Options for `:set' and `:unset':\n\ 
150
\\n\ 
151
\    +r			revert top-level expressions after each evaluation\n\ 
152 153 154 155
\    +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\ 
156 157
\"

158 159
interactiveUI :: [FilePath] -> Maybe String -> IO ()
interactiveUI srcs maybe_expr = do
160
   dflags <- getDynFlags
161

162
   cmstate <- cmInit Interactive;
163

164 165
   hFlush stdout
   hSetBuffering stdout NoBuffering
166 167 168

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

170 171
	-- We don't want the cmd line to buffer any input that might be
	-- intended for the program, so unbuffer stdin.
172
   hSetBuffering stdin NoBuffering
173

174 175 176
	-- initial context is just the Prelude
   cmstate <- cmSetContext cmstate dflags [] ["Prelude"]

177 178 179 180
#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
   Readline.initialize
#endif

181
   startGHCi (runGHCi srcs dflags maybe_expr)
182 183
	GHCiState{ progname = "<interactive>",
		   args = [],
184
		   targets = srcs,
185 186
		   cmstate = cmstate,
		   options = [] }
rrt's avatar
rrt committed
187 188 189 190 191

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

192 193
   return ()

194 195
runGHCi :: [FilePath] -> DynFlags -> Maybe String -> GHCi ()
runGHCi paths dflags maybe_expr = do
196 197 198 199 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
  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
226

227
  -- Perform a :load for files given on the GHCi command line
228
  when (not (null paths)) $
229
     ghciHandle showException $
sof's avatar
sof committed
230
	loadModule paths
231

232 233
  -- if verbosity is greater than 0, or we are connected to a
  -- terminal, display the prompt in the interactive loop.
234
  is_tty <- io (hIsTerminalDevice stdin)
235 236
  let show_prompt = verbosity dflags > 0 || is_tty

237 238 239 240 241 242 243 244
  case maybe_expr of
	Nothing -> 
	    -- enter the interactive loop
	    interactiveLoop is_tty show_prompt
	Just expr -> do
	    -- just evaluate the expression we were given
	    runCommand expr
	    return ()
245 246

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


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

256
  -- read commands from stdin
257
#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
258 259
  if (is_tty) 
	then readlineLoop
260
	else fileLoop stdin show_prompt
261
#else
262
  fileLoop stdin show_prompt
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 =
277
#ifdef mingw32_HOST_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 True{-omit prags-} ty_thing) ]
496 497 498

    showFixity fix name
	| fix == defaultFixity = empty
499 500
	| otherwise            = ppr fix <+> 
				 (if isSymOcc (nameOccName name)
501 502
				  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
  files <- mapM expandPath files
540
  let new_targets = files ++ targets state 
541 542
  graph <- io (cmDepAnal (cmstate state) dflags new_targets)
  (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
543
  setGHCiState state{ cmstate = cmstate1, targets = new_targets }
544
  setContextAfterLoad mods
545
  modulesLoadedMsg ok mods dflags
546

547
changeDirectory :: String -> GHCi ()
548
changeDirectory dir = do
549 550 551 552 553 554 555 556
  state    <- getGHCiState
  when (targets state /= []) $
	io $ putStr "Warning: changing directory causes all loaded modules to be unloaded, \n\ 
	\because the search path has changed.\n"
  dflags   <- io getDynFlags
  cmstate1 <- io (cmUnload (cmstate state) dflags)
  setGHCiState state{ cmstate = cmstate1, targets = [] }
  setContextAfterLoad []
557 558
  dir <- expandPath dir
  io (setCurrentDirectory dir)
559

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

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) 
595
	then throwDyn (CmdLineError
596 597 598
		("command `" ++ macro_name ++ "' cannot be undefined"))
	else do
  if (macro_name `notElem` map fst cmds) 
599
	then throwDyn (CmdLineError 
600 601 602 603
		("command `" ++ macro_name ++ "' not defined"))
	else do
  io (writeIORef commands (filter ((/= macro_name) . fst) cmds))

604

sof's avatar
sof committed
605 606
loadModule :: [FilePath] -> GHCi ()
loadModule fs = timeIt (loadModule' fs)
607

sof's avatar
sof committed
608 609
loadModule' :: [FilePath] -> GHCi ()
loadModule' files = do
610
  state <- getGHCiState
611
  dflags <- io getDynFlags
612

613 614 615
  -- expand tildes
  files <- mapM expandPath files

616 617 618 619 620
  -- 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
621
  cmstate1 <- io (cmUnload (cmstate state) dflags)
622
  setGHCiState state{ cmstate = cmstate1, targets = [] }
623 624 625

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

  setContextAfterLoad mods
629
  modulesLoadedMsg ok mods dflags
630

631

632 633 634
reloadModule :: String -> GHCi ()
reloadModule "" = do
  state <- getGHCiState
635
  dflags <- io getDynFlags
636 637
  case targets state of
   [] -> io (putStr "no current target\n")
638 639 640 641 642 643
   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.
644
	(cmstate1, ok, mods) 
645
		<- io (cmLoadModules (cmstate state) dflags graph)
646 647
        setGHCiState state{ cmstate=cmstate1 }
	setContextAfterLoad mods
648
	modulesLoadedMsg ok mods dflags
649

650 651
reloadModule _ = noArgs ":reload"

652
setContextAfterLoad [] = setContext prel
653 654 655
setContextAfterLoad (m:_) = do
  cmstate <- getCmState
  b <- io (cmModuleIsInterpreted cmstate m)
656
  if b then setContext ('*':m) else setContext m
657

658 659 660
modulesLoadedMsg ok mods dflags =
  when (verbosity dflags > 0) $ do
   let mod_commas 
661 662 663
	| null mods = text "none."
	| otherwise = hsep (
	    punctuate comma (map text mods)) <> text "."
664
   case ok of
665
    Failed ->
666
       io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
667
    Succeeded  ->
668 669 670
       io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))


671
typeOfExpr :: String -> GHCi ()
672
typeOfExpr str 
673
  = do cms <- getCmState
674
       dflags <- io getDynFlags
675 676
       (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
       setCmState new_cmstate
677 678 679
       case maybe_tystr of
	  Nothing    -> return ()
	  Just tystr -> io (putStrLn tystr)
680

681 682
quit :: String -> GHCi Bool
quit _ = return True
683

684 685
shellEscape :: String -> GHCi Bool
shellEscape str = io (system str >> return False)
686

687 688 689 690 691 692
-----------------------------------------------------------------------------
-- Browing a module's contents

browseCmd :: String -> GHCi ()
browseCmd m = 
  case words m of
693 694
    ['*':m] | looksLikeModuleName m -> browseModule m False
    [m]     | looksLikeModuleName m -> browseModule m True
695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719
    _ -> 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

720 721 722
      wantToSee (AnId id)    = not (isImplicitId id)
      wantToSee (ADataCon _) = False	-- They'll come via their TyCon
      wantToSee _ 	     = True
723 724 725

      thing_names = map getName things

726
      thingDecl thing@(AnId id)  = ifaceTyThing True{-omit prags-} thing
727 728

      thingDecl thing@(AClass c) =
729
        let rn_decl = ifaceTyThing True{-omit prags-} thing in
730 731 732 733 734 735 736 737
	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) =
738
        let rn_decl = ifaceTyThing True{-omit prags-} thing in
739
	case rn_decl of
740 741
	  TyData { tcdCons = DataCons cons } -> 
		rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
742 743
	  other -> other
        where
744
	  conIsVisible (ConDecl n _ _ _ _) = n `elem` thing_names
745 746 747 748 749

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

750 751 752 753
-----------------------------------------------------------------------------
-- Setting the module context

setContext str
754 755 756 757 758 759 760 761
  | 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) 

762 763
    sensible ('*':m) = looksLikeModuleName m
    sensible m       = looksLikeModuleName m
764 765

newContext mods = do
766
  cms <- getCmState
767
  dflags <- io getDynFlags
768
  (as,bs) <- separate cms mods [] []
769
  let bs' = if null as && prel `notElem` bs then prel:bs else bs
770 771 772 773
  cms' <- io (cmSetContext cms dflags as bs')
  setCmState cms'

separate cmstate []           as bs = return (as,bs)
774
separate cmstate (('*':m):ms) as bs = do
775
   b <- io (cmModuleIsInterpreted cmstate m)
776
   if b then separate cmstate ms (m:as) bs
777
   	else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
778 779
separate cmstate (m:ms)       as bs = separate cmstate ms as (m:bs)

780 781
prel = "Prelude"

782 783 784

addToContext mods = do
  cms <- getCmState
785
  dflags <- io getDynFlags
786
  (as,bs) <- io (cmGetContext cms)
787

788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809
  (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'
810

811 812 813 814 815 816 817 818 819 820
----------------------------------------------------------------------------
-- 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.

821 822
setCmd :: String -> GHCi ()
setCmd ""
823 824 825 826 827 828 829 830
  = 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)
   	   ))
831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849
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
850
      mapM_ setOpt plus_opts
851 852

      -- now, the GHC flags
853
      pkgs_before <- io (readIORef v_ExplicitPackages)
854
      leftovers   <- io (processArgs static_flags minus_opts [])
855
      pkgs_after  <- io (readIORef v_ExplicitPackages)
856 857

      -- update things if the users wants more packages
858 859 860 861 862 863 864 865 866
      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 [])
867 868 869

      -- then, dynamic flags
      io $ do 
870
	restoreDynFlags
871
        leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) []
872
	saveDynFlags
873

874
        if (not (null leftovers))
875
		then throwDyn (CmdLineError ("unrecognised flags: " ++