InteractiveUI.hs 112 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
  dflags <- getDynFlags
436
  when (read_dot_files) $ do
437
    mcfgs0 <- sequence $ [ current_dir, app_user_dir, home_dir ] ++ map (return . Just ) (ghciScripts dflags)
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
                -- TODO: this is a hack.
449
450
                runInputTWithPrefs defaultPrefs defaultSettings $
                    loadModule paths
Ian Lynagh's avatar
Ian Lynagh committed
451
     when (isJust maybe_exprs && failed ok) $
Ian Lynagh's avatar
Ian Lynagh committed
452
        liftIO (exitWith (ExitFailure 1))
453

454
455
  -- 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
456
  is_tty <- liftIO (hIsTerminalDevice stdin)
457
458
  let show_prompt = verbosity dflags > 0 || is_tty

459
460
461
  -- reset line number
  getGHCiState >>= \st -> setGHCiState st{line_number=1}

Ian Lynagh's avatar
Ian Lynagh committed
462
  case maybe_exprs of
Ian Lynagh's avatar
Ian Lynagh committed
463
        Nothing ->
sof's avatar
sof committed
464
          do
Ian Lynagh's avatar
Ian Lynagh committed
465
            -- enter the interactive loop
466
            runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
Ian Lynagh's avatar
Ian Lynagh committed
467
        Just exprs -> do
Ian Lynagh's avatar
Ian Lynagh committed
468
            -- just evaluate the expression we were given
Ian Lynagh's avatar
Ian Lynagh committed
469
            enqueueCommands exprs
dterei's avatar
dterei committed
470
471
472
473
474
475
476
477
            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
478
                                   -- this used to be topHandlerFastExit, see #2228
479
            runInputTWithPrefs defaultPrefs defaultSettings $ do
dterei's avatar
dterei committed
480
                runCommands' hdle (return Nothing)
481
482

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

485
486
runGHCiInput :: InputT GHCi a -> GHCi a
runGHCiInput f = do
Ian Lynagh's avatar
Ian Lynagh committed
487
488
489
490
491
    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
492
493
494
    runInputT
        (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})
        f
495

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

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

rrt's avatar
rrt committed
512
513
514
515
-- 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.
516
517

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

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

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

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

  context_bit <-
        case resumes of
            [] -> return empty
Simon Marlow's avatar
Simon Marlow committed
569
            r:_ -> do
570
571
572
573
574
                let ix = GHC.resumeHistoryIx r
                if ix == 0
                   then return (brackets (ppr (GHC.resumeSpan r)) <> space)
                   else do
                        let hist = GHC.resumeHistory r !! (ix-1)
dterei's avatar
dterei committed
575
576
577
                        pan <- GHC.getHistorySpan hist
                        return (brackets (ppr (negate ix) <> char ':'
                                          <+> ppr pan) <> space)
578
  let
Simon Marlow's avatar
Simon Marlow committed
579
        dots | _:rs <- resumes, not (null rs) = text "... "
580
581
             | otherwise = empty

582
583
        rev_imports = reverse imports -- rightmost are the most recent
        modules_bit =
584
             hsep [ char '*' <> ppr m | IIModule m <- rev_imports ] <+>
585
586
587
588
589
             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)
590

591
592
593
594
595
596
        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
597

598
599
  st <- getGHCiState
  return (showSDoc (f (prompt st)))
600

601

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

610
-- | The main read-eval-print loop
611
runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
612
613
runCommands = runCommands' handler

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

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

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

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

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

    -- haskell
    doCommand stmt = do
vivian's avatar
vivian committed
692
693
      ml <- lift $ isOptionSet Multiline
      if ml
dterei's avatar
dterei committed
694
695
        then do
          mb_stmt <- checkInputForLayout stmt gCmd
vivian's avatar
vivian committed
696
697
698
699
700
701
702
703
704
705
706
          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
707
checkInputForLayout :: String -> InputT GHCi (Maybe String)
vivian's avatar
vivian committed
708
                    -> InputT GHCi (Maybe String)
