InteractiveUI.hs 88.7 KB
Newer Older
1
2
3
{-# OPTIONS -fno-cse #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly

4
{-# OPTIONS -#include "Linker.h" #-}
5
6
7
8
-----------------------------------------------------------------------------
--
-- GHC Interactive User Interface
--
9
-- (c) The GHC Team 2005-2006
10
11
--
-----------------------------------------------------------------------------
12

13
module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
14

15
16
#include "HsVersions.h"

mnislaih's avatar
mnislaih committed
17
18
import qualified GhciMonad
import GhciMonad hiding (runStmt)
19
import GhciTags
20
import Debugger
21

22
-- The GHC interface
mnislaih's avatar
mnislaih committed
23
import qualified GHC hiding (resume, runStmt)
24
import GHC              ( LoadHowMuch(..), Target(..),  TargetId(..),
Simon Marlow's avatar
Simon Marlow committed
25
                          Module, ModuleName, TyThing(..), Phase,
26
27
                          BreakIndex, SrcSpan, Resume, SingleStep,
                          Ghc, handleSourceError )
28
import PprTyThing
29
import DynFlags
30

31
import Packages
Ian Lynagh's avatar
Ian Lynagh committed
32
#ifdef USE_EDITLINE
33
34
import PackageConfig
import UniqFM
35
36
#endif

37
38
import HscTypes		( implicitTyThings, reflectGhc, reifyGhc
                        , handleFlagWarnings )
39
import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
40
import Outputable       hiding (printForUser, printForUserPartWay)
41
import Module           -- for ModuleEnv
42
import Name
43
import SrcLoc
44
45

-- Other random utilities
46
import CmdLineParser
47
import Digraph
mnislaih's avatar
mnislaih committed
48
49
import BasicTypes hiding (isTopLevel)
import Panic      hiding (showException)
50
import Config
51
52
53
import StaticFlags
import Linker
import Util
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
54
import NameSet
55
import Maybes		( orElse, expectJust )
56
import FastString
57
import Encoding
58
import MonadUtils       ( liftIO )
59

60
#ifndef mingw32_HOST_OS
61
import System.Posix hiding (getEnv)
sof's avatar
sof committed
62
63
#else
import GHC.ConsoleHandler ( flushConsole )
64
import qualified System.Win32
sof's avatar
sof committed
65
66
#endif

Ian Lynagh's avatar
Ian Lynagh committed
67
#ifdef USE_EDITLINE
68
import Control.Concurrent	( yield )	-- Used in readline loop
Ian Lynagh's avatar
Ian Lynagh committed
69
import System.Console.Editline.Readline as Readline
70
#endif
71
72
73

--import SystemExts

74
import Exception
75
-- import Control.Concurrent
76

77
import System.FilePath
Simon Marlow's avatar
Simon Marlow committed
78
import qualified Data.ByteString.Char8 as BS
79
import Data.List
80
import Data.Maybe
81
82
import System.Cmd
import System.Environment
83
import System.Exit	( exitWith, ExitCode(..) )
84
import System.Directory
ross's avatar
ross committed
85
86
import System.IO
import System.IO.Error as IO
87
import Data.Char
88
import Data.Array
89
import Control.Monad as Monad
Simon Marlow's avatar
Simon Marlow committed
90
import Text.Printf
91
import Foreign
Ian Lynagh's avatar
Ian Lynagh committed
92
import Foreign.C
93
import GHC.Exts		( unsafeCoerce# )
Simon Marlow's avatar
Simon Marlow committed
94
import GHC.IOBase	( IOErrorType(InvalidArgument) )
Ian Lynagh's avatar
Ian Lynagh committed
95
import GHC.TopHandler
96

97
import Data.IORef	( IORef, readIORef, writeIORef )
98

99
100
-----------------------------------------------------------------------------

101
102
103
ghciWelcomeMsg :: String
ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
                 ": http://www.haskell.org/ghc/  :? for help"
104

Simon Marlow's avatar
Simon Marlow committed
105
cmdName :: Command -> String
106
cmdName (n,_,_,_) = n
107

Simon Marlow's avatar
Simon Marlow committed
108
GLOBAL_VAR(macros_ref, [], [Command])
Simon Marlow's avatar
Simon Marlow committed
109
110

builtin_commands :: [Command]
111
builtin_commands = [
112
	-- Hugs users are accustomed to :e, so make sure it doesn't overlap
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
141
142
143
  ("?",		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
144
  ("run",	keepGoing runRun,		Nothing, completeIdentifier),
145
  ("set",	keepGoing setCmd,		Just flagWordBreakChars, completeSetOptions),
146
  ("show",	keepGoing showCmd,		Nothing, completeShowOptions),
147
148
149
150
151
152
153
154
  ("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)
155
156
  ]

157
158
159
160
161
162
163
164
165

-- 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
166
#ifdef USE_EDITLINE
167
word_break_chars :: String
168
169
170
171
word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
                       specials = "(),;[]`{}"
                       spaces = " \t\n"
                   in spaces ++ specials ++ symbols
172
173
174
#endif

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


179
180
181
keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
keepGoing a str = a str >> return False

sof's avatar
sof committed
182
keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
Ian Lynagh's avatar
Ian Lynagh committed
183
184
185
186
187
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
188

Simon Marlow's avatar
Simon Marlow committed
189
shortHelpText :: String
190
191
shortHelpText = "use :? for help.\n"

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

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

Simon Marlow's avatar
Simon Marlow committed
279
findEditor :: IO String
Simon Marlow's avatar
Simon Marlow committed
280
281
282
findEditor = do
  getEnv "EDITOR" 
    `IO.catch` \_ -> do
283
#if mingw32_HOST_OS
Ian Lynagh's avatar
Ian Lynagh committed
284
285
        win <- System.Win32.getWindowsDirectory
        return (win </> "notepad.exe")
Simon Marlow's avatar
Simon Marlow committed
286
#else
Ian Lynagh's avatar
Ian Lynagh committed
287
        return ""
Simon Marlow's avatar
Simon Marlow committed
288
289
#endif

290
291
interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String]
              -> Ghc ()
292
interactiveUI srcs maybe_exprs = withTerminalReset $ do
293
294
295
296
297
298
299
300
   -- 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.
301
302
303
   liftIO $ newStablePtr stdin
   liftIO $ newStablePtr stdout
   liftIO $ newStablePtr stderr
304

Ian Lynagh's avatar
Ian Lynagh committed
305
    -- Initialise buffering for the *interpreted* I/O system
306
   initInterpBuffering
307

308
   liftIO $ when (isNothing maybe_exprs) $ do
Ian Lynagh's avatar
Ian Lynagh committed
309
310
311
312
313
314
315
316
317
318
319
        -- 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
320
#ifdef USE_EDITLINE
321
        is_tty <- hIsTerminalDevice stdin
322
        when is_tty $ withReadline $ do
323
            Readline.initialize
324
325
326

            withGhcAppData
                 (\dir -> Readline.readHistory (dir </> "ghci_history"))
Ian Lynagh's avatar
Ian Lynagh committed
327
                 (return True)
328
            
329
330
331
332
333
334
            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
335
336
#endif

337
   -- initial context is just the Prelude
338
339
   prel_mod <- GHC.findModule (GHC.mkModuleName "Prelude") Nothing
   GHC.setContext [] [prel_mod]
340

341
   default_editor <- liftIO $ findEditor
Simon Marlow's avatar
Simon Marlow committed
342

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

Ian Lynagh's avatar
Ian Lynagh committed
361
#ifdef USE_EDITLINE
362
363
364
365
366
   liftIO $ do
     Readline.stifleHistory 100
     withGhcAppData (\dir -> Readline.writeHistory (dir </> "ghci_history"))
                    (return True)
     Readline.resetTerminal Nothing
rrt's avatar
rrt committed
367
368
#endif

369
370
   return ()

371
372
373
374
375
376
377
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

378
379
380
381
382
383
384
385
386
387
388
-- libedit doesn't always restore the terminal settings correctly (as of at 
-- least 07/12/2008); see trac #2691.  Work around this by manually resetting
-- the terminal outselves.
withTerminalReset :: Ghc () -> Ghc ()
#ifdef mingw32_HOST_OS
withTerminalReset = id
#else
withTerminalReset f = do
    isTTY <- liftIO $ hIsTerminalDevice stdout
    if not isTTY
        then f
389
390
391
        else gbracket (liftIO $ getTerminalAttributes stdOutput)
                (\attrs -> liftIO $ setTerminalAttributes stdOutput attrs Immediately)
                (const f)
392
#endif
393

Ian Lynagh's avatar
Ian Lynagh committed
394
395
runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
runGHCi paths maybe_exprs = do
396
397
  let 
   read_dot_files = not opt_IgnoreDotGhci
398

399
400
   current_dir = return (Just ".ghci")

401
402
403
   app_user_dir = io $ withGhcAppData 
                    (\dir -> return (Just (dir </> "ghci.conf")))
                    (return Nothing)
404
405
406
407
408
409
410
411
412
413
414
415
416

   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
417
       when (dir_ok && file_ok) $ do
418
419
420
421
422
423
         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
424

425
  when (read_dot_files) $ do
426
427
428
429
430
    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.
431

432
  -- Perform a :load for files given on the GHCi command line
433
434
435
  -- 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
436
437
     ok <- ghciHandle (\e -> do showException e; return Failed) $
                loadModule paths
Ian Lynagh's avatar
Ian Lynagh committed
438
     when (isJust maybe_exprs && failed ok) $
Ian Lynagh's avatar
Ian Lynagh committed
439
        io (exitWith (ExitFailure 1))
440

441
442
  -- if verbosity is greater than 0, or we are connected to a
  -- terminal, display the prompt in the interactive loop.
443
  is_tty <- io (hIsTerminalDevice stdin)
444
  dflags <- getDynFlags
445
446
  let show_prompt = verbosity dflags > 0 || is_tty

Ian Lynagh's avatar
Ian Lynagh committed
447
  case maybe_exprs of
Ian Lynagh's avatar
Ian Lynagh committed
448
        Nothing ->
sof's avatar
sof committed
449
          do
Simon Marlow's avatar
Simon Marlow committed
450
#if defined(mingw32_HOST_OS)
Ian Lynagh's avatar
Ian Lynagh committed
451
            -- The win32 Console API mutates the first character of
sof's avatar
sof committed
452
453
454
455
            -- 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
456
457
458
459
            case flushed of
             Left err | isDoesNotExistError err -> return ()
                      | otherwise -> io (ioError err)
             Right () -> return ()
sof's avatar
sof committed
460
#endif
Ian Lynagh's avatar
Ian Lynagh committed
461
462
            -- enter the interactive loop
            interactiveLoop is_tty show_prompt
Ian Lynagh's avatar
Ian Lynagh committed
463
        Just exprs -> do
Ian Lynagh's avatar
Ian Lynagh committed
464
            -- just evaluate the expression we were given
Ian Lynagh's avatar
Ian Lynagh committed
465
            enqueueCommands exprs
Ian Lynagh's avatar
Ian Lynagh committed
466
467
468
469
470
            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)
471
472
                                   -- this used to be topHandlerFastExit, see #2228
                                 $ topHandler e
Ian Lynagh's avatar
Ian Lynagh committed
473
            runCommands' handle (return Nothing)
474
475

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

Simon Marlow's avatar
Simon Marlow committed
478
interactiveLoop :: Bool -> Bool -> GHCi ()
479
interactiveLoop is_tty show_prompt =
480
  -- Ignore ^C exceptions caught here
481
  ghciHandleGhcException (\e -> case e of 
482
			Interrupted -> do
sof's avatar
sof committed
483
#if defined(mingw32_HOST_OS)
484
				io (putStrLn "")
sof's avatar
sof committed
485
#endif
486
487
488
489
490
				interactiveLoop is_tty show_prompt
			_other      -> return ()) $ 

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

492
  -- read commands from stdin
Ian Lynagh's avatar
Ian Lynagh committed
493
#ifdef USE_EDITLINE
494
  if (is_tty) 
495
	then runCommands readlineLoop
496
	else runCommands (fileLoop stdin show_prompt is_tty)
497
#else
498
  runCommands (fileLoop stdin show_prompt is_tty)
499
#endif
500
501


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

rrt's avatar
rrt committed
506
507
508
509
-- 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.
510
511

checkPerms :: String -> IO Bool
512
#ifdef mingw32_HOST_OS
Simon Marlow's avatar
Simon Marlow committed
513
checkPerms _ =
514
  return True
sof's avatar
sof committed
515
#else
Simon Marlow's avatar
Simon Marlow committed
516
checkPerms name =
517
  handleIO (\_ -> return False) $ do
518
519
520
521
522
523
524
525
526
527
528
529
530
531
     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
532
#endif
533

534
535
fileLoop :: Handle -> Bool -> Bool -> GHCi (Maybe String)
fileLoop hdl show_prompt is_tty = do
536
537
538
   when show_prompt $ do
        prompt <- mkPrompt
        (io (putStr prompt))
539
540
   l <- io (IO.try (hGetLine hdl))
   case l of
541
542
543
544
545
546
547
548
        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.
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
        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
576

Simon Marlow's avatar
Simon Marlow committed
577
mkPrompt :: GHCi String
578
mkPrompt = do
579
580
  (toplevs,exports) <- GHC.getContext
  resumes <- GHC.getResumeContext
Simon Marlow's avatar
Simon Marlow committed
581
  -- st <- getGHCiState
582
583
584
585

  context_bit <-
        case resumes of
            [] -> return empty
Simon Marlow's avatar
Simon Marlow committed
586
            r:_ -> do
587
588
589
590
591
                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)
592
                        span <- GHC.getHistorySpan hist
593
594
595
                        return (brackets (ppr (negate ix) <> char ':' 
                                          <+> ppr span) <> space)
  let
Simon Marlow's avatar
Simon Marlow committed
596
        dots | _:rs <- resumes, not (null rs) = text "... "
597
598
             | otherwise = empty

Simon Marlow's avatar
Simon Marlow committed
599
600
        

601
        modules_bit = 
Simon Marlow's avatar
Simon Marlow committed
602
603
604
605
606
       -- 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) <+>
