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

14 15
#include "HsVersions.h"

mnislaih's avatar
mnislaih committed
16
import GhciMonad
17
import GhciTags
18
import Debugger
19

20 21
-- The GHC interface
import qualified GHC
22
import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
23
                          Type, Module, ModuleName, TyThing(..), Phase,
24
                          BreakIndex, Name, SrcSpan, Resume, SingleStep )
25 26 27 28
import DynFlags
import Packages
import PackageConfig
import UniqFM
29
import PprTyThing
30
import Outputable       hiding (printForUser)
31
import Module           -- for ModuleEnv
32 33

-- Other random utilities
34
import Digraph
mnislaih's avatar
mnislaih committed
35 36
import BasicTypes hiding (isTopLevel)
import Panic      hiding (showException)
37
import Config
38 39 40
import StaticFlags
import Linker
import Util
41
import FastString
42

43
#ifndef mingw32_HOST_OS
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
#else
import GHC.ConsoleHandler ( flushConsole )
50
import System.Win32	  ( setConsoleCP, setConsoleOutputCP )
51
import qualified System.Win32
sof's avatar
sof committed
52 53
#endif

54
#ifdef USE_READLINE
55
import Control.Concurrent	( yield )	-- Used in readline loop
56
import System.Console.Readline as Readline
57
#endif
58 59 60 61

--import SystemExts

import Control.Exception as Exception
62
-- import Control.Concurrent
63

Simon Marlow's avatar
Simon Marlow committed
64
import qualified Data.ByteString.Char8 as BS
65
import Data.List
66
import Data.Maybe
67 68
import System.Cmd
import System.Environment
69
import System.Exit	( exitWith, ExitCode(..) )
70
import System.Directory
ross's avatar
ross committed
71 72
import System.IO
import System.IO.Error as IO
73
import Data.Char
mnislaih's avatar
mnislaih committed
74
import Data.Dynamic
75
import Data.Array
76
import Control.Monad as Monad
Simon Marlow's avatar
Simon Marlow committed
77
import Text.Printf
78

