InteractiveUI.hs 87.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

10
module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
11

12
13
#include "HsVersions.h"

mnislaih's avatar
mnislaih committed
14
import GhciMonad
15
import GhciTags
16
import Debugger
17

18
19
-- The GHC interface
import qualified GHC
20
import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
Simon Marlow's avatar
Simon Marlow committed
21
                          Module, ModuleName, TyThing(..), Phase,
22
                          BreakIndex, SrcSpan, Resume, SingleStep )
23
import PprTyThing
24
import DynFlags
25

26
import Packages
Ian Lynagh's avatar
Ian Lynagh committed
27
#ifdef USE_EDITLINE
28
29
import PackageConfig
import UniqFM
30
31
#endif

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
32
import HscTypes		( implicitTyThings )
33
import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
34
import Outputable       hiding (printForUser, printForUserPartWay)
35
import Module           -- for ModuleEnv
36
import Name
37
import SrcLoc
38
39

-- Other random utilities
40
import Digraph
mnislaih's avatar
mnislaih committed
41
42
import BasicTypes hiding (isTopLevel)
import Panic      hiding (showException)
43
import Config
44
45
46
import StaticFlags
import Linker
import Util
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
47
48
import NameSet
import Maybes		( orElse )
49
import FastString
50
import Encoding
51

52
#ifndef mingw32_HOST_OS
53
import System.Posix hiding (getEnv)
sof's avatar
sof committed
54
55
#else
import GHC.ConsoleHandler ( flushConsole )
56
import qualified System.Win32
sof's avatar
sof committed
57
58
#endif

Ian Lynagh's avatar
Ian Lynagh committed
59
#ifdef USE_EDITLINE
60
import Control.Concurrent	( yield )	-- Used in readline loop
Ian Lynagh's avatar
Ian Lynagh committed
61
import System.Console.Editline.Readline as Readline
62
#endif
63
64
65
66

--import SystemExts

import Control.Exception as Exception
67
-- import Control.Concurrent
68

