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

4
5
6
7
-----------------------------------------------------------------------------
--
-- GHC Interactive User Interface
--
8
-- (c) The GHC Team 2005-2006
9
10
--
-----------------------------------------------------------------------------
11

12
module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
13

14
15
#include "HsVersions.h"

dterei's avatar
dterei committed
16
17
18
-- GHCi
import qualified GhciMonad ( args, runStmt )
import GhciMonad hiding ( args, runStmt )
19
import GhciTags
20
import Debugger
21

22
-- The GHC interface
dterei's avatar
dterei committed
23
import DynFlags
dterei's avatar
dterei committed
24
25
26
27
import qualified GHC
import GHC ( LoadHowMuch(..), Target(..),  TargetId(..), InteractiveImport(..),
             TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,
             handleSourceError )
28
import HsImpExp
dterei's avatar
dterei committed
29
import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, dep_pkgs )
dterei's avatar
dterei committed
30
import Module
31
import Name
dterei's avatar
dterei committed
32
33
34
import Packages ( trusted, getPackageDetails, exposed, exposedModules, pkgIdMap )
import PprTyThing
import RdrName ( getGRE_NameQualifier_maybes )
35
import SrcLoc
dterei's avatar
dterei committed
36
37
38
39
40
import qualified Lexer

import StringBuffer
import UniqFM ( eltsUFM )
import Outputable hiding ( printForUser, printForUserPartWay, bold )
41
42

-- Other random utilities
dterei's avatar
dterei committed
43
import BasicTypes hiding ( isTopLevel )
44
import Config
dterei's avatar
dterei committed
45
46
47
import Digraph
import Encoding
import FastString
48
import Linker
dterei's avatar
dterei committed
49
import Maybes ( orElse, expectJust )
dterei's avatar
dterei committed
50
51
52
53
54
import NameSet
import Panic hiding ( showException )
import StaticFlags
import Util ( on, global, toArgs, toCmdArgs, removeSpaces, getCmd,
              filterOut, seqList, looksLikeModuleName, partitionWith )
sof's avatar
sof committed
55

dterei's avatar
dterei committed
56
-- Haskell Libraries
57
58
import System.Console.Haskeline as Haskeline
import qualified System.Console.Haskeline.Encoding as Encoding
59

dterei's avatar
dterei committed
60
61
62
import Control.Applicative hiding (empty)
import Control.Monad as Monad
import Control.Monad.Trans
63

dterei's avatar
dterei committed
64
import Data.Array
Simon Marlow's avatar
Simon Marlow committed
65
import qualified Data.ByteString.Char8 as BS
dterei's avatar
dterei committed
66
67
68
69
import Data.Char
import Data.IORef ( IORef, readIORef, writeIORef )
import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,
                   partition, sort, sortBy )
70
import Data.Maybe
dterei's avatar
dterei committed
71
72
73
74
75
76

import Exception hiding (catch, block, unblock)

import Foreign.C
import Foreign.Safe

77
import System.Cmd
dterei's avatar
dterei committed
78
import System.Directory
79
import System.Environment
dterei's avatar
dterei committed
80
import System.Exit ( exitWith, ExitCode(..) )
dterei's avatar
dterei committed
81
import System.FilePath
ross's avatar
ross committed
82
import System.IO
83
import System.IO.Error
dterei's avatar
dterei committed
84
import System.IO.Unsafe ( unsafePerformIO )
Simon Marlow's avatar
Simon Marlow committed
85
import Text.Printf
86

dterei's avatar
dterei committed
87
88
89
90
91
92
93
#ifndef mingw32_HOST_OS
import System.Posix hiding ( getEnv )
#else
import qualified System.Win32
#endif