79
import Foreign.StablePtr	( newStablePtr )
80
import GHC.Exts		( unsafeCoerce# )
Simon Marlow's avatar
Simon Marlow committed
81
import GHC.IOBase	( IOErrorType(InvalidArgument) )
82

83
import Data.IORef	( IORef, readIORef, writeIORef )
84

85
import System.Posix.Internals ( setNonBlockingFD )
86

87 88
-----------------------------------------------------------------------------

89 90 91
ghciWelcomeMsg =
 "   ___         ___ _\n"++
 "  / _ \\ /\\  /\\/ __(_)\n"++
92 93 94
 " / /_\\// /_/ / /  | |    GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
 "/ /_\\\\/ __  / /___| |    http://www.haskell.org/ghc/\n"++
 "\\____/\\/ /_/\\____/|_|    Type :? for help.\n"
95

96 97
type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
cmdName (n,_,_,_) = n
98

Simon Marlow's avatar
Simon Marlow committed
99 100 101
GLOBAL_VAR(commands, builtin_commands, [Command])

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

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

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

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

150 151 152
helpText =
 " Commands available from the prompt:\n" ++
 "\n" ++
153
 "   <statement>                 evaluate/run <statement>\n" ++
154 155 156
 "   :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" ++
Simon Marlow's avatar
Simon Marlow committed
157
 "   :ctags [<file>]             create tags file for Vi (default: \"tags\")\n" ++
158
 "   :def <cmd> <expr>           define a command :<cmd>\n" ++
Simon Marlow's avatar
Simon Marlow committed
159 160
 "   :edit <file>                edit file\n" ++
 "   :edit                       edit last module\n" ++
Simon Marlow's avatar
Simon Marlow committed
161
 "   :etags [<file>]             create tags file for Emacs (default: \"TAGS\")\n" ++
162 163
 "   :help, :?                   display this list of commands\n" ++
 "   :info [<name> ...]          display information about the given names\n" ++
Simon Marlow's avatar
Simon Marlow committed
164
 "   :kind <type>                show the kind of <type>\n" ++
165 166
 "   :load <filename> ...        load module(s) and their dependents\n" ++
 "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
167
 "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
Simon Marlow's avatar
Simon Marlow committed
168
 "   :quit                       exit GHCi\n" ++
169
 "   :reload                     reload the current module set\n" ++
170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194
 "   :type <expr>                show the type of <expr>\n" ++
 "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
 "   :!<command>                 run the shell command <command>\n" ++
 "\n" ++
 " -- Commands for debugging:\n" ++
 "\n" ++
 "   :abandon                    at a breakpoint, abandon current computation\n" ++
 "   :back                       go back in the history (after :trace)\n" ++
 "   :break [<mod>] <l> [<col>]  set a breakpoint at the specified location\n" ++
 "   :break <name>               set a breakpoint on the specified function\n" ++
 "   :continue                   resume after a breakpoint\n" ++
 "   :delete <number>            delete the specified breakpoint\n" ++
 "   :delete *                   delete all breakpoints\n" ++
 "   :force <expr>               print <expr>, forcing unevaluated parts\n" ++
 "   :forward                    go forward in the history (after :back)\n" ++
 "   :history [<n>]              show the last <n> items in the history (after :trace)\n" ++
 "   :print [<name> ...]         prints a value without forcing its computation\n" ++
 "   :step                       single-step after stopping at a breakpoint\n"++
 "   :step <expr>                single-step into <expr>\n"++
 "   :trace                      trace after stopping at a breakpoint\n"++
 "   :trace <expr>               trace into <expr> (remembers breakpoints for :history)\n"++
 "   :sprint [<name> ...]        simplifed version of :print\n" ++

 "\n" ++
 " -- Commands for changing settings:\n" ++
195 196 197 198
 "\n" ++
 "   :set <option> ...           set options\n" ++
 "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
 "   :set prog <progname>        set the value returned by System.getProgName\n" ++
Simon Marlow's avatar
Simon Marlow committed
199
 "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
Ian Lynagh's avatar
Ian Lynagh committed
200
 "   :set editor <cmd>           set the command used for :edit\n" ++
Simon Marlow's avatar
Simon Marlow committed
201
 "   :set stop <cmd>             set the command to run when a breakpoint is hit\n" ++
202 203
 "   :unset <option> ...         unset options\n" ++
 "\n" ++
204
 "  Options for ':set' and ':unset':\n" ++
205 206 207 208 209
 "\n" ++
 "    +r            revert top-level expressions after each evaluation\n" ++
 "    +s            print timing/memory stats after each evaluation\n" ++
 "    +t            print type after evaluation\n" ++
 "    -<flags>      most GHC command line flags can also be set here\n" ++
mnislaih's avatar
mnislaih committed
210
 "                         (eg. -v2, -fglasgow-exts, etc.)\n" ++
211 212 213 214 215 216 217 218
 "\n" ++
 " -- Commands for displaying information:\n" ++
 "\n" ++
 "   :show bindings              show the current bindings made at the prompt\n" ++
 "   :show breaks                show the active breakpoints\n" ++
 "   :show context               show the breakpoint context\n" ++
 "   :show modules               show the currently loaded modules\n" ++
 "   :show <setting>             show anything that can be set with :set (e.g. args)\n" ++
219
 "\n" 
220

Simon Marlow's avatar
Simon Marlow committed
221 222 223
findEditor = do
  getEnv "EDITOR" 
    `IO.catch` \_ -> do
224 225
#if mingw32_HOST_OS
	win <- System.Win32.getWindowsDirectory
Simon Marlow's avatar
Simon Marlow committed
226
	return (win `joinFileName` "notepad.exe")
Simon Marlow's avatar
Simon Marlow committed
227 228 229 230
#else
	return ""
#endif

231
interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
232
interactiveUI session srcs maybe_expr = do
233 234 235 236 237 238 239 240 241 242 243 244
   -- 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

245
	-- Initialise buffering for the *interpreted* I/O system
246
   initInterpBuffering session
247

248 249 250 251 252 253 254
   when (isNothing maybe_expr) $ do
	-- Only for GHCi (not runghc and ghc -e):
	-- Turn buffering off for the compiled program's stdout/stderr
	turnOffBuffering
	-- Turn buffering off for GHCi's stdout
	hFlush stdout
	hSetBuffering stdout NoBuffering
255 256
	-- We don't want the cmd line to buffer any input that might be
	-- intended for the program, so unbuffer stdin.
257
	hSetBuffering stdin NoBuffering
258

259
	-- initial context is just the Prelude
260
   prel_mod <- GHC.findModule session prel_name (Just basePackageId)
Simon Marlow's avatar
Simon Marlow committed
261
   GHC.setContext session [] [prel_mod]
262

263
#ifdef USE_READLINE
264
   Readline.initialize
Simon Marlow's avatar
Simon Marlow committed
265 266 267 268 269 270 271 272 273 274
   Readline.setAttemptedCompletionFunction (Just completeWord)
   --Readline.parseAndBind "set show-all-if-ambiguous 1"

   let symbols = "!#$%&*+/<=>?@\\^|-~"
       specials = "(),;[]`{}"
       spaces = " \t\n"
       word_break_chars = spaces ++ specials ++ symbols

   Readline.setBasicWordBreakCharacters word_break_chars
   Readline.setCompleterWordBreakCharacters word_break_chars
275 276
#endif

Simon Marlow's avatar
Simon Marlow committed
277 278
   default_editor <- findEditor

279
   startGHCi (runGHCi srcs maybe_expr)
280 281
	GHCiState{ progname = "<interactive>",
		   args = [],
Simon Marlow's avatar
Simon Marlow committed
282
                   prompt = "%s> ",
Simon Marlow's avatar
Simon Marlow committed
283
                   stop = "",
Simon Marlow's avatar
Simon Marlow committed
284
		   editor = default_editor,
285
		   session = session,
Simon Marlow's avatar
Simon Marlow committed
286
		   options = [],
mnislaih's avatar
mnislaih committed
287
                   prelude = prel_mod,
288 289
                   break_ctr = 0,
                   breaks = [],
290 291
                   tickarrays = emptyModuleEnv,
                   cmdqueue = []
mnislaih's avatar
mnislaih committed
292
                 }
rrt's avatar
rrt committed
293

294
#ifdef USE_READLINE
rrt's avatar
rrt committed
295 296 297
   Readline.resetTerminal Nothing
#endif

298 299
   return ()

Simon Marlow's avatar
Simon Marlow committed
300 301
prel_name = GHC.mkModuleName "Prelude"

302
runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
303
runGHCi paths maybe_expr = do
304
  let read_dot_files = not opt_IgnoreDotGhci
305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333

  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
334

335
  -- Perform a :load for files given on the GHCi command line
336 337 338 339 340 341 342
  -- When in -e mode, if the load fails then we want to stop
  -- immediately rather than going on to evaluate the expression.
  when (not (null paths)) $ do
     ok <- ghciHandle (\e -> do showException e; return Failed) $ 
		loadModule paths
     when (isJust maybe_expr && failed ok) $
	io (exitWith (ExitFailure 1))
343

344 345
  -- if verbosity is greater than 0, or we are connected to a
  -- terminal, display the prompt in the interactive loop.
346
  is_tty <- io (hIsTerminalDevice stdin)
347
  dflags <- getDynFlags
348 349
  let show_prompt = verbosity dflags > 0 || is_tty

350 351
  case maybe_expr of
	Nothing -> 
sof's avatar
sof committed
352
          do
Simon Marlow's avatar
Simon Marlow committed
353
#if defined(mingw32_HOST_OS)
sof's avatar
sof committed
354 355 356 357 358 359 360 361 362 363
            -- The win32 Console API mutates the first character of 
            -- type-ahead when reading from it in a non-buffered manner. Work
            -- around this by flushing the input buffer of type-ahead characters,
            -- but only if stdin is available.
            flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
            case flushed of 
   	     Left err | isDoesNotExistError err -> return ()
   		      | otherwise -> io (ioError err)
   	     Right () -> return ()
#endif
364 365 366
	    -- initialise the console if necessary
	    io setUpConsole

367 368 369 370
	    -- enter the interactive loop
	    interactiveLoop is_tty show_prompt
	Just expr -> do
	    -- just evaluate the expression we were given
371
	    runCommandEval expr
372
	    return ()
373 374

  -- and finally, exit
375
  io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
376 377


378
interactiveLoop is_tty show_prompt =
379
  -- Ignore ^C exceptions caught here
380
  ghciHandleDyn (\e -> case e of 
381
			Interrupted -> do
sof's avatar
sof committed
382
#if defined(mingw32_HOST_OS)
383
				io (putStrLn "")
sof's avatar
sof committed
384
#endif
385 386 387 388 389
				interactiveLoop is_tty show_prompt
			_other      -> return ()) $ 

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

391
  -- read commands from stdin
392
#ifdef USE_READLINE
393
  if (is_tty) 
394
	then readlineLoop
395
	else fileLoop stdin show_prompt
396
#else
397
  fileLoop stdin show_prompt
398
#endif
399 400


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

rrt's avatar
rrt committed
405 406 407 408
-- 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.
409 410 411

checkPerms :: String -> IO Bool
checkPerms name =
412
#ifdef mingw32_HOST_OS
413
  return True
sof's avatar
sof committed
414
#else
415
  Util.handle (\_ -> return False) $ do
416 417 418 419 420 421 422 423 424 425 426 427 428 429
     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
430
#endif
431

432
fileLoop :: Handle -> Bool -> GHCi ()
Simon Marlow's avatar
Simon Marlow committed
433
fileLoop hdl show_prompt = do
434 435 436
   when show_prompt $ do
        prompt <- mkPrompt
        (io (putStr prompt))
437 438
   l <- io (IO.try (hGetLine hdl))
   case l of
439 440 441 442 443 444 445 446
	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.
447
	Right l -> 
448
	  case removeSpaces l of
Simon Marlow's avatar
Simon Marlow committed
449
            "" -> fileLoop hdl show_prompt
450
	    l  -> do quit <- runCommands l
Simon Marlow's avatar
Simon Marlow committed
451
                     if quit then return () else fileLoop hdl show_prompt
452

453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474
mkPrompt = do
  session <- getSession
  (toplevs,exports) <- io (GHC.getContext session)
  resumes <- io $ GHC.getResumeContext session

  context_bit <-
        case resumes of
            [] -> return empty
            r:rs -> do
                let ix = GHC.resumeHistoryIx r
                if ix == 0
                   then return (brackets (ppr (GHC.resumeSpan r)) <> space)
                   else do
                        let hist = GHC.resumeHistory r !! (ix-1)
                        span <- io $ GHC.getHistorySpan session hist
                        return (brackets (ppr (negate ix) <> char ':' 
                                          <+> ppr span) <> space)
  let
        dots | r:rs <- resumes, not (null rs) = text "... "
             | otherwise = empty

        modules_bit = 
475 476 477
             hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
             hsep (map (ppr . GHC.moduleName) exports)

478 479 480 481 482 483 484 485 486
        deflt_prompt = dots <> context_bit <> modules_bit

        f ('%':'s':xs) = deflt_prompt <> f xs
        f ('%':'%':xs) = char '%' <> f xs
        f (x:xs) = char x <> f xs
        f [] = empty
   --
  st <- getGHCiState
  return (showSDoc (f (prompt st)))
487

488

489
#ifdef USE_READLINE
490 491
readlineLoop :: GHCi ()
readlineLoop = do
492 493
   session <- getSession
   (mod,imports) <- io (GHC.getContext session)
494
   io yield
Simon Marlow's avatar
Simon Marlow committed
495
   saveSession -- for use by completion
Simon Marlow's avatar
Simon Marlow committed
496
   st <- getGHCiState
497 498 499
   mb_span <- getCurrentBreakSpan
   prompt <- mkPrompt
   l <- io (readline prompt `finally` setNonBlockingFD 0)
500 501
		-- readline sometimes puts stdin into blocking mode,
		-- so we need to put it back for the IO library
Simon Marlow's avatar
Simon Marlow committed
502
   splatSavedSession
503 504 505
   case l of
	Nothing -> return ()
	Just l  ->
506
	  case removeSpaces l of
507 508 509
	    "" -> readlineLoop
	    l  -> do
        	  io (addHistory l)
510
  	  	  quit <- runCommands l
511 512
          	  if quit then return () else readlineLoop
#endif
513

514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534
runCommands :: String -> GHCi Bool
runCommands cmd = do
        q <- ghciHandle handler (doCommand cmd)
        if q then return True else runNext
  where
       runNext = do
          st <- getGHCiState
          case cmdqueue st of
            []   -> return False
            c:cs -> do setGHCiState st{ cmdqueue = cs }
                       runCommands c

       doCommand (':' : cmd) = specialCommand cmd
       doCommand stmt        = do timeIt $ runStmt stmt GHC.RunToCompletion
                                  return False

enqueueCommands :: [String] -> GHCi ()
enqueueCommands cmds = do
  st <- getGHCiState
  setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }

535

536 537 538 539 540 541
-- 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)
542
    handleEval e                    = do handler e
543 544
				         io (exitWith (ExitFailure 1))

545 546
    doCommand (':' : command) = specialCommand command
    doCommand stmt
547
       = do r <- runStmt stmt GHC.RunToCompletion
548 549
	    case r of 
		False -> io (exitWith (ExitFailure 1))
550
		  -- failure to run the command causes exit(1) for ghc -e.
551
		_       -> return True
552

553 554
runStmt :: String -> SingleStep -> GHCi Bool
runStmt stmt step
555
 | null (filter (not.isSpace) stmt) = return False
556
 | otherwise
557
 = do st <- getGHCiState
558 559
      session <- getSession
      result <- io $ withProgName (progname st) $ withArgs (args st) $
560
	     	     GHC.runStmt session stmt step
561
      afterRunStmt result
562

563

Simon Marlow's avatar
Simon Marlow committed
564 565 566
afterRunStmt :: GHC.RunResult -> GHCi Bool
                                 -- False <=> the statement failed to compile
afterRunStmt (GHC.RunException e) = throw e
567 568
afterRunStmt run_result = do
  session <- getSession
Simon Marlow's avatar
Simon Marlow committed
569 570 571 572
  case run_result of
     GHC.RunOk names -> do
        show_types <- isOptionSet ShowType
        when show_types $ mapM_ (showTypeOfName session) names