69
import System.FilePath
Simon Marlow's avatar
Simon Marlow committed
70
import qualified Data.ByteString.Char8 as BS
71
import Data.List
72
import Data.Maybe
73
74
import System.Cmd
import System.Environment
75
import System.Exit	( exitWith, ExitCode(..) )
76
import System.Directory
ross's avatar
ross committed
77
78
import System.IO
import System.IO.Error as IO
79
import Data.Char
mnislaih's avatar
mnislaih committed
80
import Data.Dynamic
81
import Data.Array
82
import Control.Monad as Monad
Simon Marlow's avatar
Simon Marlow committed
83
import Text.Printf
84
import Foreign
Ian Lynagh's avatar
Ian Lynagh committed
85
import Foreign.C
86
import GHC.Exts		( unsafeCoerce# )
Simon Marlow's avatar
Simon Marlow committed
87
import GHC.IOBase	( IOErrorType(InvalidArgument) )
Ian Lynagh's avatar
Ian Lynagh committed
88
import GHC.TopHandler
89

90
import Data.IORef	( IORef, readIORef, writeIORef )
91

Ian Lynagh's avatar
Ian Lynagh committed
92
#ifdef USE_EDITLINE
93
import System.Posix.Internals ( setNonBlockingFD )
94
#endif
95

96
97
-----------------------------------------------------------------------------

98
99
100
ghciWelcomeMsg :: String
ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
                 ": http://www.haskell.org/ghc/  :? for help"
101

Simon Marlow's avatar
Simon Marlow committed
102
cmdName :: Command -> String
103
cmdName (n,_,_,_) = n
104

Simon Marlow's avatar
Simon Marlow committed
105
GLOBAL_VAR(macros_ref, [], [Command])
Simon Marlow's avatar
Simon Marlow committed
106
107

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

154
155
156
157
158
159
160
161
162

-- We initialize readline (in the interactiveUI function) to use 
-- word_break_chars as the default set of completion word break characters.
-- This can be overridden for a particular command (for example, filename
-- expansion shouldn't consider '/' to be a word break) by setting the third
-- entry in the Command tuple above.
-- 
-- NOTE: in order for us to override the default correctly, any custom entry
-- must be a SUBSET of word_break_chars.
Ian Lynagh's avatar
Ian Lynagh committed
163
#ifdef USE_EDITLINE
164
word_break_chars :: String
165
166
167
168
word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
                       specials = "(),;[]`{}"
                       spaces = " \t\n"
                   in spaces ++ specials ++ symbols
169
170
171
#endif

flagWordBreakChars, filenameWordBreakChars :: String
172
173
174
175
flagWordBreakChars = " \t\n"
filenameWordBreakChars = " \t\n\\`@$><=;|&{(" -- bash defaults


176
177
178
keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
keepGoing a str = a str >> return False

sof's avatar
sof committed
179
keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
Ian Lynagh's avatar
Ian Lynagh committed
180
181
182
183
184
keepGoingPaths a str
 = do case toArgs str of
          Left err -> io (hPutStrLn stderr err)
          Right args -> a args
      return False
sof's avatar
sof committed
185

Simon Marlow's avatar
Simon Marlow committed
186
shortHelpText :: String
187
188
shortHelpText = "use :? for help.\n"

Simon Marlow's avatar
Simon Marlow committed
189
helpText :: String
190
191
192
helpText =
 " Commands available from the prompt:\n" ++
 "\n" ++
193
 "   <statement>                 evaluate/run <statement>\n" ++
194
 "   :                           repeat last command\n" ++
195
 "   :{\\n ..lines.. \\n:}\\n       multiline command\n" ++
196
 "   :add <filename> ...         add module(s) to the current target set\n" ++
197
198
 "   :browse[!] [[*]<mod>]       display the names defined by module <mod>\n" ++
 "                               (!: more details; *: all top-level names)\n" ++
199
 "   :cd <dir>                   change directory to <dir>\n" ++
200
 "   :cmd <expr>                 run the commands returned by <expr>::IO String\n" ++
Simon Marlow's avatar
Simon Marlow committed
201
 "   :ctags [<file>]             create tags file for Vi (default: \"tags\")\n" ++
202
 "   :def <cmd> <expr>           define a command :<cmd>\n" ++
Simon Marlow's avatar
Simon Marlow committed
203
204
 "   :edit <file>                edit file\n" ++
 "   :edit                       edit last module\n" ++
Simon Marlow's avatar
Simon Marlow committed
205
 "   :etags [<file>]             create tags file for Emacs (default: \"TAGS\")\n" ++
206
207
 "   :help, :?                   display this list of commands\n" ++
 "   :info [<name> ...]          display information about the given names\n" ++
Simon Marlow's avatar
Simon Marlow committed
208
 "   :kind <type>                show the kind of <type>\n" ++
209
 "   :load <filename> ...        load module(s) and their dependents\n" ++
210
 "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
211
 "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
Simon Marlow's avatar
Simon Marlow committed
212
 "   :quit                       exit GHCi\n" ++
213
 "   :reload                     reload the current module set\n" ++
Ian Lynagh's avatar
Ian Lynagh committed
214
 "   :run function [<arguments> ...] run the function with the given arguments\n" ++
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
 "   :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" ++
230
 "   :history [<n>]              after :trace, show the execution history\n" ++
231
 "   :print [<name> ...]         prints a value without forcing its computation\n" ++
Simon Marlow's avatar
Simon Marlow committed
232
 "   :sprint [<name> ...]        simplifed version of :print\n" ++
233
234
 "   :step                       single-step after stopping at a breakpoint\n"++
 "   :step <expr>                single-step into <expr>\n"++
235
 "   :steplocal                  single-step within the current top-level binding\n"++
236
 "   :stepmodule                 single-step restricted to the current module\n"++
237
 "   :trace                      trace after stopping at a breakpoint\n"++
238
 "   :trace <expr>               evaluate <expr> with tracing on (see :history)\n"++
239
240
241

 "\n" ++
 " -- Commands for changing settings:\n" ++
242
243
244
245
 "\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
246
 "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
Ian Lynagh's avatar
Ian Lynagh committed
247
 "   :set editor <cmd>           set the command used for :edit\n" ++
Simon Marlow's avatar
Simon Marlow committed
248
 "   :set stop <cmd>             set the command to run when a breakpoint is hit\n" ++
249
250
 "   :unset <option> ...         unset options\n" ++
 "\n" ++
251
 "  Options for ':set' and ':unset':\n" ++
252
253
254
255
256
 "\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
257
 "                         (eg. -v2, -fglasgow-exts, etc.)\n" ++
258
259
 "                    for GHCi-specific flags, see User's Guide,\n"++
 "                    Flag reference, Interactive-mode options\n" ++
260
261
262
263
264
265
266
 "\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" ++
267
268
 "   :show packages              show the currently active package flags\n" ++
 "   :show languages             show the currently active language flags\n" ++
269
270
 "   :show <setting>             show value of <setting>, which is one of\n" ++
 "                                  [args, prog, prompt, editor, stop]\n" ++
271
 "\n" 
272

Simon Marlow's avatar
Simon Marlow committed
273
findEditor :: IO String
Simon Marlow's avatar
Simon Marlow committed
274
275
276
findEditor = do
  getEnv "EDITOR" 
    `IO.catch` \_ -> do
277
#if mingw32_HOST_OS
Ian Lynagh's avatar
Ian Lynagh committed
278
279
        win <- System.Win32.getWindowsDirectory
        return (win </> "notepad.exe")
Simon Marlow's avatar
Simon Marlow committed
280
#else
Ian Lynagh's avatar
Ian Lynagh committed
281
        return ""
Simon Marlow's avatar
Simon Marlow committed
282
283
#endif

Ian Lynagh's avatar
Ian Lynagh committed
284
285
286
interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe [String]
              -> IO ()
interactiveUI session srcs maybe_exprs = do
287
288
289
290
291
292
293
294
295
296
297
298
   -- 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

Ian Lynagh's avatar
Ian Lynagh committed
299
    -- Initialise buffering for the *interpreted* I/O system
300
   initInterpBuffering session
301

Ian Lynagh's avatar
Ian Lynagh committed
302
   when (isNothing maybe_exprs) $ do
Ian Lynagh's avatar
Ian Lynagh committed
303
304
305
306
307
308
309
310
311
312
313
        -- 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
        -- We don't want the cmd line to buffer any input that might be
        -- intended for the program, so unbuffer stdin.
        hSetBuffering stdin NoBuffering

Ian Lynagh's avatar
Ian Lynagh committed
314
#ifdef USE_EDITLINE
315
316
317
        is_tty <- hIsTerminalDevice stdin
        when is_tty $ do
            Readline.initialize
318
319
320

            withGhcAppData
                 (\dir -> Readline.readHistory (dir </> "ghci_history"))
Ian Lynagh's avatar
Ian Lynagh committed
321
                 (return True)
322
            
323
324
325
326
327
328
            Readline.setAttemptedCompletionFunction (Just completeWord)
            --Readline.parseAndBind "set show-all-if-ambiguous 1"

            Readline.setBasicWordBreakCharacters word_break_chars
            Readline.setCompleterWordBreakCharacters word_break_chars
            Readline.setCompletionAppendCharacter Nothing
329
330
#endif

331
332
333
334
335
   -- initial context is just the Prelude
   prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude") 
                                      (Just basePackageId)
   GHC.setContext session [] [prel_mod]

Simon Marlow's avatar
Simon Marlow committed
336
337
   default_editor <- findEditor

Ian Lynagh's avatar
Ian Lynagh committed
338
   startGHCi (runGHCi srcs maybe_exprs)
Ian Lynagh's avatar
Ian Lynagh committed
339
340
        GHCiState{ progname = "<interactive>",
                   args = [],
Simon Marlow's avatar
Simon Marlow committed
341
                   prompt = "%s> ",
Simon Marlow's avatar
Simon Marlow committed
342
                   stop = "",
Ian Lynagh's avatar
Ian Lynagh committed
343
344
345
                   editor = default_editor,
                   session = session,
                   options = [],
mnislaih's avatar
mnislaih committed
346
                   prelude = prel_mod,
347
348
                   break_ctr = 0,
                   breaks = [],
349
                   tickarrays = emptyModuleEnv,
350
                   last_command = Nothing,
Simon Marlow's avatar
Simon Marlow committed
351
                   cmdqueue = [],
352
                   remembered_ctx = []
mnislaih's avatar
mnislaih committed
353
                 }
rrt's avatar
rrt committed
354

Ian Lynagh's avatar
Ian Lynagh committed
355
#ifdef USE_EDITLINE
356
357
   Readline.stifleHistory 100
   withGhcAppData (\dir -> Readline.writeHistory (dir </> "ghci_history"))
Ian Lynagh's avatar
Ian Lynagh committed
358
                  (return True)
rrt's avatar
rrt committed
359
360
361
   Readline.resetTerminal Nothing
#endif

362
363
   return ()

364
365
366
367
368
369
370
371
withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
withGhcAppData right left = do
   either_dir <- IO.try (getAppUserDataDirectory "ghc")
   case either_dir of
      Right dir -> right dir
      _ -> left


Ian Lynagh's avatar
Ian Lynagh committed
372
373
runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
runGHCi paths maybe_exprs = do
374
375
  let 
   read_dot_files = not opt_IgnoreDotGhci
376

377
378
   current_dir = return (Just ".ghci")

379
380
381
   app_user_dir = io $ withGhcAppData 
                    (\dir -> return (Just (dir </> "ghci.conf")))
                    (return Nothing)
382
383
384
385
386
387
388
389
390
391
392
393
394

   home_dir = do
    either_dir <- io $ IO.try (getEnv "HOME")
    case either_dir of
      Right home -> return (Just (home </> ".ghci"))
      _ -> return Nothing

   sourceConfigFile :: FilePath -> GHCi ()
   sourceConfigFile file = do
     exists <- io $ doesFileExist file
     when exists $ do
       dir_ok  <- io $ checkPerms (getDirectory file)
       file_ok <- io $ checkPerms file
395
       when (dir_ok && file_ok) $ do
396
397
398
399
400
401
         either_hdl <- io $ IO.try (openFile file ReadMode)
         case either_hdl of
           Left _e   -> return ()
           Right hdl -> runCommands (fileLoop hdl False False)
     where
      getDirectory f = case takeDirectory f of "" -> "."; d -> d
Ian Lynagh's avatar
Ian Lynagh committed
402

403
  when (read_dot_files) $ do
404
405
406
407
408
    cfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
    cfgs <- io $ mapM canonicalizePath (catMaybes cfgs0)
    mapM_ sourceConfigFile (nub cfgs)
        -- nub, because we don't want to read .ghci twice if the
        -- CWD is $HOME.
409

410
  -- Perform a :load for files given on the GHCi command line
411
412
413
  -- 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
Ian Lynagh's avatar
Ian Lynagh committed
414
415
     ok <- ghciHandle (\e -> do showException e; return Failed) $
                loadModule paths
Ian Lynagh's avatar
Ian Lynagh committed
416
     when (isJust maybe_exprs && failed ok) $
Ian Lynagh's avatar
Ian Lynagh committed
417
        io (exitWith (ExitFailure 1))
418

419
420
  -- if verbosity is greater than 0, or we are connected to a
  -- terminal, display the prompt in the interactive loop.
421
  is_tty <- io (hIsTerminalDevice stdin)
422
  dflags <- getDynFlags
423
424
  let show_prompt = verbosity dflags > 0 || is_tty

Ian Lynagh's avatar
Ian Lynagh committed
425
  case maybe_exprs of
Ian Lynagh's avatar
Ian Lynagh committed
426
        Nothing ->
sof's avatar
sof committed
427
          do
Simon Marlow's avatar
Simon Marlow committed
428
#if defined(mingw32_HOST_OS)
Ian Lynagh's avatar
Ian Lynagh committed
429
            -- The win32 Console API mutates the first character of
sof's avatar
sof committed
430
431
432
433
            -- 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))