import GHC.Exts ( unsafeCoerce# )
dterei's avatar
dterei committed
94
95
import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
import GHC.IO.Handle ( hFlushAll )
dterei's avatar
dterei committed
96
import GHC.TopHandler ( topHandler )
97

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
113
114
115
116
117
118
119
120
121
122
123
  -- Hugs users are accustomed to :e, so make sure it doesn't overlap
  ("?",         keepGoing help,                 noCompletion),
  ("add",       keepGoingPaths addModule,       completeFilename),
  ("abandon",   keepGoing abandonCmd,           noCompletion),
  ("break",     keepGoing breakCmd,             completeIdentifier),
  ("back",      keepGoing backCmd,              noCompletion),
  ("browse",    keepGoing' (browseCmd False),   completeModule),
  ("browse!",   keepGoing' (browseCmd True),    completeModule),
  ("cd",        keepGoing' changeDirectory,     completeFilename),
  ("check",     keepGoing' checkModule,         completeHomeModule),
  ("continue",  keepGoing continueCmd,          noCompletion),
  ("cmd",       keepGoing cmdCmd,               completeExpression),
124
125
  ("ctags",     keepGoing createCTagsWithLineNumbersCmd, completeFilename),
  ("ctags!",    keepGoing createCTagsWithRegExesCmd, completeFilename),
126
127
128
  ("def",       keepGoing (defineMacro False),  completeExpression),
  ("def!",      keepGoing (defineMacro True),   completeExpression),
  ("delete",    keepGoing deleteCmd,            noCompletion),
129
  ("edit",      keepGoing' editFile,            completeFilename),
130
131
132
133
134
135
  ("etags",     keepGoing createETagsFileCmd,   completeFilename),
  ("force",     keepGoing forceCmd,             completeExpression),
  ("forward",   keepGoing forwardCmd,           noCompletion),
  ("help",      keepGoing help,                 noCompletion),
  ("history",   keepGoing historyCmd,           noCompletion),
  ("info",      keepGoing' info,                completeIdentifier),
136
  ("issafe",    keepGoing' isSafeCmd,           completeModule),
137
138
  ("kind",      keepGoing' (kindOfType False),  completeIdentifier),
  ("kind!",     keepGoing' (kindOfType True),   completeIdentifier),
139
140
  ("load",      keepGoingPaths loadModule_,     completeHomeModuleOrFile),
  ("list",      keepGoing' listCmd,             noCompletion),
141
  ("module",    keepGoing moduleCmd,            completeSetModule),
142
143
144
145
146
  ("main",      keepGoing runMain,              completeFilename),
  ("print",     keepGoing printCmd,             completeExpression),
  ("quit",      quit,                           noCompletion),
  ("reload",    keepGoing' reloadModule,        noCompletion),
  ("run",       keepGoing runRun,               completeFilename),
vivian's avatar
vivian committed
147
  ("script",    keepGoing' scriptCmd,           completeFilename),
148
  ("set",       keepGoing setCmd,               completeSetOptions),
149
  ("seti",      keepGoing setiCmd,              completeSeti),
150
  ("show",      keepGoing showCmd,              completeShowOptions),
151
  ("showi",     keepGoing showiCmd,             completeShowiOptions),
152
153
154
155
156
157
158
159
  ("sprint",    keepGoing sprintCmd,            completeExpression),
  ("step",      keepGoing stepCmd,              completeIdentifier),
  ("steplocal", keepGoing stepLocalCmd,         completeIdentifier),
  ("stepmodule",keepGoing stepModuleCmd,        completeIdentifier),
  ("type",      keepGoing' typeOfExpr,          completeExpression),
  ("trace",     keepGoing traceCmd,             completeExpression),
  ("undef",     keepGoing undefineMacro,        completeMacro),
  ("unset",     keepGoing unsetOptions,         completeSetOptions)
160
161
  ]

162

dterei's avatar
dterei committed
163
-- We initialize readline (in the interactiveUI function) to use
164
165
166
167
-- 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.
dterei's avatar
dterei committed
168
--
169
170
-- NOTE: in order for us to override the default correctly, any custom entry
-- must be a SUBSET of word_break_chars.
171
word_break_chars :: String
172
173
174
175
word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
                       specials = "(),;[]`{}"
                       spaces = " \t\n"
                   in spaces ++ specials ++ symbols
176

177
flagWordBreakChars :: String
178
179
180
flagWordBreakChars = " \t\n"


181
182
183
184
185
keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)
keepGoing a str = keepGoing' (lift . a) str

keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool
keepGoing' a str = a str >> return False
186

187
keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
Ian Lynagh's avatar
Ian Lynagh committed
188
189
keepGoingPaths a str
 = do case toArgs str of
190
          Left err -> Encoding.encode err >>= liftIO . BS.hPutStrLn stderr
Ian Lynagh's avatar
Ian Lynagh committed
191
192
          Right args -> a args
      return False
sof's avatar
sof committed
193

Simon Marlow's avatar
Simon Marlow committed
194
shortHelpText :: String
195
196
shortHelpText = "use :? for help.\n"

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

dterei's avatar
dterei committed
254
255
256
257
  "\n" ++
  " -- Commands for changing settings:\n" ++
  "\n" ++
  "   :set <option> ...           set options\n" ++
258
  "   :seti <option> ...          set options for interactive evaluation only\n" ++
dterei's avatar
dterei committed
259
260
261
262
263
264
265
266
267
  "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
  "   :set prog <progname>        set the value returned by System.getProgName\n" ++
  "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
  "   :set editor <cmd>           set the command used for :edit\n" ++
  "   :set stop [<n>] <cmd>       set the command to run when a breakpoint is hit\n" ++
  "   :unset <option> ...         unset options\n" ++
  "\n" ++
  "  Options for ':set' and ':unset':\n" ++
  "\n" ++
dterei's avatar
dterei committed
268
  "    +m            allow multiline commands\n" ++
dterei's avatar
dterei committed
269
270
271
272
273
274
275
276
277
278
279
280
281
  "    +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" ++
  "                         (eg. -v2, -fglasgow-exts, etc.)\n" ++
  "                    for GHCi-specific flags, see User's Guide,\n"++
  "                    Flag reference, Interactive-mode options\n" ++
  "\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" ++
282
  "   :show imports               show the current imports\n" ++
dterei's avatar
dterei committed
283
284
  "   :show modules               show the currently loaded modules\n" ++
  "   :show packages              show the currently active package flags\n" ++
285
  "   :show language              show the currently active language flags\n" ++
dterei's avatar
dterei committed
286
287
  "   :show <setting>             show value of <setting>, which is one of\n" ++
  "                                  [args, prog, prompt, editor, stop]\n" ++
288
  "   :showi language             show language flags for interactive evaluation\n" ++
dterei's avatar
dterei committed
289
  "\n"
290

Simon Marlow's avatar
Simon Marlow committed
291
findEditor :: IO String
Simon Marlow's avatar
Simon Marlow committed
292
findEditor = do
dterei's avatar
dterei committed
293
  getEnv "EDITOR"
294
    `catchIO` \_ -> do
295
#if mingw32_HOST_OS
Ian Lynagh's avatar
Ian Lynagh committed
296
297
        win <- System.Win32.getWindowsDirectory
        return (win </> "notepad.exe")
Simon Marlow's avatar
Simon Marlow committed
298
#else
Ian Lynagh's avatar
Ian Lynagh committed
299
        return ""
Simon Marlow's avatar
Simon Marlow committed
300
301
#endif

Simon Marlow's avatar
Simon Marlow committed
302
303
foreign import ccall unsafe "rts_isProfiled" isProfiled :: IO CInt

Simon Marlow's avatar
Simon Marlow committed
304
default_progname, default_prompt, default_stop :: String
Boris Lykah's avatar
Boris Lykah committed
305
306
307
308
default_progname = "<interactive>"
default_prompt = "%s> "
default_stop = ""

Simon Marlow's avatar
Simon Marlow committed
309
310
311
default_args :: [String]
default_args = []

312
313
interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String]
              -> Ghc ()
314
interactiveUI srcs maybe_exprs = do
315
316
317
   -- although GHCi compiles with -prof, it is not usable: the byte-code
   -- compiler and interpreter don't work with profiling.  So we check for
   -- this up front and emit a helpful error message (#2197)
Simon Marlow's avatar
Simon Marlow committed
318
   i <- liftIO $ isProfiled
dterei's avatar
dterei committed
319
   when (i /= 0) $
320
321
     ghcError (InstallationError "GHCi cannot be used when compiled with -prof")

322
323
324
325
326
327
328
329
   -- 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.
330
331
332
   _ <- liftIO $ newStablePtr stdin
   _ <- liftIO $ newStablePtr stdout
   _ <- liftIO $ newStablePtr stderr
333

Ian Lynagh's avatar
Ian Lynagh committed
334
    -- Initialise buffering for the *interpreted* I/O system
335
   initInterpBuffering
336

337
338
339
340
341
   -- The initial set of DynFlags used for interactive evaluation is the same
   -- as the global DynFlags, plus -XExtendedDefaultRules
   dflags <- getDynFlags
   GHC.setInteractiveDynFlags (xopt_set dflags Opt_ExtendedDefaultRules)

342
   liftIO $ when (isNothing maybe_exprs) $ do
Ian Lynagh's avatar
Ian Lynagh committed
343
344
345
346
347
348
349
350
351
352
        -- 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
353
#if defined(mingw32_HOST_OS)
354
355
356
357
358
        -- On Unix, stdin will use the locale encoding.  The IO library
        -- doesn't do this on Windows (yet), so for now we use UTF-8,
        -- for consistency with GHC 6.10 and to make the tests work.
        hSetEncoding stdin utf8
#endif
Ian Lynagh's avatar
Ian Lynagh committed
359

360
   default_editor <- liftIO $ findEditor
Simon Marlow's avatar
Simon Marlow committed
361

Ian Lynagh's avatar
Ian Lynagh committed
362
   startGHCi (runGHCi srcs maybe_exprs)
dterei's avatar
dterei committed
363
364
365
366
367
368
369
370
371
372
373
374
        GHCiState{ progname       = default_progname,
                   GhciMonad.args = default_args,
                   prompt         = default_prompt,
                   stop           = default_stop,
                   editor         = default_editor,
                   options        = [],
                   line_number    = 1,
                   break_ctr      = 0,
                   breaks         = [],
                   tickarrays     = emptyModuleEnv,
                   last_command   = Nothing,
                   cmdqueue       = [],
mnislaih's avatar
mnislaih committed
375
                   remembered_ctx = [],
dterei's avatar
dterei committed
376
377
                   transient_ctx  = [],
                   ghc_e          = isJust maybe_exprs
mnislaih's avatar
mnislaih committed
378
                 }
rrt's avatar
rrt committed
379

380
381
   return ()

382
383
withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
withGhcAppData right left = do
384
    either_dir <- tryIO (getAppUserDataDirectory "ghc")
385
386
387
388
389
    case either_dir of
        Right dir ->
            do createDirectoryIfMissing False dir `catchIO` \_ -> return ()
               right dir
        _ -> left
390

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

396
397
   current_dir = return (Just ".ghci")

Ian Lynagh's avatar
Ian Lynagh committed
398
   app_user_dir = liftIO $ withGhcAppData
399
400
                    (\dir -> return (Just (dir </> "ghci.conf")))
                    (return Nothing)
401
402

   home_dir = do
403
    either_dir <- liftIO $ tryIO (getEnv "HOME")
404
405
406
407
    case either_dir of
      Right home -> return (Just (home </> ".ghci"))
      _ -> return Nothing

408
409
410
411
   canonicalizePath' :: FilePath -> IO (Maybe FilePath)
   canonicalizePath' fp = liftM Just (canonicalizePath fp)
                `catchIO` \_ -> return Nothing

412
413
   sourceConfigFile :: FilePath -> GHCi ()
   sourceConfigFile file = do
Ian Lynagh's avatar
Ian Lynagh committed
414
     exists <- liftIO $ doesFileExist file
415
     when exists $ do
Ian Lynagh's avatar
Ian Lynagh committed
416
417
       dir_ok  <- liftIO $ checkPerms (getDirectory file)
       file_ok <- liftIO $ checkPerms file
418
       when (dir_ok && file_ok) $ do
419
         either_hdl <- liftIO $ tryIO (openFile file ReadMode)
420
421
         case either_hdl of
           Left _e   -> return ()
422
423
424
           -- NOTE: this assumes that runInputT won't affect the terminal;
           -- can we assume this will always be the case?
           -- This would be a good place for runFileInputT.
425
426
           Right hdl ->
               do runInputTWithPrefs defaultPrefs defaultSettings $
427
                            runCommands $ fileLoop hdl
428
                  liftIO (hClose hdl `catchIO` \_ -> return ())
429
430
     where
      getDirectory f = case takeDirectory f of "" -> "."; d -> d
431
432
  --

433
  setGHCContextFromGHCiState
Ian Lynagh's avatar
Ian Lynagh committed
434

435
  when (read_dot_files) $ do
436
437
    mcfgs0 <- sequence $ [ current_dir, app_user_dir, home_dir ]
                         ++ map (return . Just) opt_GhciScripts
Ian Lynagh's avatar
Ian Lynagh committed
438
    mcfgs <- liftIO $ mapM canonicalizePath' (catMaybes mcfgs0)
439
    mapM_ sourceConfigFile $ nub $ catMaybes mcfgs
440
441
        -- nub, because we don't want to read .ghci twice if the
        -- CWD is $HOME.
442

443
  -- Perform a :load for files given on the GHCi command line
444
445
446
  -- 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
447
     ok <- ghciHandle (\e -> do showException e; return Failed) $
448
449
450
451
452
                -- TODO: this is a hack.
                runInputTWithPrefs defaultPrefs defaultSettings $ do
                    let (filePaths, phases) = unzip paths
                    filePaths' <- mapM (Encoding.decode . BS.pack) filePaths
                    loadModule (zip filePaths' phases)
Ian Lynagh's avatar
Ian Lynagh committed
453
     when (isJust maybe_exprs && failed ok) $
Ian Lynagh's avatar
Ian Lynagh committed
454
        liftIO (exitWith (ExitFailure 1))
455

456
457
  -- if verbosity is greater than 0, or we are connected to a
  -- terminal, display the prompt in the interactive loop.
Ian Lynagh's avatar
Ian Lynagh committed
458
  is_tty <- liftIO (hIsTerminalDevice stdin)
459
  dflags <- getDynFlags
460
461
  let show_prompt = verbosity dflags > 0 || is_tty

462
463
464
  -- reset line number
  getGHCiState >>= \st -> setGHCiState st{line_number=1}

Ian Lynagh's avatar
Ian Lynagh committed
465
  case maybe_exprs of
Ian Lynagh's avatar
Ian Lynagh committed
466
        Nothing ->
sof's avatar
sof committed
467
          do
Ian Lynagh's avatar
Ian Lynagh committed
468
            -- enter the interactive loop
469
            runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
Ian Lynagh's avatar
Ian Lynagh committed
470
        Just exprs -> do
Ian Lynagh's avatar
Ian Lynagh committed
471
            -- just evaluate the expression we were given
Ian Lynagh's avatar
Ian Lynagh committed
472
            enqueueCommands exprs
dterei's avatar
dterei committed
473
474
475
476
477
478
479
480
            let hdle e = do st <- getGHCiState
                            -- flush the interpreter's stdout/stderr on exit (#3890)
                            flushInterpBuffers
                            -- Jump through some hoops to get the
                            -- current progname in the exception text:
                            -- <progname>: <exception>
                            liftIO $ withProgName (progname st)
                                   $ topHandler e
481
                                   -- this used to be topHandlerFastExit, see #2228
482
            runInputTWithPrefs defaultPrefs defaultSettings $ do
dterei's avatar
dterei committed
483
                runCommands' hdle (return Nothing)
484
485

  -- and finally, exit
Ian Lynagh's avatar
Ian Lynagh committed
486
  liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
487

488
489
runGHCiInput :: InputT GHCi a -> GHCi a
runGHCiInput f = do
Ian Lynagh's avatar
Ian Lynagh committed
490
491
492
493
494
    dflags <- getDynFlags
    histFile <- if dopt Opt_GhciHistory dflags
                then liftIO $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
                                             (return Nothing)
                else return Nothing
dterei's avatar
dterei committed
495
496
497
    runInputT
        (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})
        f
498

499
-- | How to get the next input line from the user
500
501
502
nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
nextInputLine show_prompt is_tty
  | is_tty = do
dterei's avatar
dterei committed
503
504
    prmpt <- if show_prompt then lift mkPrompt else return ""
    r <- getInputLine prmpt
505
506
    incrementLineNo
    return r
507
508
509
  | otherwise = do
    when show_prompt $ lift mkPrompt >>= liftIO . putStr
    fileLoop stdin
510

511
-- NOTE: We only read .ghci files if they are owned by the current user,
dterei's avatar
dterei committed
512
-- and aren't world writable.  Otherwise, we could be accidentally
513
514
-- running code planted by a malicious third party.

rrt's avatar
rrt committed
515
516
517
518
-- 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.
519
520

checkPerms :: String -> IO Bool
521
#ifdef mingw32_HOST_OS
dterei's avatar
dterei committed
522
checkPerms _ = return True
sof's avatar
sof committed
523
#else
Simon Marlow's avatar
Simon Marlow committed
524
checkPerms name =
525
  handleIO (\_ -> return False) $ do
dterei's avatar
dterei committed
526
527
528
529
530
531
532
533
    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 = System.Posix.fileMode st
        if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
dterei's avatar
dterei committed
534
            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
dterei's avatar
dterei committed
535
            then do
dterei's avatar
dterei committed
536
                putStrLn $ "*** WARNING: " ++ name ++
dterei's avatar
dterei committed
537
538
539
                           " is writable by someone else, IGNORING!"
                return False
            else return True
sof's avatar
sof committed
540
#endif
541

542
543
incrementLineNo :: InputT GHCi ()
incrementLineNo = do
vivian's avatar
vivian committed
544
545
546
547
548
   st <- lift $ getGHCiState
   let ln = 1+(line_number st)
   lift $ setGHCiState st{line_number=ln}

fileLoop :: Handle -> InputT GHCi (Maybe String)
549
fileLoop hdl = do
550
   l <- liftIO $ tryIO $ hGetLine hdl
551
   case l of
552
553
        Left e | isEOFError e              -> return Nothing
               | InvalidArgument <- etype  -> return Nothing
554
               | otherwise                 -> liftIO $ ioError e
555
556
557
558
559
                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.
dterei's avatar
dterei committed
560
        Right l' -> do
561
           incrementLineNo
dterei's avatar
dterei committed
562
           return (Just l')
563

Simon Marlow's avatar
Simon Marlow committed
564
mkPrompt :: GHCi String
565
mkPrompt = do
566
  imports <- GHC.getContext
567
  resumes <- GHC.getResumeContext
568
569
570
571

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

585
586
        rev_imports = reverse imports -- rightmost are the most recent
        modules_bit =
587
             hsep [ char '*' <> ppr m | IIModule m <- rev_imports ] <+>
588
589
590
591
592
             hsep (map ppr [ myIdeclName d | IIDecl d <- rev_imports ])

         --  use the 'as' name if there is one
        myIdeclName d | Just m <- ideclAs d = m
                      | otherwise           = unLoc (ideclName d)
593

594
595
596
597
598
599
        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
dterei's avatar
dterei committed
600

601
602
  st <- getGHCiState
  return (showSDoc (f (prompt st)))
603

604

605
606
607
608
609
610
611
612
queryQueue :: GHCi (Maybe String)
queryQueue = do
  st <- getGHCiState
  case cmdqueue st of
    []   -> return Nothing
    c:cs -> do setGHCiState st{ cmdqueue = cs }
               return (Just c)

613
-- | The main read-eval-print loop
614
runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
615
616
runCommands = runCommands' handler

dterei's avatar
dterei committed
617
runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler
618
             -> InputT GHCi (Maybe String) -> InputT GHCi ()
dterei's avatar
dterei committed
619
runCommands' eh gCmd = do
620
    b <- ghandle (\e -> case fromException e of
vivian's avatar
vivian committed
621
                          Just UserInterrupt -> return $ Just False
622
                          _ -> case fromException e of
dterei's avatar
dterei committed
623
624
                                 Just ghce ->
                                   do liftIO (print (ghce :: GhcException))
vivian's avatar
vivian committed
625
                                      return Nothing
626
627
                                 _other ->
                                   liftIO (Exception.throwIO e))
dterei's avatar
dterei committed
628
            (runOneCommand eh gCmd)
vivian's avatar
vivian committed
629
630
    case b of
      Nothing -> return ()
dterei's avatar
dterei committed
631
      Just _  -> runCommands' eh gCmd
632

633
-- | Evaluate a single line of user input (either :<command> or Haskell code)
634
runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
vivian's avatar
vivian committed
635
            -> InputT GHCi (Maybe Bool)
dterei's avatar
dterei committed
636
runOneCommand eh gCmd = do
637
638
  -- run a previously queued command if there is one, otherwise get new
  -- input from user
dterei's avatar
dterei committed
639
640
641
  mb_cmd0 <- noSpace (lift queryQueue)
  mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0
  case mb_cmd1 of
vivian's avatar
vivian committed
642
643
    Nothing -> return Nothing
    Just c  -> ghciHandle (\e -> lift $ eh e >>= return . Just) $
644
645
             handleSourceError printErrorAndKeepGoing
               (doCommand c)
vivian's avatar
vivian committed
646
647
               -- source error's are handled by runStmt
               -- is the handler necessary here?
648
  where
649
    printErrorAndKeepGoing err = do
650
        GHC.printException err
vivian's avatar
vivian committed
651
        return $ Just True
652

653
    noSpace q = q >>= maybe (return Nothing)
dterei's avatar
dterei committed
654
655
656
                            (\c -> case removeSpaces c of
                                     ""   -> noSpace q
                                     ":{" -> multiLineCmd q
657
                                     c'   -> return (Just c') )
658
    multiLineCmd q = do
659
      st <- lift getGHCiState
660
      let p = prompt st
661
      lift $ setGHCiState st{ prompt = "%s| " }
662
      mb_cmd <- collectCommand q ""
dterei's avatar
dterei committed
663
      lift $ getGHCiState >>= \st' -> setGHCiState st'{ prompt = p }
664
      return mb_cmd
dterei's avatar
dterei committed
665
    -- we can't use removeSpaces for the sublines here, so
666
    -- multiline commands are somewhat more brittle against
dterei's avatar
dterei committed
667
668
    -- fileformat errors (such as \r in dos input on unix),
    -- we get rid of any extra spaces for the ":}" test;
669
    -- we also avoid silent failure if ":}" is not found;
dterei's avatar
dterei committed
670
    -- and since there is no (?) valid occurrence of \r (as
671
672
    -- opposed to its String representation, "\r") inside a
    -- ghci command, we replace any such with ' ' (argh:-(
dterei's avatar
dterei committed
673
    collectCommand q c = q >>=
674
      maybe (liftIO (ioError collectError))
dterei's avatar
dterei committed
675
676
            (\l->if removeSpaces l == ":}"
                 then return (Just $ removeSpaces c)
677
                 else collectCommand q (c ++ "\n" ++ map normSpace l))
678
      where normSpace '\r' = ' '
dterei's avatar
dterei committed
679
            normSpace   x  = x
dterei's avatar
dterei committed
680
    -- SDM (2007-11-07): is userError the one to use here?
681
    collectError = userError "unterminated multiline command :{ .. :}"
682
683
684
685
686

    -- | Handle a line of input
    doCommand :: String -> InputT GHCi (Maybe Bool)

    -- command
vivian's avatar
vivian committed
687
688
689
690
691
    doCommand (':' : cmd) = do
      result <- specialCommand cmd
      case result of
        True -> return Nothing
        _    -> return $ Just True
692
693
694

    -- haskell
    doCommand stmt = do
vivian's avatar
vivian committed
695
696
      ml <- lift $ isOptionSet Multiline
      if ml
dterei's avatar
dterei committed
697
698
        then do
          mb_stmt <- checkInputForLayout stmt gCmd
vivian's avatar
vivian committed
699
700
701
702
703
704
705
706
707
708
709
          case mb_stmt of
            Nothing      -> return $ Just True
            Just ml_stmt -> do
              result <- timeIt $ lift $ runStmt ml_stmt GHC.RunToCompletion
              return $ Just result
        else do
          result <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion
          return $ Just result

-- #4316
-- lex the input.  If there is an unclosed layout context, request input
vivian's avatar
vivian committed
710
checkInputForLayout :: String -> InputT GHCi (Maybe String)
vivian's avatar
vivian committed
711
                    -> InputT GHCi (Maybe String)
vivian's avatar
vivian committed
712
checkInputForLayout stmt getStmt = do
vivian's avatar
vivian committed
713
714
   dflags' <- lift $ getDynFlags
   let dflags = xopt_set dflags' Opt_AlternativeLayoutRule
dterei's avatar
dterei committed
715
716
717
718
   st0 <- lift $ getGHCiState
   let buf'   =  stringToStringBuffer stmt
       loc    = mkRealSrcLoc (fsLit (progname st0)) (line_number st0) 1
       pstate = Lexer.mkPState dflags buf' loc
vivian's avatar
vivian committed
719
720
721
   case Lexer.unP goToEnd pstate of
     (Lexer.POk _ False) -> return $ Just stmt
     _other              -> do
dterei's avatar
dterei committed
722
723
724
       st1 <- lift getGHCiState
       let p = prompt st1
       lift $ setGHCiState st1{ prompt = "%s| " }
vivian's avatar
vivian committed
725
726
727
       mb_stmt <- ghciHandle (\ex -> case fromException ex of
                            Just UserInterrupt -> return Nothing
                            _ -> case fromException ex of
dterei's avatar
dterei committed
728
729
                                 Just ghce ->
                                   do liftIO (print (ghce :: GhcException))
vivian's avatar
vivian committed
730
                                      return Nothing
dterei's avatar
dterei committed
731
                                 _other -> liftIO (Exception.throwIO ex))
vivian's avatar
vivian committed
732
                     getStmt
dterei's avatar
dterei committed
733
       lift $ getGHCiState >>= \st' -> setGHCiState st'{ prompt = p }
vivian's avatar
vivian committed
734
735
736
737
738
739
       -- the recursive call does not recycle parser state
       -- as we use a new string buffer
       case mb_stmt of
         Nothing  -> return Nothing
         Just str -> if str == ""
           then return $ Just stmt
vivian's avatar
vivian committed
740
741
           else do
             checkInputForLayout (stmt++"\n"++str) getStmt
vivian's avatar
vivian committed
742
743
     where goToEnd = do
             eof <- Lexer.nextIsEOF
dterei's avatar
dterei committed
744
             if eof
vivian's avatar
vivian committed
745
746
               then Lexer.activeContext
               else Lexer.lexer return >> goToEnd
747
748
749
750
751
752

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

753
754
755
-- | If we one of these strings prefixes a command, then we treat it as a decl
-- rather than a stmt.
declPrefixes :: [String]
756
757
declPrefixes = ["class ","data ","newtype ","type ","instance ", "deriving ",
                "foreign "]
758

759
-- | Entry point to execute some haskell code from user
760
761
runStmt :: String -> SingleStep -> GHCi Bool
runStmt stmt step
762
 -- empty
763
764
 | null (filter (not.isSpace) stmt)
 = return False
765
766

 -- import
767
 | "import " `isPrefixOf` stmt
768
 = do addImportToContext stmt; return False
769
770

 -- data, class, newtype...
771
772
773
774
 | any (flip isPrefixOf stmt) declPrefixes
 = do _ <- liftIO $ tryIO $ hFlushAll stdin
      result <- GhciMonad.runDecls stmt
      afterRunStmt (const True) (GHC.RunOk result)
775

776
 | otherwise
777
 = do -- In the new IO library, read handles buffer data even if the Handle
778
779
780
781
      -- is set to NoBuffering.  This causes problems for GHCi where there
      -- are really two stdin Handles.  So we flush any bufferred data in
      -- GHCi's stdin Handle here (only relevant if stdin is attached to
      -- a file, otherwise the read buffer can't be flushed).
782
      _ <- liftIO $ tryIO $ hFlushAll stdin
783
784
785
786
      m_result <- GhciMonad.runStmt stmt step
      case m_result of
        Nothing     -> return False
        Just result -> afterRunStmt (const True) result
787

788
-- | Clean up the GHCi environment after a statement has run
Simon Marlow's avatar
Simon Marlow committed
789
afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
790
afterRunStmt _ (GHC.RunException e) = throw e
791
afterRunStmt step_here run_result = do
792
  resumes <- GHC.getResumeContext
Simon Marlow's avatar
Simon Marlow committed
793
794
795
  case run_result of
     GHC.RunOk names -> do
        show_types <- isOptionSet ShowType
796
        when show_types $ printTypeOfNames names
797
798
     GHC.RunBreak _ names mb_info
         | isNothing  mb_info ||
799
           step_here (GHC.resumeSpan $ head resumes) -> do
800
               mb_id_loc <- toBreakIdAndLocation mb_info
dterei's avatar
dterei committed
801
802
               let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
               if (null bCmd)
803
                 then printStoppedAtBreakInfo (head resumes) names
dterei's avatar
dterei committed
804
                 else enqueueCommands [bCmd]
805
806
807
808
               -- run the command set with ":set stop <cmd>"
               st <- getGHCiState
               enqueueCommands [stop st]
               return ()
809
         | otherwise -> resume step_here GHC.SingleStep >>=
810
                        afterRunStmt step_here >> return ()
Simon Marlow's avatar
Simon Marlow committed
811
812
     _ -> return ()

813
  flushInterpBuffers
Ian Lynagh's avatar
Ian Lynagh committed
814
  liftIO installSignalHandlers
815
  b <- isOptionSet RevertCAFs
816
  when b revertCAFs
817

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

820
821
822
toBreakIdAndLocation ::
  Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
toBreakIdAndLocation Nothing = return Nothing
dterei's avatar
dterei committed
823
824
825
toBreakIdAndLocation (Just inf) = do
  let md = GHC.breakInfo_module inf
      nm = GHC.breakInfo_number inf
826
  st <- getGHCiState
827
  return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
dterei's avatar
dterei committed
828
                                  breakModule loc == md,
829
830
831
                                  breakTick loc == nm ]

printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
dterei's avatar
dterei committed
832
printStoppedAtBreakInfo res names = do
833
  printForUser $ ptext (sLit "Stopped at") <+>
dterei's avatar
dterei committed
834
    ppr (GHC.resumeSpan res)
835
836
837
  --  printTypeOfNames session names
  let namesSorted = sortBy compareNames names
  tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
dterei's avatar
dterei committed
838
  docs <- mapM pprTypeAndContents [i | AnId i <- tythings]
839
  printForUserPartWay $ vcat docs
840

841
842
843
printTypeOfNames :: [Name] -> GHCi ()
printTypeOfNames names
 = mapM_ (printTypeOfName ) $ sortBy compareNames names
844
845
846

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

849
850
851
printTypeOfName :: Name -> GHCi ()
printTypeOfName n
   = do maybe_tything <- GHC.lookupName n
852
853
854
        case maybe_tything of
            Nothing    -> return ()
            Just thing -> printTyThing thing
855

856

857
data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
858

859
-- | Entry point for execution a ':<command>' input from user
860
861
specialCommand :: String -> InputT GHCi Bool
specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
862
863
specialCommand str = do
  let (cmd,rest) = break isSpace str
864
  maybe_cmd <- lift $ lookupCommand cmd
Simon Marlow's avatar
Simon Marlow committed
865
  case maybe_cmd of
866
    GotCommand (_,f,_) -> f (dropWhile isSpace rest)
867
    BadCommand ->
868
      do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
869
870
871
                           ++ shortHelpText)
         return False
    NoLastCommand ->
872
      do liftIO $ hPutStr stdout ("there is no last command to perform\n"
873
874
875
                           ++ shortHelpText)
         return False

876
877
878
shellEscape :: String -> GHCi Bool
shellEscape str = liftIO (system str >> return False)

879
880
881
882
883
884
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
885
lookupCommand str = do
Ian Lynagh's avatar
Ian Lynagh committed
886
  mc <- liftIO $ lookupCommand' str
887
888
889
890
891
892
893
  st <- getGHCiState
  setGHCiState st{ last_command = mc }
  return $ case mc of
           Just c -> GotCommand c
           Nothing -> BadCommand

lookupCommand' :: String -> IO (Maybe Command)
894
895
lookupCommand' ":" = return Nothing
lookupCommand' str' = do
Simon Marlow's avatar
Simon Marlow committed
896
  macros <- readIORef macros_ref
897
898
  let{ (str, cmds) = case str' of
      ':' : rest -> (rest, builtin_commands)
899
      _ -> (str', builtin_commands ++ macros) }
Simon Marlow's avatar
Simon Marlow committed
900
  -- look for exact match first, then the first prefix match
901
902
903
  -- We consider builtin commands first: since new macros are appended
  -- on the *end* of the macros list, this is consistent with the view
  -- that things defined earlier should take precedence. See also #3858
904
905
  return $ case [ c | c <- cmds, str == cmdName c ] of
           c:_ -> Just c
906
           [] -> case [ c | c@(s,_,_) <- cmds, str `isPrefixOf` s ] of
907
908
                 [] -> Nothing
                 c:_ -> Just c
909
910
911

getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
getCurrentBreakSpan = do
912
  resumes <- GHC.getResumeContext
913
914
  case resumes of
    [] -> return Nothing
Simon Marlow's avatar
Simon Marlow committed
915
    (r:_) -> do
916
917
918
919
920
        let ix = GHC.resumeHistoryIx r
        if ix == 0
           then return (Just (GHC.resumeSpan r))
           else do
                let hist = GHC.resumeHistory r !! (ix-1)
dterei's avatar
dterei committed
921
922
                pan <- GHC.getHistorySpan hist
                return (Just pan)
923

924
925
getCurrentBreakModule :: GHCi (Maybe Module)
getCurrentBreakModule = do
926
  resumes <- GHC.getResumeContext