607
608
             hsep (map (ppr . GHC.moduleName) exports)

609
610
611
612
613
614
615
616
617
        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)))
618

619

Ian Lynagh's avatar
Ian Lynagh committed
620
#ifdef USE_EDITLINE
621
readlineLoop :: GHCi (Maybe String)
622
readlineLoop = do
623
   io yield
Simon Marlow's avatar
Simon Marlow committed
624
   saveSession -- for use by completion
625
   prompt <- mkPrompt
626
   l <- io $ withReadline (readline prompt)
Simon Marlow's avatar
Simon Marlow committed
627
   splatSavedSession
628
   case l of
629
        Nothing -> return Nothing
630
        Just "" -> return (Just "") -- Don't put empty lines in the history
631
632
        Just l  -> do
                   io (addHistory l)
633
634
                   str <- io $ consoleInputToUnicode True l
                   return (Just str)
635
636

withReadline :: IO a -> IO a
637
638
withReadline = bracket_ stopTimer startTimer
     --    editline doesn't handle some of its system calls returning
639
640
641
642
643
644
645
     --    EINTR, so our timer signal confuses it, hence we turn off
     --    the timer signal when making calls to editline. (#2277)
     --    If editline is ever fixed, we can remove this.

-- These come from the RTS
foreign import ccall unsafe startTimer :: IO ()
foreign import ccall unsafe stopTimer  :: IO ()
646
#endif
647

648
649
650
651
652
653
654
655
656
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 ()
657
658
runCommands = runCommands' handler

659
runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
660
661
             -> GHCi (Maybe String) -> GHCi ()
runCommands' eh getCmd = do
662
663
664
665
666
  mb_cmd <- noSpace queryQueue
  mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
  case mb_cmd of 
    Nothing -> return ()
    Just c  -> do
667
668
669
      b <- ghciHandle eh $
             handleSourceError printErrorAndKeepGoing
               (doCommand c)
670
      if b then return () else runCommands' eh getCmd
671
  where
672
673
    printErrorAndKeepGoing err = do
        GHC.printExceptionAndWarnings err
674
        return False
675

676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
    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
708
709
710
711
712
713

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

714

715
716
runStmt :: String -> SingleStep -> GHCi Bool
runStmt stmt step
717
 | null (filter (not.isSpace) stmt) = return False
718
 | ["import", mod] <- words stmt    = keepGoing setContext ('+':mod)
719
 | otherwise
mnislaih's avatar
mnislaih committed
720
 = do result <- GhciMonad.runStmt stmt step
721
      afterRunStmt (const True) result
722

723
--afterRunStmt :: GHC.RunResult -> GHCi Bool
Simon Marlow's avatar
Simon Marlow committed
724
                                 -- False <=> the statement failed to compile
Simon Marlow's avatar
Simon Marlow committed
725
afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
726
afterRunStmt _ (GHC.RunException e) = throw e
727
afterRunStmt step_here run_result = do
728
  resumes <- GHC.getResumeContext
Simon Marlow's avatar
Simon Marlow committed
729
730
731
  case run_result of
     GHC.RunOk names -> do
        show_types <- isOptionSet ShowType
732
        when show_types $ printTypeOfNames names
733
734
     GHC.RunBreak _ names mb_info 
         | isNothing  mb_info || 
735
           step_here (GHC.resumeSpan $ head resumes) -> do
736
               printForUser $ ptext (sLit "Stopped at") <+> 
737
                       ppr (GHC.resumeSpan $ head resumes)
738
--               printTypeOfNames session names
739
740
               let namesSorted = sortBy compareNames names
               tythings <- catMaybes `liftM` 
741
742
                              mapM GHC.lookupName namesSorted
               docs <- pprTypeAndContents [id | AnId id <- tythings]
743
               printForUserPartWay docs
744
745
746
747
748
               maybe (return ()) runBreakCmd mb_info
               -- run the command set with ":set stop <cmd>"
               st <- getGHCiState
               enqueueCommands [stop st]
               return ()
mnislaih's avatar
mnislaih committed
749
         | otherwise -> resume GHC.SingleStep >>=
750
                        afterRunStmt step_here >> return ()
Simon Marlow's avatar
Simon Marlow committed
751
752
     _ -> return ()

753
754
755
  flushInterpBuffers
  io installSignalHandlers
  b <- isOptionSet RevertCAFs
756
  when b revertCAFs
757

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

760
761
762
763
764
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
765
  case  [ loc | (_,loc) <- breaks st,
766
767
768
769
770
                breakModule loc == mod, breakTick loc == nm ] of
        []  -> return ()
        loc:_ | null cmd  -> return ()
              | otherwise -> do enqueueCommands [cmd]; return ()
              where cmd = onBreakCmd loc
771

772
773
774
printTypeOfNames :: [Name] -> GHCi ()
printTypeOfNames names
 = mapM_ (printTypeOfName ) $ sortBy compareNames names
775
776
777

compareNames :: Name -> Name -> Ordering
n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
778
779
    where compareWith n = (getOccString n, getSrcSpan n)

780
781
782
printTypeOfName :: Name -> GHCi ()
printTypeOfName n
   = do maybe_tything <- GHC.lookupName n
783
784
785
        case maybe_tything of
            Nothing    -> return ()
            Just thing -> printTyThing thing
786

787

788
data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
789

790
specialCommand :: String -> GHCi Bool
791
specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
792
793
specialCommand str = do
  let (cmd,rest) = break isSpace str
794
  maybe_cmd <- lookupCommand cmd
Simon Marlow's avatar
Simon Marlow committed
795
  case maybe_cmd of
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
    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
812
lookupCommand str = do
813
814
815
816
817
818
819
820
821
  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
822
823
  macros <- readIORef macros_ref
  let cmds = builtin_commands ++ macros
Simon Marlow's avatar
Simon Marlow committed
824
  -- look for exact match first, then the first prefix match
825
826
827
828
829
  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
830
831
832

getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
getCurrentBreakSpan = do
833
  resumes <- GHC.getResumeContext
834
835
  case resumes of
    [] -> return Nothing
Simon Marlow's avatar
Simon Marlow committed
836
    (r:_) -> do
837
838
839
840
841
        let ix = GHC.resumeHistoryIx r
        if ix == 0
           then return (Just (GHC.resumeSpan r))
           else do
                let hist = GHC.resumeHistory r !! (ix-1)
842
                span <- GHC.getHistorySpan hist
843
844
                return (Just span)

845
846
getCurrentBreakModule :: GHCi (Maybe Module)
getCurrentBreakModule = do
847
  resumes <- GHC.getResumeContext
848
849
  case resumes of
    [] -> return Nothing
Simon Marlow's avatar
Simon Marlow committed
850
    (r:_) -> do
851
852
        let ix = GHC.resumeHistoryIx r
        if ix == 0
mnislaih's avatar
mnislaih committed
853
           then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
854
855
856
857
           else do
                let hist = GHC.resumeHistory r !! (ix-1)
                return $ Just $ GHC.getHistoryModule  hist

858
859
860
-----------------------------------------------------------------------------
-- Commands

861
862
noArgs :: GHCi () -> String -> GHCi ()
noArgs m "" = m
Simon Marlow's avatar
Simon Marlow committed
863
noArgs _ _  = io $ putStrLn "This command takes no arguments"
864

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

rrt's avatar
rrt committed
868
info :: String -> GHCi ()
869
info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
870
871
info s  = handleSourceError GHC.printExceptionAndWarnings $ do
             { let names = words s
872
	     ; dflags <- getDynFlags
873
	     ; let pefas = dopt Opt_PrintExplicitForalls dflags
874
	     ; mapM_ (infoThing pefas) names }
875
  where
876
877
878
    infoThing pefas str = do
	names     <- GHC.parseName str
	mb_stuffs <- mapM GHC.getInfo names
Simon Marlow's avatar
Simon Marlow committed
879
	let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
880
881
882
883
884
	unqual <- GHC.getPrintUnqual
	liftIO $
          putStrLn (showSDocForUser unqual $
     		     vcat (intersperse (text "") $
		           map (pprInfo pefas) filtered))
885
886
887
888

  -- 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
889
890
891
892
893
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)]
894

895
896
897
pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
pprInfo pefas (thing, fixity, insts)
  =  pprTyThingInContextLoc pefas thing
898
899
  $$ show_fixity fixity
  $$ vcat (map GHC.pprInstance insts)
900
  where
901
    show_fixity fix 
902
903
	| fix == GHC.defaultFixity = empty
	| otherwise		   = ppr fix <+> ppr (GHC.getName thing)
904

905
runMain :: String -> GHCi ()
Ian Lynagh's avatar
Ian Lynagh committed
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
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 ++ ")"]
922

sof's avatar
sof committed
923
924
addModule :: [FilePath] -> GHCi ()
addModule files = do
925
  revertCAFs			-- always revert CAFs on load/add.
926
  files <- mapM expandPath files
927
  targets <- mapM (\m -> GHC.guessTarget m Nothing) files
Simon Marlow's avatar
Simon Marlow committed
928
  -- remove old targets with the same id; e.g. for :add *M
929
930
931
932
933
  mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
  mapM_ GHC.addTarget targets
  prev_context <- GHC.getContext
  ok <- trySuccess $ GHC.load LoadAllTargets
  afterLoad ok False prev_context