Ian Lynagh's avatar
Ian Lynagh committed
434
435
436
437
            case flushed of
             Left err | isDoesNotExistError err -> return ()
                      | otherwise -> io (ioError err)
             Right () -> return ()
sof's avatar
sof committed
438
#endif
Ian Lynagh's avatar
Ian Lynagh committed
439
440
            -- enter the interactive loop
            interactiveLoop is_tty show_prompt
Ian Lynagh's avatar
Ian Lynagh committed
441
        Just exprs -> do
Ian Lynagh's avatar
Ian Lynagh committed
442
            -- just evaluate the expression we were given
Ian Lynagh's avatar
Ian Lynagh committed
443
            enqueueCommands exprs
Ian Lynagh's avatar
Ian Lynagh committed
444
445
446
447
448
449
450
451
452
453
454
455
            let handle e = do st <- getGHCiState
                                   -- Jump through some hoops to get the
                                   -- current progname in the exception text:
                                   -- <progname>: <exception>
                              io $ withProgName (progname st)
                                   -- The "fast exit" part just calls exit()
                                   -- directly instead of doing an orderly
                                   -- runtime shutdown, otherwise the main
                                   -- GHCi thread will complain about being
                                   -- interrupted.
                                 $ topHandlerFastExit e
            runCommands' handle (return Nothing)