573
     GHC.RunBreak _ names mb_info -> do
Simon Marlow's avatar
Simon Marlow committed
574 575 576 577
        resumes <- io $ GHC.getResumeContext session
        printForUser $ ptext SLIT("Stopped at") <+> 
                       ppr (GHC.resumeSpan (head resumes))
        mapM_ (showTypeOfName session) names
578
        maybe (return ()) runBreakCmd mb_info
Simon Marlow's avatar
Simon Marlow committed
579 580
        -- run the command set with ":set stop <cmd>"
        st <- getGHCiState
581
        enqueueCommands [stop st]
Simon Marlow's avatar
Simon Marlow committed
582 583 584
        return ()
     _ -> return ()

585 586 587 588 589
  flushInterpBuffers
  io installSignalHandlers
  b <- isOptionSet RevertCAFs
  io (when b revertCAFs)

Simon Marlow's avatar
Simon Marlow committed
590
  return (case run_result of GHC.RunOk _ -> True; _ -> False)
591

592 593 594 595 596 597 598 599 600 601 602
runBreakCmd :: GHC.BreakInfo -> GHCi ()
runBreakCmd info = do
  let mod = GHC.breakInfo_module info
      nm  = GHC.breakInfo_number info
  st <- getGHCiState
  case  [ loc | (i,loc) <- breaks st,
                breakModule loc == mod, breakTick loc == nm ] of
        []  -> return ()
        loc:_ | null cmd  -> return ()
              | otherwise -> do enqueueCommands [cmd]; return ()
              where cmd = onBreakCmd loc