vivian's avatar
vivian committed
709
checkInputForLayout stmt getStmt = do
vivian's avatar
vivian committed
710
711
   dflags' <- lift $ getDynFlags
   let dflags = xopt_set dflags' Opt_AlternativeLayoutRule
dterei's avatar
dterei committed
712
713
714
715
   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
716
717
718
   case Lexer.unP goToEnd pstate of
     (Lexer.POk _ False) -> return $ Just stmt
     _other              -> do
dterei's avatar
dterei committed
719
720
721
       st1 <- lift getGHCiState
       let p = prompt st1
       lift $ setGHCiState st1{ prompt = "%s| " }
vivian's avatar
vivian committed
722
723
724
       mb_stmt <- ghciHandle (\ex -> case fromException ex of
                            Just UserInterrupt -> return Nothing
                            _ -> case fromException ex of
dterei's avatar
dterei committed
725
726
                                 Just ghce ->
                                   do liftIO (print (ghce :: GhcException))
vivian's avatar
vivian committed
727
                                      return Nothing
dterei's avatar
dterei committed
728
                                 _other -> liftIO (Exception.throwIO ex))
vivian's avatar
vivian committed
729
                     getStmt
dterei's avatar
dterei committed
730
       lift $ getGHCiState >>= \st' -> setGHCiState st'{ prompt = p }
vivian's avatar
vivian committed
731
732
733
734
735
736
       -- 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
737
738
           else do
             checkInputForLayout (stmt++"\n"++str) getStmt
vivian's avatar
vivian committed
739
740
     where goToEnd = do
             eof <- Lexer.nextIsEOF
dterei's avatar
dterei committed
741
             if eof
vivian's avatar
vivian committed
742
743
               then Lexer.activeContext
               else Lexer.lexer return >> goToEnd
744
745
746
747
748
749

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

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

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

 -- import
764
 | "import " `isPrefixOf` stmt
765
 = do addImportToContext stmt; return False
766
767

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

773
 | otherwise
774
 = do -- In the new IO library, read handles buffer data even if the Handle
775
776
777
778
      -- 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).
779
      _ <- liftIO $ tryIO $ hFlushAll stdin
780
781
782
783
      m_result <- GhciMonad.runStmt stmt step
      case m_result of
        Nothing     -> return False
        Just result -> afterRunStmt (const True) result
784

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

810
  flushInterpBuffers
Ian Lynagh's avatar
Ian Lynagh committed
811
  liftIO installSignalHandlers
812
  b <- isOptionSet RevertCAFs
813
  when b revertCAFs
814

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

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

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

838
839
840
printTypeOfNames :: [Name] -> GHCi ()
printTypeOfNames names
 = mapM_ (printTypeOfName ) $ sortBy compareNames names
841
842
843

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

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

853

854
data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
855

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

873
874
875
shellEscape :: String -> GHCi Bool
shellEscape str = liftIO (system str >> return False)

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

lookupCommand' :: String -> IO (Maybe Command)
891
892
lookupCommand' ":" = return Nothing
lookupCommand' str' = do
Simon Marlow's avatar
Simon Marlow committed
893
  macros <- readIORef macros_ref
894
895
  let{ (str, cmds) = case str' of
      ':' : rest -> (rest, builtin_commands)
896
      _ -> (str', builtin_commands ++ macros) }
Simon Marlow's avatar
Simon Marlow committed
897
  -- look for exact match first, then the first prefix match
898
899
900
  -- 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
901
902
  return $ case [ c | c <- cmds, str == cmdName c ] of
           c:_ -> Just c
903
           [] -> case [ c | c@(s,_,_) <- cmds, str `isPrefixOf` s ] of
904
905
                 [] -> Nothing
                 c:_ -> Just c
906
907
908

getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
getCurrentBreakSpan = do
909
  resumes <- GHC.getResumeContext
910
911
  case resumes of
    [] -> return Nothing
Simon Marlow's avatar
Simon Marlow committed
912
    (r:_) -> do
913
914
915
916
917
        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
918
919
                pan <- GHC.getHistorySpan hist
                return (Just pan)
920

921
922
getCurrentBreakModule :: GHCi (Maybe Module)
getCurrentBreakModule = do
923
  resumes <- GHC.getResumeContext