456
457

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

Simon Marlow's avatar
Simon Marlow committed
460
interactiveLoop :: Bool -> Bool -> GHCi ()
461
interactiveLoop is_tty show_prompt =
462
  -- Ignore ^C exceptions caught here
463
  ghciHandleDyn (\e -> case e of 
464
			Interrupted -> do
sof's avatar
sof committed
465
#if defined(mingw32_HOST_OS)
466
				io (putStrLn "")
sof's avatar
sof committed
467
#endif
468
469
470
471
472
				interactiveLoop is_tty show_prompt
			_other      -> return ()) $ 

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

474
  -- read commands from stdin
Ian Lynagh's avatar
Ian Lynagh committed
475
#ifdef USE_EDITLINE
476
  if (is_tty) 
477
	then runCommands readlineLoop
478
	else runCommands (fileLoop stdin show_prompt is_tty)
479
#else
480
  runCommands (fileLoop stdin show_prompt is_tty)
481
#endif
482
483


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

rrt's avatar
rrt committed
488
489
490
491
-- 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.
492
493

checkPerms :: String -> IO Bool
494
#ifdef mingw32_HOST_OS
Simon Marlow's avatar
Simon Marlow committed
495
checkPerms _ =
496
  return True
sof's avatar
sof committed
497
#else
Simon Marlow's avatar
Simon Marlow committed
498
checkPerms name =
499
  Util.handle (\_ -> return False) $ do