603

604 605 606 607 608 609 610
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

611
specialCommand :: String -> GHCi Bool
612
specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
613 614
specialCommand str = do
  let (cmd,rest) = break isSpace str
Simon Marlow's avatar
Simon Marlow committed
615 616 617
  maybe_cmd <- io (lookupCommand cmd)
  case maybe_cmd of
    Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n" 
618
		                    ++ shortHelpText) >> return False)
619
    Just (_,f,_,_) -> f (dropWhile isSpace rest)
Simon Marlow's avatar
Simon Marlow committed
620 621 622 623 624 625 626

lookupCommand :: String -> IO (Maybe Command)
lookupCommand str = do
  cmds <- readIORef commands
  -- look for exact match first, then the first prefix match
  case [ c | c <- cmds, str == cmdName c ] of
     c:_ -> return (Just c)
627
     [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
Simon Marlow's avatar
Simon Marlow committed
628 629
     		[] -> return Nothing
     		c:_ -> return (Just c)
630

631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646

getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
getCurrentBreakSpan = do
  session <- getSession
  resumes <- io $ GHC.getResumeContext session
  case resumes of
    [] -> return Nothing
    (r:rs) -> do
        let ix = GHC.resumeHistoryIx r
        if ix == 0
           then return (Just (GHC.resumeSpan r))
           else do
                let hist = GHC.resumeHistory r !! (ix-1)
                span <- io $ GHC.getHistorySpan session hist
                return (Just span)

647 648 649
-----------------------------------------------------------------------------
-- Commands

650 651 652 653
noArgs :: GHCi () -> String -> GHCi ()
noArgs m "" = m
noArgs m _ = io $ putStrLn "This command takes no arguments"

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

rrt's avatar
rrt committed
657
info :: String -> GHCi ()
658
info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
659
info s  = do { let names = words s
660
	     ; session <- getSession
661 662
	     ; dflags <- getDynFlags
	     ; let exts = dopt Opt_GlasgowExts dflags
663
	     ; mapM_ (infoThing exts session) names }
664
  where
665 666 667 668 669 670 671 672 673 674 675 676 677 678 679
    infoThing exts session str = io $ do
	names <- GHC.parseName session str
	let filtered = filterOutChildren names
	mb_stuffs <- mapM (GHC.getInfo session) filtered
	unqual <- GHC.getPrintUnqual session
	putStrLn (showSDocForUser unqual $
     		   vcat (intersperse (text "") $
		   [ pprInfo exts stuff | Just stuff <-  mb_stuffs ]))

  -- Filter out names whose parent is also there Good
  -- example is '[]', which is both a type and data
  -- constructor in the same type
filterOutChildren :: [Name] -> [Name]
filterOutChildren names = filter (not . parent_is_there) names
 where parent_is_there n 
680 681
--	 | Just p <- GHC.nameParent_maybe n = p `elem` names
-- ToDo!!
682 683 684
	 | otherwise		           = False

pprInfo exts (thing, fixity, insts)
685
  =  pprTyThingInContextLoc exts thing 
686 687
  $$ show_fixity fixity
  $$ vcat (map GHC.pprInstance insts)
688
  where
689
    show_fixity fix 
690 691
	| fix == GHC.defaultFixity = empty
	| otherwise		   = ppr fix <+> ppr (GHC.getName thing)
692

693 694 695
runMain :: String -> GHCi ()
runMain args = do
  let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
696
  enqueueCommands  ['[': ss ++ "] `System.Environment.withArgs` main"]
697

sof's avatar
sof committed
698 699
addModule :: [FilePath] -> GHCi ()
addModule files = do
700
  io (revertCAFs)			-- always revert CAFs on load/add.
701
  files <- mapM expandPath files
702
  targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
703 704
  session <- getSession
  io (mapM_ (GHC.addTarget session) targets)
705
  ok <- io (GHC.load session LoadAllTargets)
706
  afterLoad ok session
707

708
changeDirectory :: String -> GHCi ()
709
changeDirectory dir = do
710 711 712
  session <- getSession
  graph <- io (GHC.getModuleGraph session)
  when (not (null graph)) $
713
	io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
714
  io (GHC.setTargets session [])
715
  io (GHC.load session LoadAllTargets)
716
  setContextAfterLoad session []
717
  io (GHC.workingDirectoryChanged session)
718 719
  dir <- expandPath dir
  io (setCurrentDirectory dir)
720

Simon Marlow's avatar
Simon Marlow committed
721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741
editFile :: String -> GHCi ()
editFile str
  | null str  = do
	-- find the name of the "topmost" file loaded
     session <- getSession
     graph0 <- io (GHC.getModuleGraph session)
     graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
     let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
     case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
	Just file -> do_edit file
	Nothing   -> throwDyn (CmdLineError "unknown file name")
  | otherwise = do_edit str
  where
	do_edit file = do
	   st <- getGHCiState
	   let cmd = editor st
	   when (null cmd) $ 
		throwDyn (CmdLineError "editor not set, use :set editor")
	   io $ system (cmd ++ ' ':file)
           return ()

742 743 744 745 746
defineMacro :: String -> GHCi ()
defineMacro s = do
  let (macro_name, definition) = break isSpace s
  cmds <- io (readIORef commands)
  if (null macro_name) 
747
	then throwDyn (CmdLineError "invalid macro name") 
748
	else do
Simon Marlow's avatar
Simon Marlow committed
749
  if (macro_name `elem` map cmdName cmds)
750
	then throwDyn (CmdLineError 
751
		("command '" ++ macro_name ++ "' is already defined"))
752 753 754 755 756 757 758
	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
759 760
  cms <- getSession
  maybe_hv <- io (GHC.compileExpr cms new_expr)
761
  case maybe_hv of
762 763
     Nothing -> return ()
     Just hv -> io (writeIORef commands --
764
		    (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
765

766
runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
767 768
runMacro fun s = do
  str <- io ((unsafeCoerce# fun :: String -> IO String) s)
769 770
  enqueueCommands (lines str)
  return False
771 772 773 774

undefineMacro :: String -> GHCi ()
undefineMacro macro_name = do
  cmds <- io (readIORef commands)
Simon Marlow's avatar
Simon Marlow committed
775
  if (macro_name `elem` map cmdName builtin_commands) 
776
	then throwDyn (CmdLineError
777
		("command '" ++ macro_name ++ "' cannot be undefined"))
778
	else do
Simon Marlow's avatar
Simon Marlow committed
779
  if (macro_name `notElem` map cmdName cmds) 
780
	then throwDyn (CmdLineError 
781
		("command '" ++ macro_name ++ "' not defined"))
782
	else do
Simon Marlow's avatar
Simon Marlow committed
783
  io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
784

785

786
loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
sof's avatar
sof committed
787
loadModule fs = timeIt (loadModule' fs)
788

789
loadModule_ :: [FilePath] -> GHCi ()
790
loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
791

792
loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
sof's avatar
sof committed
793
loadModule' files = do
794 795 796
  session <- getSession

  -- unload first
797
  discardActiveBreakPoints
798
  io (GHC.setTargets session [])
799
  io (GHC.load session LoadAllTargets)
800

801
  -- expand tildes
802 803 804 805
  let (filenames, phases) = unzip files
  exp_filenames <- mapM expandPath filenames
  let files' = zip exp_filenames phases
  targets <- io (mapM (uncurry GHC.guessTarget) files')
806

807 808 809 810
  -- 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.
811

812
  io (GHC.setTargets session targets)
813
  doLoad session LoadAllTargets
814

815 816
checkModule :: String -> GHCi ()
checkModule m = do
Simon Marlow's avatar
Simon Marlow committed
817
  let modl = GHC.mkModuleName m
simonmar's avatar