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

Ian Lynagh's avatar
Ian Lynagh committed
4
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
5
6
7
8
-----------------------------------------------------------------------------
--
-- GHC Interactive User Interface
--
9
-- (c) The GHC Team 2005-2006
10
11
--
-----------------------------------------------------------------------------
12

13
module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
14

15
16
#include "HsVersions.h"

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

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

31
import Packages
32
-- import PackageConfig
33
import UniqFM
34

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

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

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

65
66
67
import System.Console.Haskeline as Haskeline
import qualified System.Console.Haskeline.Encoding as Encoding
import Control.Monad.Trans
68
69
70

--import SystemExts

71
72
import Exception hiding (catch, block, unblock)

73
-- import Control.Concurrent
74

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

#if __GLASGOW_HASKELL__ >= 611
import GHC.IO.Exception	( IOErrorType(InvalidArgument) )
94
import GHC.IO.Handle    ( hFlushAll )
95
#else
Simon Marlow's avatar
Simon Marlow committed
96
import GHC.IOBase	( IOErrorType(InvalidArgument) )
97
98
#endif

Ian Lynagh's avatar
Ian Lynagh committed
99
import GHC.TopHandler
100

101
import Data.IORef	( IORef, readIORef, writeIORef )
102

103
104
-----------------------------------------------------------------------------

105
106
107
ghciWelcomeMsg :: String
ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
                 ": http://www.haskell.org/ghc/  :? for help"
108

Simon Marlow's avatar
Simon Marlow committed
109
cmdName :: Command -> String
110
cmdName (n,_,_) = n
111

Simon Marlow's avatar
Simon Marlow committed
112
GLOBAL_VAR(macros_ref, [], [Command])
Simon Marlow's avatar
Simon Marlow committed
113
114

builtin_commands :: [Command]
115
builtin_commands = [
116
117
118
119
120
121
122
123
124
125
126
127
  -- 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),
128
129
  ("ctags",     keepGoing createCTagsWithLineNumbersCmd, completeFilename),
  ("ctags!",    keepGoing createCTagsWithRegExesCmd, completeFilename),