500
501
502
503
504
505
506
507
508
509
510
511
512
513
     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
514
#endif
515

516
517
fileLoop :: Handle -> Bool -> Bool -> GHCi (Maybe String)
fileLoop hdl show_prompt is_tty = do
518
519
520
   when show_prompt $ do
        prompt <- mkPrompt
        (io (putStr prompt))
521
522
   l <- io (IO.try (hGetLine hdl))
   case l of
523
524
525
526
527
528
529
530
        Left e | isEOFError e              -> return Nothing
               | InvalidArgument <- etype  -> return Nothing
               | 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.
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
        Right l -> do
                   str <- io $ consoleInputToUnicode is_tty l
                   return (Just str)

#ifdef mingw32_HOST_OS
-- Convert the console input into Unicode according to the current code page.
-- The Windows console stores Unicode characters directly, so this is a
-- rather roundabout way of doing things... oh well.
-- See #782, #1483, #1649
consoleInputToUnicode :: Bool -> String -> IO String
consoleInputToUnicode is_tty str
  | is_tty = do
    cp <- System.Win32.getConsoleCP
    System.Win32.stringToUnicode cp str
  | otherwise =
    decodeStringAsUTF8 str
#else
-- for Unix, assume the input is in UTF-8 and decode it to a Unicode String. 
-- See #782.
consoleInputToUnicode :: Bool -> String -> IO String
consoleInputToUnicode _is_tty str = decodeStringAsUTF8 str
#endif

decodeStringAsUTF8 :: String -> IO String
decodeStringAsUTF8 str =
  withCStringLen str $ \(cstr,len) -> 
    utf8DecodeString (castPtr cstr :: Ptr Word8) len
558

Simon Marlow's avatar
Simon Marlow committed
559
mkPrompt :: GHCi String
560
561
562
563
mkPrompt = do
  session <- getSession
  (toplevs,exports) <- io (GHC.getContext session)
  resumes <- io $ GHC.getResumeContext session
Simon Marlow's avatar
Simon Marlow committed
564
  -- st <- getGHCiState
565
566
567
568

  context_bit <-
        case resumes of
            [] -> return empty
Simon Marlow's avatar
Simon Marlow committed
569
            r:_ -> do
570
571
572
573
574
                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)
575
                        span <- io$ GHC.getHistorySpan session hist
576
577
578
                        return (brackets (ppr (negate ix) <> char ':' 
                                          <+> ppr span) <> space)
  let
Simon Marlow's avatar
Simon Marlow committed
579
        dots | _:rs <- resumes, not (null rs) = text "... "
580
581
             | otherwise = empty

Simon Marlow's avatar
Simon Marlow committed
582
583
        

584
        modules_bit = 
Simon Marlow's avatar
Simon Marlow committed
585
586
587
588
589
       -- ToDo: maybe...
       --  let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
       --  hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
       --  hsep (map (\m -> char '!'  <> ppr (GHC.moduleName m)) bexports) <+>
             hsep (map (\m -> char '*'  <> ppr (GHC.moduleName m)) toplevs) <+>
590
591
             hsep (map (ppr . GHC.moduleName) exports)

592
593
594
595
596
597
598
599
600
        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)))
601

602

Ian Lynagh's avatar
Ian Lynagh committed
603
#ifdef USE_EDITLINE
604
readlineLoop :: GHCi (Maybe String)
605
readlineLoop = do
606
   io yield
Simon Marlow's avatar
Simon Marlow committed
607
   saveSession -- for use by completion
608
609
   prompt <- mkPrompt
   l <- io (readline prompt `finally` setNonBlockingFD 0)
610
611
                -- 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
612
   splatSavedSession
613
   case l of
614
        Nothing -> return Nothing
615
        Just "" -> return (Just "") -- Don't put empty lines in the history
616
617
        Just l  -> do
                   io (addHistory l)
618
619
                   str <- io $ consoleInputToUnicode True l
                   return (Just str)
620
#endif
621

622
623
624
625
626
627
628
629
630
queryQueue :: GHCi (Maybe String)
queryQueue = do
  st <- getGHCiState
  case cmdqueue st of
    []   -> return Nothing
    c:cs -> do setGHCiState st{ cmdqueue = cs }
               return (Just c)

runCommands :: GHCi (Maybe String) -> GHCi ()
631
632
633
634
635
runCommands = runCommands' handler

runCommands' :: (Exception -> GHCi Bool) -- Exception handler
             -> GHCi (Maybe String) -> GHCi ()
runCommands' eh getCmd = do
636
637
638
639
640
  mb_cmd <- noSpace queryQueue
  mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
  case mb_cmd of 
    Nothing -> return ()
    Just c  -> do
