InteractiveUI.hs 33.1 KB
Newer Older
1
{-# OPTIONS -#include "Linker.h" #-}
2
-----------------------------------------------------------------------------
3
-- $Id: InteractiveUI.hs,v 1.145 2003/02/17 12:24:26 simonmar 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 Id		( isRecordSelector, isImplicitId, recordSelectorFieldLabel, idName )
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

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

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

--import SystemExts

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

62
import Numeric
63 64 65 66 67 68 69 70
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
71

72
import GHC.Exts		( unsafeCoerce# )
73

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

76 77
import GHC.Posix	( setNonBlockingFD )

78 79 80
-----------------------------------------------------------------------------

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

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

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

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

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

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

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

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

159 160
   dflags <- getDynFlags

161
   initLinker
162 163 164 165 166 167

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

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

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

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

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

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

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

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

195 196
   return ()

197 198
runGHCi :: [FilePath] -> DynFlags -> GHCi ()
runGHCi paths dflags = do
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 226 227 228
  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
229

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

  -- enter the interactive loop
sof's avatar
sof committed
236 237 238 239 240
#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
241 242
  is_tty <- io (hIsTerminalDevice stdin)
  interactiveLoop is_tty
sof's avatar
sof committed
243
#endif
244 245

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


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

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


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

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

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

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

311 312 313 314 315 316 317 318
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

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

322
#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
323 324
readlineLoop :: GHCi ()
readlineLoop = do
325 326
   cmstate <- getCmState
   (mod,imports) <- io (cmGetContext cmstate)
327
   io yield
328 329 330 331
   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
332 333 334 335 336 337 338 339 340 341
   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
342

343
runCommand :: String -> GHCi Bool
344 345 346 347 348 349 350 351 352 353 354 355 356 357
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
358
  io installSignalHandlers
359
  ghciHandle handler (showException exception >> return False)
360 361 362

showException (DynException dyn) =
  case fromDynamic dyn of
sof's avatar
sof committed
363 364 365
    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
366
    Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
sof's avatar
sof committed
367 368
    Just other_ghc_ex     -> io (print other_ghc_ex)

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

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

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

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

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

405 406 407 408 409 410 411
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))

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

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

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

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

468 469 470 471 472 473
-----------------------------------------------------------------------------
-- Commands

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

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

489 490
    unqual = cmGetPrintUnqual init_cms

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

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

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

    idDescr id
516 517 518 519 520 521
       | isRecordSelector id = 
		case tyConClass_maybe (fieldLabelTyCon (
				recordSelectorFieldLabel id)) of
			Nothing -> text "record selector"
			Just c  -> text "method in class " <> ppr c
       | otherwise           = text "variable"
522 523 524 525 526 527 528 529 530

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

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

sof's avatar
sof committed
535 536
addModule :: [FilePath] -> GHCi ()
addModule files = do
537 538 539
  state <- getGHCiState
  dflags <- io (getDynFlags)
  io (revertCAFs)			-- always revert CAFs on load/add.
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 549 550
changeDirectory ('~':d) = do
   tilde <- io (getEnv "HOME")	-- will fail if HOME not defined
   io (setCurrentDirectory (tilde ++ '/':d))
551
changeDirectory d = io (setCurrentDirectory d)
552

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

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) 
588
	then throwDyn (CmdLineError
589 590 591
		("command `" ++ macro_name ++ "' cannot be undefined"))
	else do
  if (macro_name `notElem` map fst cmds) 
592
	then throwDyn (CmdLineError 
593 594 595 596
		("command `" ++ macro_name ++ "' not defined"))
	else do
  io (writeIORef commands (filter ((/= macro_name) . fst) cmds))

597

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

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

  -- 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
611
  cmstate1 <- io (cmUnload (cmstate state) dflags)
612
  setGHCiState state{ cmstate = cmstate1, targets = [] }
613 614 615

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

  setContextAfterLoad mods
619
  modulesLoadedMsg ok mods dflags
620

621

622 623 624
reloadModule :: String -> GHCi ()
reloadModule "" = do
  state <- getGHCiState
625
  dflags <- io getDynFlags
626 627
  case targets state of
   [] -> io (putStr "no current target\n")
628 629 630 631 632 633
   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.
634
	(cmstate1, ok, mods) 
635
		<- io (cmLoadModules (cmstate state) dflags graph)
636 637
        setGHCiState state{ cmstate=cmstate1 }
	setContextAfterLoad mods
638
	modulesLoadedMsg ok mods dflags
639

640 641
reloadModule _ = noArgs ":reload"

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

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


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

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

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

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

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

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

      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
730 731
	  TyData { tcdCons = DataCons cons } -> 
		rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
732 733
	  other -> other
        where
734
	  conIsVisible (ConDecl n _ _ _ _) = n `elem` thing_names
735 736 737 738 739 740 741

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

  where

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

setContext str
746 747 748 749 750 751 752 753
  | 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) 

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

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

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

772 773
prel = "Prelude"

774 775 776

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

780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801
  (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'
802

803 804 805 806 807 808 809 810 811 812
----------------------------------------------------------------------------
-- 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.

813 814
setCmd :: String -> GHCi ()
setCmd ""
815 816 817 818 819 820 821 822
  = 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)
   	   ))
823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841
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
842
      mapM_ setOpt plus_opts
843 844

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

      -- update things if the users wants more packages
850 851 852 853 854 855 856 857 858
      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 [])
859 860 861

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

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

871 872 873 874 875 876 877 878

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

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

sof's avatar
sof committed
883
       mapM_ unsetOpt plus_opts
884 885
 
       -- can't do GHC flags for now
886
       if (not (null minus_opts))
887
	  then throwDyn (CmdLineError "can't unset GHC command-line flags")
888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908
	  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
909
strToGHCiOpt "r" = Just RevertCAFs
910 911 912 913 914
strToGHCiOpt _   = Nothing

optToStr :: GHCiOption -> String
optToStr ShowTiming = "s"
optToStr ShowType   = "t"