130
131
132
133
134
135
136
137
138
139
140
141
142
  ("def",       keepGoing (defineMacro False),  completeExpression),
  ("def!",      keepGoing (defineMacro True),   completeExpression),
  ("delete",    keepGoing deleteCmd,            noCompletion),
  ("edit",      keepGoing editFile,             completeFilename),
  ("etags",     keepGoing createETagsFileCmd,   completeFilename),
  ("force",     keepGoing forceCmd,             completeExpression),
  ("forward",   keepGoing forwardCmd,           noCompletion),
  ("help",      keepGoing help,                 noCompletion),
  ("history",   keepGoing historyCmd,           noCompletion),
  ("info",      keepGoing' info,                completeIdentifier),
  ("kind",      keepGoing' kindOfType,          completeIdentifier),
  ("load",      keepGoingPaths loadModule_,     completeHomeModuleOrFile),
  ("list",      keepGoing' listCmd,             noCompletion),
lykahb@gmail.com's avatar
lykahb@gmail.com committed
143
  ("module",    keepGoing setContext,           completeSetModule),
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
  ("main",      keepGoing runMain,              completeFilename),
  ("print",     keepGoing printCmd,             completeExpression),
  ("quit",      quit,                           noCompletion),
  ("reload",    keepGoing' reloadModule,        noCompletion),
  ("run",       keepGoing runRun,               completeFilename),
  ("set",       keepGoing setCmd,               completeSetOptions),
  ("show",      keepGoing showCmd,              completeShowOptions),
  ("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)
159
160
  ]

161
162
163
164
165
166
167
168
169

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

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


180
181
182
183
184
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
185

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

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

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

 "\n" ++
 " -- Commands for changing settings:\n" ++
253
254
255
256
 "\n" ++
 "   :set <option> ...           set options\n" ++
 "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
 "   :set prog <progname>        set the value returned by System.getProgName\n" ++
Simon Marlow's avatar
Simon Marlow committed
257
 "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
Ian Lynagh's avatar
Ian Lynagh committed
258
 "   :set editor <cmd>           set the command used for :edit\n" ++
259
 "   :set stop [<n>] <cmd>       set the command to run when a breakpoint is hit\n" ++
260
261
 "   :unset <option> ...         unset options\n" ++
 "\n" ++
262
 "  Options for ':set' and ':unset':\n" ++
263
264
265
266
267
 "\n" ++
 "    +r            revert top-level expressions after each evaluation\n" ++
 "    +s            print timing/memory stats after each evaluation\n" ++
 "    +t            print type after evaluation\n" ++
 "    -<flags>      most GHC command line flags can also be set here\n" ++
mnislaih's avatar
mnislaih committed
268
 "                         (eg. -v2, -fglasgow-exts, etc.)\n" ++
269
270
 "                    for GHCi-specific flags, see User's Guide,\n"++
 "                    Flag reference, Interactive-mode options\n" ++
271
272
273
274
275
276
277
 "\n" ++
 " -- Commands for displaying information:\n" ++
 "\n" ++
 "   :show bindings              show the current bindings made at the prompt\n" ++
 "   :show breaks                show the active breakpoints\n" ++
 "   :show context               show the breakpoint context\n" ++
 "   :show modules               show the currently loaded modules\n" ++
278
279
 "   :show packages              show the currently active package flags\n" ++
 "   :show languages             show the currently active language flags\n" ++
280
281
 "   :show <setting>             show value of <setting>, which is one of\n" ++
 "                                  [args, prog, prompt, editor, stop]\n" ++
282
 "\n" 
283

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

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

297
298
interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String]
              -> Ghc ()
299
interactiveUI srcs maybe_exprs = do
300
301
302
   -- 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
303
304
   i <- liftIO $ isProfiled
   when (i /= 0) $ 
305
306
     ghcError (InstallationError "GHCi cannot be used when compiled with -prof")

307
308
309
310
311
312
313
314
   -- 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.
315
316
317
   _ <- liftIO $ newStablePtr stdin
   _ <- liftIO $ newStablePtr stdout
   _ <- liftIO $ newStablePtr stderr
318

Ian Lynagh's avatar
Ian Lynagh committed
319
    -- Initialise buffering for the *interpreted* I/O system
320
   initInterpBuffering
321

322
   liftIO $ when (isNothing maybe_exprs) $ do
Ian Lynagh's avatar
Ian Lynagh committed
323
324
325
326
327
328
329
330
331
332
        -- 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
333
334
335
336
337
338
#if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611
        -- 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
339

340
   -- initial context is just the Prelude
341
   prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing
342
   GHC.setContext [] [(prel_mod, Nothing)]
343

344
   default_editor <- liftIO $ findEditor
Simon Marlow's avatar
Simon Marlow committed
345

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

364
365
   return ()

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

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

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

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

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

390
391
392
393
   canonicalizePath' :: FilePath -> IO (Maybe FilePath)
   canonicalizePath' fp = liftM Just (canonicalizePath fp)
                `catchIO` \_ -> return Nothing

394
395
396
397
398
399
   sourceConfigFile :: FilePath -> GHCi ()
   sourceConfigFile file = do
     exists <- io $ doesFileExist file
     when exists $ do
       dir_ok  <- io $ checkPerms (getDirectory file)
       file_ok <- io $ checkPerms file
400
       when (dir_ok && file_ok) $ do
401
402
403
         either_hdl <- io $ IO.try (openFile file ReadMode)
         case either_hdl of
           Left _e   -> return ()
404
405
406
407
408
           -- 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.
           Right hdl -> runInputTWithPrefs defaultPrefs defaultSettings $ do
                            runCommands $ fileLoop hdl
409
410
     where
      getDirectory f = case takeDirectory f of "" -> "."; d -> d
Ian Lynagh's avatar
Ian Lynagh committed
411

412
  when (read_dot_files) $ do
413
414
415
    mcfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
    mcfgs <- io $ mapM canonicalizePath' (catMaybes mcfgs0)
    mapM_ sourceConfigFile $ nub $ catMaybes mcfgs
416
417
        -- nub, because we don't want to read .ghci twice if the
        -- CWD is $HOME.
418

419
  -- Perform a :load for files given on the GHCi command line
420
421
422
  -- 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
423
     ok <- ghciHandle (\e -> do showException e; return Failed) $
424
425
426
427
428
                -- 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
429
     when (isJust maybe_exprs && failed ok) $
Ian Lynagh's avatar
Ian Lynagh committed
430
        io (exitWith (ExitFailure 1))
431

432
433
  -- if verbosity is greater than 0, or we are connected to a
  -- terminal, display the prompt in the interactive loop.
434
  is_tty <- io (hIsTerminalDevice stdin)
435
  dflags <- getDynFlags
436
437
  let show_prompt = verbosity dflags > 0 || is_tty

Ian Lynagh's avatar
Ian Lynagh committed
438
  case maybe_exprs of
Ian Lynagh's avatar
Ian Lynagh committed
439
        Nothing ->
sof's avatar
sof committed
440
          do
Ian Lynagh's avatar
Ian Lynagh committed
441
            -- enter the interactive loop
442
            runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
Ian Lynagh's avatar
Ian Lynagh committed
443
        Just exprs -> do
Ian Lynagh's avatar
Ian Lynagh committed
444
            -- just evaluate the expression we were given
Ian Lynagh's avatar
Ian Lynagh committed
445
            enqueueCommands exprs
Ian Lynagh's avatar
Ian Lynagh committed
446
            let handle e = do st <- getGHCiState
447
448
                              -- flush the interpreter's stdout/stderr on exit (#3890)
                              flushInterpBuffers
Ian Lynagh's avatar
Ian Lynagh committed
449
450
451
452
                                   -- Jump through some hoops to get the
                                   -- current progname in the exception text:
                                   -- <progname>: <exception>
                              io $ withProgName (progname st)
453
454
                                   -- this used to be topHandlerFastExit, see #2228
                                 $ topHandler e
455
456
            runInputTWithPrefs defaultPrefs defaultSettings $ do
                runCommands' handle (return Nothing)
457
458

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

461
462
463
464
465
466
runGHCiInput :: InputT GHCi a -> GHCi a
runGHCiInput f = do
    histFile <- io $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
                        (return Nothing)
    let settings = setComplete ghciCompleteWord
                    $ defaultSettings {historyFile = histFile}
467
    runInputT settings f
468

469
470
471
nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
nextInputLine show_prompt is_tty
  | is_tty = do
472
    prompt <- if show_prompt then lift mkPrompt else return ""
473
474
475
476
    getInputLine prompt
  | otherwise = do
    when show_prompt $ lift mkPrompt >>= liftIO . putStr
    fileLoop stdin
477

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

rrt's avatar
rrt committed
482
483
484
485
-- 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.
486
487

checkPerms :: String -> IO Bool
488
#ifdef mingw32_HOST_OS
Simon Marlow's avatar
Simon Marlow committed
489
checkPerms _ =
490
  return True
sof's avatar
sof committed
491
#else
Simon Marlow's avatar
Simon Marlow committed
492
checkPerms name =
493
  handleIO (\_ -> return False) $ do
494
495
496
497
498
499
     st <- getFileStatus name
     me <- getRealUserID
     if fileOwner st /= me then do
   	putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
   	return False
      else do
Ian Lynagh's avatar
Ian Lynagh committed
500
   	let mode =  System.Posix.fileMode st
501
502
503
504
505
506
507
   	if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
   	   || (otherWriteMode == (mode `intersectFileModes` otherWriteMode)) 
   	   then do
   	       putStrLn $ "*** WARNING: " ++ name ++ 
   			  " is writable by someone else, IGNORING!"
   	       return False
   	  else return True
sof's avatar
sof committed
508
#endif
509

510
511
fileLoop :: MonadIO m => Handle -> InputT m (Maybe String)
fileLoop hdl = do
512
   l <- liftIO $ IO.try $ hGetLine hdl
513
   case l of
514
515
        Left e | isEOFError e              -> return Nothing
               | InvalidArgument <- etype  -> return Nothing
516
               | otherwise                 -> liftIO $ ioError e
517
518
519
520
521
                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.
522
        Right l -> return (Just l)
523

Simon Marlow's avatar
Simon Marlow committed
524
mkPrompt :: GHCi String
525
mkPrompt = do
526
527
  (toplevs,exports) <- GHC.getContext
  resumes <- GHC.getResumeContext
Simon Marlow's avatar
Simon Marlow committed
528
  -- st <- getGHCiState
529
530
531
532

  context_bit <-
        case resumes of
            [] -> return empty
Simon Marlow's avatar
Simon Marlow committed
533
            r:_ -> do
534
535
536
537
538
                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)
539
                        span <- GHC.getHistorySpan hist
540
541
542
                        return (brackets (ppr (negate ix) <> char ':' 
                                          <+> ppr span) <> space)
  let
Simon Marlow's avatar
Simon Marlow committed
543
        dots | _:rs <- resumes, not (null rs) = text "... "
544
545
546
             | otherwise = empty

        modules_bit = 
Simon Marlow's avatar
Simon Marlow committed
547
548
549
550
551
       -- ToDo: maybe...
       --  let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
       --  hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
       --  hsep (map (\m -> char '!'  <> ppr (GHC.moduleName m)) bexports) <+>
             hsep (map (\m -> char '*'  <> ppr (GHC.moduleName m)) toplevs) <+>
552
             hsep (map (ppr . GHC.moduleName) (nub (map fst exports)))
553

554
555
556
557
558
559
560
561
562
        deflt_prompt = dots <> context_bit <> modules_bit

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

564

565
566
567
568
569
570
571
572
queryQueue :: GHCi (Maybe String)
queryQueue = do
  st <- getGHCiState
  case cmdqueue st of
    []   -> return Nothing
    c:cs -> do setGHCiState st{ cmdqueue = cs }
               return (Just c)

573
runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
574
575
runCommands = runCommands' handler

576
runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
577
             -> InputT GHCi (Maybe String) -> InputT GHCi ()
578
runCommands' eh getCmd = do
579
580
581
582
583
584
585
586
    b <- ghandle (\e -> case fromException e of
                          Just UserInterrupt -> return False
                          _ -> case fromException e of
                                 Just ghc_e ->
                                   do liftIO (print (ghc_e :: GhcException))
                                      return True
                                 _other ->
                                   liftIO (Exception.throwIO e))
587
588
589
590
591
592
593
            (runOneCommand eh getCmd)
    if b then return () else runCommands' eh getCmd

runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
            -> InputT GHCi Bool
runOneCommand eh getCmd = do
  mb_cmd <- noSpace (lift queryQueue)
594
  mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
595
596
597
  case mb_cmd of
    Nothing -> return True
    Just c  -> ghciHandle (lift . eh) $
598
599
             handleSourceError printErrorAndKeepGoing
               (doCommand c)
600
  where
601
602
    printErrorAndKeepGoing err = do
        GHC.printExceptionAndWarnings err
603
        return False
604

605
606
607
608
609
610
    noSpace q = q >>= maybe (return Nothing)
                            (\c->case removeSpaces c of 
                                   ""   -> noSpace q
                                   ":{" -> multiLineCmd q
                                   c    -> return (Just c) )
    multiLineCmd q = do
611
      st <- lift getGHCiState
612
      let p = prompt st
613
      lift $ setGHCiState st{ prompt = "%s| " }
614
      mb_cmd <- collectCommand q ""
615
      lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p }
616
617
618
619
620
621
622
623
624
625
      return mb_cmd
    -- we can't use removeSpaces for the sublines here, so 
    -- multiline commands are somewhat more brittle against
    -- fileformat errors (such as \r in dos input on unix), 
    -- we get rid of any extra spaces for the ":}" test; 
    -- we also avoid silent failure if ":}" is not found;
    -- and since there is no (?) valid occurrence of \r (as 
    -- opposed to its String representation, "\r") inside a
    -- ghci command, we replace any such with ' ' (argh:-(
    collectCommand q c = q >>= 
626
      maybe (liftIO (ioError collectError))
627
628
            (\l->if removeSpaces l == ":}" 
                 then return (Just $ removeSpaces c) 
629
                 else collectCommand q (c ++ "\n" ++ map normSpace l))
630
631
632
633
634
      where normSpace '\r' = ' '
            normSpace   c  = c
    -- QUESTION: is userError the one to use here?
    collectError = userError "unterminated multiline command :{ .. :}"
    doCommand (':' : cmd) = specialCommand cmd
635
    doCommand stmt        = do _ <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion
636
                               return False
637
638
639
640
641
642

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

643

644
645
runStmt :: String -> SingleStep -> GHCi Bool
runStmt stmt step
646
647
648
649
 | null (filter (not.isSpace) stmt)
 = return False
 | "import " `isPrefixOf` stmt
 = do newContextCmd (Import stmt); return False
650
 | otherwise
651
652
653
654
655
656
657
 = do
#if __GLASGOW_HASKELL__ >= 611
      -- In the new IO library, read handles buffer data even if the Handle
      -- 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).
658
      _ <- liftIO $ IO.try $ hFlushAll stdin
659
#endif
660
      result <- withFlattenedDynflags $ GhciMonad.runStmt stmt step
661
      afterRunStmt (const True) result
662

663
--afterRunStmt :: GHC.RunResult -> GHCi Bool
Simon Marlow's avatar
Simon Marlow committed
664
                                 -- False <=> the statement failed to compile
Simon Marlow's avatar
Simon Marlow committed
665
afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
666
afterRunStmt _ (GHC.RunException e) = throw e
667
afterRunStmt step_here run_result = do
668
  resumes <- GHC.getResumeContext
Simon Marlow's avatar
Simon Marlow committed
669
670
671
  case run_result of
     GHC.RunOk names -> do
        show_types <- isOptionSet ShowType
672
        when show_types $ printTypeOfNames names
673
674
     GHC.RunBreak _ names mb_info
         | isNothing  mb_info ||
675
           step_here (GHC.resumeSpan $ head resumes) -> do
676
677
678
679
680
               mb_id_loc <- toBreakIdAndLocation mb_info
               let breakCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
               if (null breakCmd)
                 then printStoppedAtBreakInfo (head resumes) names
                 else enqueueCommands [breakCmd]
681
682
683
684
               -- run the command set with ":set stop <cmd>"
               st <- getGHCiState
               enqueueCommands [stop st]
               return ()
685
         | otherwise -> resume step_here GHC.SingleStep >>=
686
                        afterRunStmt step_here >> return ()
Simon Marlow's avatar
Simon Marlow committed
687
688
     _ -> return ()

689
690
691
  flushInterpBuffers
  io installSignalHandlers
  b <- isOptionSet RevertCAFs
692
  when b revertCAFs
693

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

696
697
698
699
toBreakIdAndLocation ::
  Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
toBreakIdAndLocation Nothing = return Nothing
toBreakIdAndLocation (Just info) = do
700
701
702
  let mod = GHC.breakInfo_module info
      nm  = GHC.breakInfo_number info
  st <- getGHCiState
703
704
705
706
707
708
709
710
711
712
713
714
715
  return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
                                  breakModule loc == mod,
                                  breakTick loc == nm ]

printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
printStoppedAtBreakInfo resume names = do
  printForUser $ ptext (sLit "Stopped at") <+>
    ppr (GHC.resumeSpan resume)
  --  printTypeOfNames session names
  let namesSorted = sortBy compareNames names
  tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
  docs <- pprTypeAndContents [id | AnId id <- tythings]
  printForUserPartWay docs
716

717
718
719
printTypeOfNames :: [Name] -> GHCi ()
printTypeOfNames names
 = mapM_ (printTypeOfName ) $ sortBy compareNames names
720
721
722

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

725
726
727
printTypeOfName :: Name -> GHCi ()
printTypeOfName n
   = do maybe_tything <- GHC.lookupName n
728
729
730
        case maybe_tything of
            Nothing    -> return ()
            Just thing -> printTyThing thing
731

732

733
data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
734

735
736
specialCommand :: String -> InputT GHCi Bool
specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
737
738
specialCommand str = do
  let (cmd,rest) = break isSpace str
739
  maybe_cmd <- lift $ lookupCommand cmd
Simon Marlow's avatar
Simon Marlow committed
740
  case maybe_cmd of
741
    GotCommand (_,f,_) -> f (dropWhile isSpace rest)
742
    BadCommand ->
743
      do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
744
745
746
                           ++ shortHelpText)
         return False
    NoLastCommand ->