641
      b <- ghciHandle eh (doCommand c)
642
      if b then return () else runCommands' eh getCmd
643
  where
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
    noSpace q = q >>= maybe (return Nothing)
                            (\c->case removeSpaces c of 
                                   ""   -> noSpace q
                                   ":{" -> multiLineCmd q
                                   c    -> return (Just c) )
    multiLineCmd q = do
      st <- getGHCiState
      let p = prompt st
      setGHCiState st{ prompt = "%s| " }
      mb_cmd <- collectCommand q ""
      getGHCiState >>= \st->setGHCiState st{ prompt = p }
      return mb_cmd
    -- we can't use removeSpaces for the sublines here, so 
    -- multiline commands are somewhat more brittle against
    -- fileformat errors (such as \r in dos input on unix), 
    -- we get rid of any extra spaces for the ":}" test; 
    -- we also avoid silent failure if ":}" is not found;
    -- and since there is no (?) valid occurrence of \r (as 
    -- opposed to its String representation, "\r") inside a
    -- ghci command, we replace any such with ' ' (argh:-(
    collectCommand q c = q >>= 
      maybe (io (ioError collectError))
            (\l->if removeSpaces l == ":}" 
                 then return (Just $ removeSpaces c) 
                 else collectCommand q (c++map normSpace l))
      where normSpace '\r' = ' '
            normSpace   c  = c
    -- QUESTION: is userError the one to use here?
    collectError = userError "unterminated multiline command :{ .. :}"
    doCommand (':' : cmd) = specialCommand cmd
    doCommand stmt        = do timeIt $ runStmt stmt GHC.RunToCompletion
                               return False
676
677
678
679
680
681

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

682

683
684
runStmt :: String -> SingleStep -> GHCi Bool
runStmt stmt step
685
 | null (filter (not.isSpace) stmt) = return False
686
 | ["import", mod] <- words stmt    = keepGoing setContext ('+':mod)
687
 | otherwise
688
 = do st <- getGHCiState
689
690
      session <- getSession
      result <- io $ withProgName (progname st) $ withArgs (args st) $
691
	     	     GHC.runStmt session stmt step
692
      afterRunStmt (const True) result
693

694

695
--afterRunStmt :: GHC.RunResult -> GHCi Bool
Simon Marlow's avatar
Simon Marlow committed
696
                                 -- False <=> the statement failed to compile
Simon Marlow's avatar
Simon Marlow committed
697
afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
698
afterRunStmt _ (GHC.RunException e) = throw e
699
afterRunStmt step_here run_result = do
700
701
  session     <- getSession
  resumes <- io $ GHC.getResumeContext session
Simon Marlow's avatar
Simon Marlow committed
702
703
704
  case run_result of
     GHC.RunOk names -> do
        show_types <- isOptionSet ShowType
705
        when show_types $ printTypeOfNames session names
706
707
     GHC.RunBreak _ names mb_info 
         | isNothing  mb_info || 
708
           step_here (GHC.resumeSpan $ head resumes) -> do
709
710
               printForUser $ ptext SLIT("Stopped at") <+> 
                       ppr (GHC.resumeSpan $ head resumes)
711
--               printTypeOfNames session names
712
713
714
               let namesSorted = sortBy compareNames names
               tythings <- catMaybes `liftM` 
                              io (mapM (GHC.lookupName session) namesSorted)
715
716
               docs <- io$ pprTypeAndContents session [id | AnId id <- tythings]
               printForUserPartWay docs
717
718
719
720
721
722
               maybe (return ()) runBreakCmd mb_info
               -- run the command set with ":set stop <cmd>"
               st <- getGHCiState
               enqueueCommands [stop st]
               return ()
         | otherwise -> io(GHC.resume session GHC.SingleStep) >>= 
723
                        afterRunStmt step_here >> return ()
Simon Marlow's avatar
Simon Marlow committed
724
725
     _ -> return ()

726
727
728
729
730
  flushInterpBuffers
  io installSignalHandlers
  b <- isOptionSet RevertCAFs
  io (when b revertCAFs)

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

733
734
735
736
737
runBreakCmd :: GHC.BreakInfo -> GHCi ()
runBreakCmd info = do
  let mod = GHC.breakInfo_module info
      nm  = GHC.breakInfo_number info
  st <- getGHCiState
Simon Marlow's avatar
Simon Marlow committed
738
  case  [ loc | (_,loc) <- breaks st,
739
740
741
742
743
                breakModule loc == mod, breakTick loc == nm ] of
        []  -> return ()
        loc:_ | null cmd  -> return ()
              | otherwise -> do enqueueCommands [cmd]; return ()
              where cmd = onBreakCmd loc
744

745
746
printTypeOfNames :: Session -> [Name] -> GHCi ()
printTypeOfNames session names
747
748
749
750
 = mapM_ (printTypeOfName session) $ sortBy compareNames names

compareNames :: Name -> Name -> Ordering
n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
751
752
753
754
    where compareWith n = (getOccString n, getSrcSpan n)

printTypeOfName :: Session -> Name -> GHCi ()
printTypeOfName session n
755
   = do maybe_tything <- io (GHC.lookupName session n)
756
757
758
        case maybe_tything of
            Nothing    -> return ()
            Just thing -> printTyThing thing
759

760

761
data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
762

763
specialCommand :: String -> GHCi Bool
764
specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
765
766
specialCommand str = do
  let (cmd,rest) = break isSpace str
767
  maybe_cmd <- lookupCommand cmd
Simon Marlow's avatar
Simon Marlow committed
768
  case maybe_cmd of
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
    GotCommand (_,f,_,_) -> f (dropWhile isSpace rest)
    BadCommand ->
      do io $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
                           ++ shortHelpText)
         return False
    NoLastCommand ->
      do io $ hPutStr stdout ("there is no last command to perform\n"
                           ++ shortHelpText)
         return False

lookupCommand :: String -> GHCi (MaybeCommand)
lookupCommand "" = do
  st <- getGHCiState
  case last_command st of
      Just c -> return $ GotCommand c
      Nothing -> return NoLastCommand
Simon Marlow's avatar
Simon Marlow committed
785
lookupCommand str = do
786
787
788
789
790
791
792
793
794
  mc <- io $ lookupCommand' str
  st <- getGHCiState
  setGHCiState st{ last_command = mc }
  return $ case mc of
           Just c -> GotCommand c
           Nothing -> BadCommand

lookupCommand' :: String -> IO (Maybe Command)
lookupCommand' str = do
Simon Marlow's avatar
Simon Marlow committed
795
796
  macros <- readIORef macros_ref
  let cmds = builtin_commands ++ macros
Simon Marlow's avatar
Simon Marlow committed
797
  -- look for exact match first, then the first prefix match
798
799
800
801
802
  return $ case [ c | c <- cmds, str == cmdName c ] of
           c:_ -> Just c
           [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
                 [] -> Nothing
                 c:_ -> Just c
803
804
805
806
807
808
809

getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
getCurrentBreakSpan = do
  session <- getSession
  resumes <- io $ GHC.getResumeContext session
  case resumes of
    [] -> return Nothing
Simon Marlow's avatar
Simon Marlow committed
810
    (r:_) -> do
811
812
813
814
815
816
817
818
        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)

819
820
821
822
823
824
getCurrentBreakModule :: GHCi (Maybe Module)
getCurrentBreakModule = do
  session <- getSession
  resumes <- io $ GHC.getResumeContext session
  case resumes of
    [] -> return Nothing
Simon Marlow's avatar
Simon Marlow committed
825
    (r:_) -> do
826
827
        let ix = GHC.resumeHistoryIx r
        if ix == 0
mnislaih's avatar
mnislaih committed
828
           then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
829
830
831
832
           else do
                let hist = GHC.resumeHistory r !! (ix-1)
                return $ Just $ GHC.getHistoryModule  hist

833
834
835
-----------------------------------------------------------------------------
-- Commands

836
837
noArgs :: GHCi () -> String -> GHCi ()
noArgs m "" = m
Simon Marlow's avatar
Simon Marlow committed
838
noArgs _ _  = io $ putStrLn "This command takes no arguments"
839

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

rrt's avatar
rrt committed
843
info :: String -> GHCi ()
844
info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
845
info s  = do { let names = words s
846
	     ; session <- getSession
847
	     ; dflags <- getDynFlags
848
849
	     ; let pefas = dopt Opt_PrintExplicitForalls dflags
	     ; mapM_ (infoThing pefas session) names }
850
  where
851
    infoThing pefas session str = io $ do
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
852
853
	names     <- GHC.parseName session str
	mb_stuffs <- mapM (GHC.getInfo session) names
Simon Marlow's avatar
Simon Marlow committed
854
	let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
855
856
857
	unqual <- GHC.getPrintUnqual session
	putStrLn (showSDocForUser unqual $
     		   vcat (intersperse (text "") $
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
858
		         map (pprInfo pefas) filtered))
859
860
861
862

  -- Filter out names whose parent is also there Good
  -- example is '[]', which is both a type and data
  -- constructor in the same type
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
863
864
865
866
867
filterOutChildren :: (a -> TyThing) -> [a] -> [a]
filterOutChildren get_thing xs 
  = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
  where
    implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
868

869
870
871
pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
pprInfo pefas (thing, fixity, insts)
  =  pprTyThingInContextLoc pefas thing
872
873
  $$ show_fixity fixity
  $$ vcat (map GHC.pprInstance insts)
874
  where
875
    show_fixity fix 
876
877
	| fix == GHC.defaultFixity = empty
	| otherwise		   = ppr fix <+> ppr (GHC.getName thing)
878

879
runMain :: String -> GHCi ()
Ian Lynagh's avatar
Ian Lynagh committed
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
runMain s = case toArgs s of
            Left err   -> io (hPutStrLn stderr err)
            Right args ->
                do dflags <- getDynFlags
                   case mainFunIs dflags of
                       Nothing -> doWithArgs args "main"
                       Just f  -> doWithArgs args f

runRun :: String -> GHCi ()
runRun s = case toCmdArgs s of
           Left err          -> io (hPutStrLn stderr err)
           Right (cmd, args) -> doWithArgs args cmd

doWithArgs :: [String] -> String -> GHCi ()
doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
                                       show args ++ " (" ++ cmd ++ ")"]
896

sof's avatar
sof committed
897
898
addModule :: [FilePath] -> GHCi ()
addModule files = do
899
  io (revertCAFs)			-- always revert CAFs on load/add.
900
  files <- mapM expandPath files
901
  targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
902
903
  session <- getSession
  io (mapM_ (GHC.addTarget session) targets)
Simon Marlow's avatar
Simon Marlow committed
904
  prev_context <- io $ GHC.getContext session
905
  ok <- io (GHC.load session LoadAllTargets)
Simon Marlow's avatar
Simon Marlow committed
906
  afterLoad ok session False prev_context
907

908
changeDirectory :: String -> GHCi ()
909
910
911
912
913
914
changeDirectory "" = do
  -- :cd on its own changes to the user's home directory
  either_dir <- io (IO.try getHomeDirectory)
  case either_dir of
     Left _e -> return ()
     Right dir -> changeDirectory dir
915
changeDirectory dir = do
916
917
918
  session <- getSession
  graph <- io (GHC.getModuleGraph session)
  when (not (null graph)) $
919
	io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
Simon Marlow's avatar
Simon Marlow committed
920
  prev_context <- io $ GHC.getContext session
921
  io (GHC.setTargets session [])
922
  io (GHC.load session LoadAllTargets)
923
  setContextAfterLoad session prev_context False []