747
      do liftIO $ hPutStr stdout ("there is no last command to perform\n"
748
749
750
751
752
753
754
755
756
                           ++ shortHelpText)
         return False

lookupCommand :: String -> GHCi (MaybeCommand)
lookupCommand "" = do
  st <- getGHCiState
  case last_command st of
      Just c -> return $ GotCommand c
      Nothing -> return NoLastCommand
Simon Marlow's avatar
Simon Marlow committed
757
lookupCommand str = do
758
759
760
761
762
763
764
765
  mc <- io $ lookupCommand' str
  st <- getGHCiState
  setGHCiState st{ last_command = mc }
  return $ case mc of
           Just c -> GotCommand c
           Nothing -> BadCommand

lookupCommand' :: String -> IO (Maybe Command)
766
767
lookupCommand' ":" = return Nothing
lookupCommand' str' = do
Simon Marlow's avatar
Simon Marlow committed
768
  macros <- readIORef macros_ref
769
770
771
  let{ (str, cmds) = case str' of
      ':' : rest -> (rest, builtin_commands)
      _ -> (str', macros ++ builtin_commands) }
Simon Marlow's avatar
Simon Marlow committed
772
  -- look for exact match first, then the first prefix match
773
774
  return $ case [ c | c <- cmds, str == cmdName c ] of
           c:_ -> Just c
775
           [] -> case [ c | c@(s,_,_) <- cmds, str `isPrefixOf` s ] of
776
777
                 [] -> Nothing
                 c:_ -> Just c
778
779
780

getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
getCurrentBreakSpan = do
781
  resumes <- GHC.getResumeContext
782
783
  case resumes of
    [] -> return Nothing
Simon Marlow's avatar
Simon Marlow committed
784
    (r:_) -> do
785
786
787
788
789
        let ix = GHC.resumeHistoryIx r
        if ix == 0
           then return (Just (GHC.resumeSpan r))
           else do
                let hist = GHC.resumeHistory r !! (ix-1)
790
                span <- GHC.getHistorySpan hist
791
792
                return (Just span)

793
794
getCurrentBreakModule :: GHCi (Maybe Module)
getCurrentBreakModule = do
795
  resumes <- GHC.getResumeContext
796
797
  case resumes of
    [] -> return Nothing
Simon Marlow's avatar
Simon Marlow committed
798
    (r:_) -> do
799
800
        let ix = GHC.resumeHistoryIx r
        if ix == 0
mnislaih's avatar
mnislaih committed
801
           then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
802
803
804
805
           else do
                let hist = GHC.resumeHistory r !! (ix-1)
                return $ Just $ GHC.getHistoryModule  hist

806
807
808
-----------------------------------------------------------------------------
-- Commands

809
810
noArgs :: GHCi () -> String -> GHCi ()
noArgs m "" = m
Simon Marlow's avatar
Simon Marlow committed
811
noArgs _ _  = io $ putStrLn "This command takes no arguments"
812

813
814
815
help :: String -> GHCi ()
help _ = io (putStr helpText)

816
info :: String -> InputT GHCi ()
817
info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
818
819
info s  = handleSourceError GHC.printExceptionAndWarnings $
          withFlattenedDynflags $ do
820
             { let names = words s
821
	     ; dflags <- getDynFlags
822
	     ; let pefas = dopt Opt_PrintExplicitForalls dflags
823
	     ; mapM_ (infoThing pefas) names }
824
  where
825
826
827
    infoThing pefas str = do
	names     <- GHC.parseName str
	mb_stuffs <- mapM GHC.getInfo names
Simon Marlow's avatar
Simon Marlow committed
828
	let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
829
	unqual <- GHC.getPrintUnqual
830
	outputStrLn $ showSDocForUser unqual $
831
     		     vcat (intersperse (text "") $
832
		           map (pprInfo pefas) filtered)
833
834
835
836

  -- Filter out names whose parent is also there Good
  -- example is '[]', which is both a type and data
  -- constructor in the same type
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
837
838
filterOutChildren :: (a -> TyThing) -> [a] -> [a]
filterOutChildren get_thing xs 
839
  = filterOut has_parent xs
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
840
  where
841
842
843
844
    all_names = mkNameSet (map (getName . get_thing) xs)
    has_parent x = case pprTyThingParent_maybe (get_thing x) of
                     Just p  -> getName p `elemNameSet` all_names
                     Nothing -> False
845

846
847
848
pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
pprInfo pefas (thing, fixity, insts)
  =  pprTyThingInContextLoc pefas thing
849
850
  $$ show_fixity fixity
  $$ vcat (map GHC.pprInstance insts)
851
  where
852
    show_fixity fix 
853
854
	| fix == GHC.defaultFixity = empty
	| otherwise		   = ppr fix <+> ppr (GHC.getName thing)
855

856
runMain :: String -> GHCi ()
Ian Lynagh's avatar
Ian Lynagh committed
857
858
859
runMain s = case toArgs s of
            Left err   -> io (hPutStrLn stderr err)
            Right args ->
860
861
                withFlattenedDynflags $ do
                   dflags <- getDynFlags
Ian Lynagh's avatar
Ian Lynagh committed
862
863
864
865
866
867
868
869
870
871
872
873
                   case mainFunIs dflags of
                       Nothing -> doWithArgs args "main"
                       Just f  -> doWithArgs args f

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

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

875
addModule :: [FilePath] -> InputT GHCi ()
sof's avatar
sof committed
876
addModule files = do
877
  lift revertCAFs -- always revert CAFs on load/add.
878
  files <- mapM expandPath files
879
  targets <- mapM (\m -> GHC.guessTarget m Nothing) files
Simon Marlow's avatar
Simon Marlow committed
880
  -- remove old targets with the same id; e.g. for :add *M
881
882
883
884
885
  mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
  mapM_ GHC.addTarget targets
  prev_context <- GHC.getContext
  ok <- trySuccess $ GHC.load LoadAllTargets
  afterLoad ok False prev_context
886

887
changeDirectory :: String -> InputT GHCi ()
888
889
changeDirectory "" = do
  -- :cd on its own changes to the user's home directory
890
  either_dir <- liftIO $ IO.try getHomeDirectory
891
892
893
  case either_dir of
     Left _e -> return ()
     Right dir -> changeDirectory dir
894
changeDirectory dir = do
895
  graph <- GHC.getModuleGraph
896
  when (not (null graph)) $