924
  io (GHC.workingDirectoryChanged session)
925
926
  dir <- expandPath dir
  io (setCurrentDirectory dir)
927

Simon Marlow's avatar
Simon Marlow committed
928
editFile :: String -> GHCi ()
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
editFile str =
  do file <- if null str then chooseEditFile else return str
     st <- getGHCiState
     let cmd = editor st
     when (null cmd) 
       $ throwDyn (CmdLineError "editor not set, use :set editor")
     io $ system (cmd ++ ' ':file)
     return ()

-- The user didn't specify a file so we pick one for them.
-- Our strategy is to pick the first module that failed to load,
-- or otherwise the first target.
--
-- XXX: Can we figure out what happened if the depndecy analysis fails
--      (e.g., because the porgrammeer mistyped the name of a module)?
-- XXX: Can we figure out the location of an error to pass to the editor?
-- XXX: if we could figure out the list of errors that occured during the
-- last load/reaload, then we could start the editor focused on the first
-- of those.
chooseEditFile :: GHCi String
chooseEditFile =
  do session <- getSession
     let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x

     graph <- io (GHC.getModuleGraph session)
     failed_graph <- filterM hasFailed graph
     let order g  = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
         pick xs  = case xs of
                      x : _ -> GHC.ml_hs_file (GHC.ms_location x)
                      _     -> Nothing

     case pick (order failed_graph) of
       Just file -> return file
       Nothing   -> 
         do targets <- io (GHC.getTargets session)
            case msum (map fromTarget targets) of
              Just file -> return file
              Nothing   -> throwDyn (CmdLineError "No files to edit.")
          
  where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
        fromTarget _ = Nothing -- when would we get a module target?
Simon Marlow's avatar
Simon Marlow committed
970

Simon Marlow's avatar
Simon Marlow committed
971
972
defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
defineMacro overwrite s = do
973
  let (macro_name, definition) = break isSpace s
Simon Marlow's avatar
Simon Marlow committed
974
975
  macros <- io (readIORef macros_ref)
  let defined = map cmdName macros
976
  if (null macro_name) 
Simon Marlow's avatar
Simon Marlow committed
977
978
979
980
	then if null defined
                then io $ putStrLn "no macros defined"
                else io $ putStr ("the following macros are defined:\n" ++
                                  unlines defined)
981
	else do
Simon Marlow's avatar
Simon Marlow committed
982
  if (not overwrite && macro_name `elem` defined)
983
	then throwDyn (CmdLineError 
Simon Marlow's avatar