UI.hs 138 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

12
13
14
{-# OPTIONS -fno-cse #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly

15
16
17
18
-----------------------------------------------------------------------------
--
-- GHC Interactive User Interface
--
19
-- (c) The GHC Team 2005-2006
20
21
--
-----------------------------------------------------------------------------
22

23
module GHCi.UI (
24
25
26
27
28
29
        interactiveUI,
        GhciSettings(..),
        defaultGhciSettings,
        ghciCommands,
        ghciWelcomeMsg
    ) where
30

31
32
#include "HsVersions.h"

dterei's avatar
dterei committed
33
-- GHCi
34
35
36
37
import qualified GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls )
import GHCi.UI.Monad hiding ( args, runStmt, runDecls )
import GHCi.UI.Tags
import GHCi.UI.Info
38
import Debugger
39

40
-- The GHC interface
41
import GHCi
42
43
import GHCi.RemoteTypes
import GHCi.BreakArray
dterei's avatar
dterei committed
44
import DynFlags
45
import ErrUtils
46
import GhcMonad ( modifySession )
dterei's avatar
dterei committed
47
48
49
import qualified GHC
import GHC ( LoadHowMuch(..), Target(..),  TargetId(..), InteractiveImport(..),
             TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,
50
             getModuleGraph, handleSourceError )
51
import HsImpExp
52
import HsSyn
53
import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,
54
                  setInteractivePrintName, hsc_dflags )
dterei's avatar
dterei committed
55
import Module
56
import Name
57
import Packages ( trusted, getPackageDetails, listVisibleModuleNames, pprFlag )
dterei's avatar
dterei committed
58
import PprTyThing
59
60
import PrelNames
import RdrName ( RdrName, getGRE_NameQualifier_maybes, getRdrName )
61
import SrcLoc
dterei's avatar
dterei committed
62
63
64
65
import qualified Lexer

import StringBuffer
import Outputable hiding ( printForUser, printForUserPartWay, bold )
66
67

-- Other random utilities
dterei's avatar
dterei committed
68
import BasicTypes hiding ( isTopLevel )
69
import Config
dterei's avatar
dterei committed
70
71
72
import Digraph
import Encoding
import FastString
73
import Linker
dterei's avatar
dterei committed
74
import Maybes ( orElse, expectJust )
dterei's avatar
dterei committed
75
76
import NameSet
import Panic hiding ( showException )
77
import Util
78
import qualified GHC.LanguageExtensions as LangExt
sof's avatar
sof committed
79

dterei's avatar
dterei committed
80
-- Haskell Libraries
81
import System.Console.Haskeline as Haskeline
82

dterei's avatar
dterei committed
83
import Control.Applicative hiding (empty)
84
85
import Control.DeepSeq (deepseq)
import Control.Monad as Monad
86
import Control.Monad.IO.Class
87
import Control.Monad.Trans.Class
88
import Control.Monad.Trans.Except
89

dterei's avatar
dterei committed
90
import Data.Array
Simon Marlow's avatar
Simon Marlow committed
91
import qualified Data.ByteString.Char8 as BS
dterei's avatar
dterei committed
92
import Data.Char
Ian Lynagh's avatar
Ian Lynagh committed
93
import Data.Function
94
import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )
dterei's avatar
dterei committed
95
96
import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,
                   partition, sort, sortBy )
97
import Data.Maybe
98
import qualified Data.Map as M
dterei's avatar
dterei committed
99

100
import Exception hiding (catch)
101
import Foreign
102
import GHC.Stack hiding (SrcLoc(..))
dterei's avatar
dterei committed
103
104

import System.Directory
105
import System.Environment
dterei's avatar
dterei committed
106
import System.Exit ( exitWith, ExitCode(..) )
dterei's avatar
dterei committed
107
import System.FilePath
ross's avatar
ross committed
108
import System.IO
109
import System.IO.Error
dterei's avatar
dterei committed
110
import System.IO.Unsafe ( unsafePerformIO )
111
import System.Process
Simon Marlow's avatar
Simon Marlow committed
112
import Text.Printf
113
import Text.Read ( readMaybe )
Geraldus's avatar
Geraldus committed
114
import Text.Read.Lex (isSymbolChar)
115

dterei's avatar
dterei committed
116
117
118
119
120
121
#ifndef mingw32_HOST_OS
import System.Posix hiding ( getEnv )
#else
import qualified System.Win32
#endif

dterei's avatar
dterei committed
122
123
import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
import GHC.IO.Handle ( hFlushAll )
dterei's avatar
dterei committed
124
import GHC.TopHandler ( topHandler )
125

126
127
-----------------------------------------------------------------------------

128
129
130
data GhciSettings = GhciSettings {
        availableCommands :: [Command],
        shortHelpText     :: String,
131
132
133
        fullHelpText      :: String,
        defPrompt         :: String,
        defPrompt2        :: String
134
135
136
137
138
139
140
    }

defaultGhciSettings :: GhciSettings
defaultGhciSettings =
    GhciSettings {
        availableCommands = ghciCommands,
        shortHelpText     = defShortHelpText,
141
142
        defPrompt         = default_prompt,
        defPrompt2        = default_prompt2,
143
        fullHelpText      = defFullHelpText
144
145
    }

146
147
148
ghciWelcomeMsg :: String
ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
                 ": http://www.haskell.org/ghc/  :? for help"
149

150
ghciCommands :: [Command]
151
ghciCommands = map mkCmd [
152
153
154
155
156
157
158
159
160
161
162
163
  -- 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),
164
165
  ("ctags",     keepGoing createCTagsWithLineNumbersCmd, completeFilename),
  ("ctags!",    keepGoing createCTagsWithRegExesCmd, completeFilename),
166
167
168
  ("def",       keepGoing (defineMacro False),  completeExpression),
  ("def!",      keepGoing (defineMacro True),   completeExpression),
  ("delete",    keepGoing deleteCmd,            noCompletion),
169
  ("edit",      keepGoing' editFile,            completeFilename),
170
171
172
173
174
  ("etags",     keepGoing createETagsFileCmd,   completeFilename),
  ("force",     keepGoing forceCmd,             completeExpression),
  ("forward",   keepGoing forwardCmd,           noCompletion),
  ("help",      keepGoing help,                 noCompletion),
  ("history",   keepGoing historyCmd,           noCompletion),
175
176
  ("info",      keepGoing' (info False),        completeIdentifier),
  ("info!",     keepGoing' (info True),         completeIdentifier),
177
  ("issafe",    keepGoing' isSafeCmd,           completeModule),
178
179
  ("kind",      keepGoing' (kindOfType False),  completeIdentifier),
  ("kind!",     keepGoing' (kindOfType True),   completeIdentifier),
180
181
  ("load",      keepGoingPaths (loadModule_ False), completeHomeModuleOrFile),
  ("load!",     keepGoingPaths (loadModule_ True), completeHomeModuleOrFile),
182
  ("list",      keepGoing' listCmd,             noCompletion),
183
  ("module",    keepGoing moduleCmd,            completeSetModule),
184
185
186
  ("main",      keepGoing runMain,              completeFilename),
  ("print",     keepGoing printCmd,             completeExpression),
  ("quit",      quit,                           noCompletion),
187
188
  ("reload",    keepGoing' (reloadModule False), noCompletion),
  ("reload!",   keepGoing' (reloadModule True), noCompletion),
189
  ("run",       keepGoing runRun,               completeFilename),
vivian's avatar
vivian committed
190
  ("script",    keepGoing' scriptCmd,           completeFilename),
191
  ("set",       keepGoing setCmd,               completeSetOptions),
192
  ("seti",      keepGoing setiCmd,              completeSeti),
193
  ("show",      keepGoing showCmd,              completeShowOptions),
194
  ("showi",     keepGoing showiCmd,             completeShowiOptions),
195
196
197
198
199
200
201
  ("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),
202
203
  ("unset",     keepGoing unsetOptions,         completeSetOptions),
  ("where",     keepGoing whereCmd,             noCompletion)
204
  ] ++ map mkCmdHidden [ -- hidden commands
205
206
207
208
209
  ("all-types", keepGoing' allTypesCmd),
  ("complete",  keepGoing completeCmd),
  ("loc-at",    keepGoing' locAtCmd),
  ("type-at",   keepGoing' typeAtCmd),
  ("uses",      keepGoing' usesCmd)
210
  ]
211
212
213
214
215
216
217
218
219
220
221
222
 where
  mkCmd (n,a,c) = Command { cmdName = n
                          , cmdAction = a
                          , cmdHidden = False
                          , cmdCompletionFunc = c
                          }

  mkCmdHidden (n,a) = Command { cmdName = n
                              , cmdAction = a
                              , cmdHidden = True
                              , cmdCompletionFunc = noCompletion
                              }
223

dterei's avatar
dterei committed
224
-- We initialize readline (in the interactiveUI function) to use
225
226
227
228
-- 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
229
--
230
231
-- NOTE: in order for us to override the default correctly, any custom entry
-- must be a SUBSET of word_break_chars.
232
word_break_chars :: String
Geraldus's avatar
Geraldus committed
233
234
235
236
237
238
word_break_chars = spaces ++ specials ++ symbols

symbols, specials, spaces :: String
symbols = "!#$%&*+/<=>?@\\^|-~"
specials = "(),;[]`{}"
spaces = " \t\n"
239

240
flagWordBreakChars :: String
241
242
243
flagWordBreakChars = " \t\n"


244
245
246
247
248
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
249

250
keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
Ian Lynagh's avatar
Ian Lynagh committed
251
252
keepGoingPaths a str
 = do case toArgs str of
Ian Lynagh's avatar
Ian Lynagh committed
253
          Left err -> liftIO $ hPutStrLn stderr err
Ian Lynagh's avatar
Ian Lynagh committed
254
255
          Right args -> a args
      return False
sof's avatar
sof committed
256

257
258
defShortHelpText :: String
defShortHelpText = "use :? for help.\n"
259

260
261
defFullHelpText :: String
defFullHelpText =
dterei's avatar
dterei committed
262
263
264
265
266
267
268
269
270
271
  " 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" ++
272
  "   :complete <dom> [<rng>] <s> list completions for partial input string\n" ++
273
  "   :ctags[!] [<file>]          create tags file <file> for Vi (default: \"tags\")\n" ++
dterei's avatar
dterei committed
274
  "                               (!: use regex instead of line number)\n" ++
275
276
  "   :def <cmd> <expr>           define command :<cmd> (later defined command has\n" ++
  "                               precedence, ::<cmd> is always a builtin command)\n" ++
dterei's avatar
dterei committed
277
278
  "   :edit <file>                edit file\n" ++
  "   :edit                       edit last module\n" ++
279
  "   :etags [<file>]             create tags file <file> for Emacs (default: \"TAGS\")\n" ++
dterei's avatar
dterei committed
280
  "   :help, :?                   display this list of commands\n" ++
281
282
  "   :info[!] [<name> ...]       display information about the given names\n" ++
  "                               (!: do not filter instances)\n" ++
dterei's avatar
dterei committed
283
  "   :issafe [<mod>]             display safe haskell information of module <mod>\n" ++
284
285
  "   :kind[!] <type>             show the kind of <type>\n" ++
  "                               (!: also print the normalised type)\n" ++
286
287
  "   :load[!] [*]<module> ...    load module(s) and their dependents\n" ++
  "                               (!: defer type errors)\n" ++
dterei's avatar
dterei committed
288
289
290
  "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
  "   :quit                       exit GHCi\n" ++
291
292
  "   :reload[!]                  reload the current module set\n" ++
  "                               (!: defer type errors)\n" ++
dterei's avatar
dterei committed
293
  "   :run function [<arguments> ...] run the function with the given arguments\n" ++
294
  "   :script <file>              run the script <file>\n" ++
dterei's avatar
dterei committed
295
296
297
298
299
300
301
  "   :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" ++
302
  "   :back [<n>]                 go back in the history N steps (after :trace)\n" ++
dterei's avatar
dterei committed
303
304
305
306
307
308
  "   :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" ++
309
  "   :forward [<n>]              go forward in the history N step s(after :back)\n" ++
dterei's avatar
dterei committed
310
311
  "   :history [<n>]              after :trace, show the execution history\n" ++
  "   :list                       show the source code around current breakpoint\n" ++
312
  "   :list <identifier>          show the source code for <identifier>\n" ++
dterei's avatar
dterei committed
313
  "   :list [<module>] <line>     show the source code around line number <line>\n" ++
Austin Seipp's avatar
Austin Seipp committed
314
315
  "   :print [<name> ...]         show a value without forcing its computation\n" ++
  "   :sprint [<name> ...]        simplified version of :print\n" ++
dterei's avatar
dterei committed
316
317
318
319
320
321
  "   :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
322

dterei's avatar
dterei committed
323
324
325
326
  "\n" ++
  " -- Commands for changing settings:\n" ++
  "\n" ++
  "   :set <option> ...           set options\n" ++
327
  "   :seti <option> ...          set options for interactive evaluation only\n" ++
dterei's avatar
dterei committed
328
329
330
  "   :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" ++
331
  "   :set prompt2 <prompt>       set the continuation prompt used in GHCi\n" ++
dterei's avatar
dterei committed
332
333
334
335
336
337
  "   :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
338
  "    +m            allow multiline commands\n" ++
dterei's avatar
dterei committed
339
340
341
  "    +r            revert top-level expressions after each evaluation\n" ++
  "    +s            print timing/memory stats after each evaluation\n" ++
  "    +t            print type after evaluation\n" ++
342
  "    +c            collect type/location info after loading modules\n" ++
dterei's avatar
dterei committed
343
  "    -<flags>      most GHC command line flags can also be set here\n" ++
344
  "                         (eg. -v2, -XFlexibleInstances, etc.)\n" ++
dterei's avatar
dterei committed
345
346
347
348
349
350
351
352
  "                    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" ++
353
  "   :show imports               show the current imports\n" ++
354
  "   :show linker                show current linker state\n" ++
dterei's avatar
dterei committed
355
356
  "   :show modules               show the currently loaded modules\n" ++
  "   :show packages              show the currently active package flags\n" ++
357
  "   :show paths                 show the currently active search paths\n" ++
358
  "   :show language              show the currently active language flags\n" ++
dterei's avatar
dterei committed
359
360
  "   :show <setting>             show value of <setting>, which is one of\n" ++
  "                                  [args, prog, prompt, editor, stop]\n" ++
361
  "   :showi language             show language flags for interactive evaluation\n" ++
dterei's avatar
dterei committed
362
  "\n"
363

Simon Marlow's avatar
Simon Marlow committed
364
findEditor :: IO String
Simon Marlow's avatar
Simon Marlow committed
365
findEditor = do
dterei's avatar
dterei committed
366
  getEnv "EDITOR"
367
    `catchIO` \_ -> do
368
#if mingw32_HOST_OS
Ian Lynagh's avatar
Ian Lynagh committed
369
370
        win <- System.Win32.getWindowsDirectory
        return (win </> "notepad.exe")
Simon Marlow's avatar
Simon Marlow committed
371
#else
Ian Lynagh's avatar
Ian Lynagh committed
372
        return ""
Simon Marlow's avatar
Simon Marlow committed
373
374
#endif

375
default_progname, default_prompt, default_prompt2, default_stop :: String
Boris Lykah's avatar
Boris Lykah committed
376
default_progname = "<interactive>"
377
378
default_prompt = "%s> "
default_prompt2 = "%s| "
Boris Lykah's avatar
Boris Lykah committed
379
380
default_stop = ""

Simon Marlow's avatar
Simon Marlow committed
381
382
383
default_args :: [String]
default_args = []

384
interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]
385
              -> Ghc ()
386
interactiveUI config srcs maybe_exprs = do
387
388
389
390
391
392
393
394
   -- 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.
395
396
397
   _ <- liftIO $ newStablePtr stdin
   _ <- liftIO $ newStablePtr stdout
   _ <- liftIO $ newStablePtr stderr
398

Ian Lynagh's avatar
Ian Lynagh committed
399
    -- Initialise buffering for the *interpreted* I/O system
400
   (nobuffering, flush) <- initInterpBuffering
401

402
   -- The initial set of DynFlags used for interactive evaluation is the same
403
404
   -- as the global DynFlags, plus -XExtendedDefaultRules and
   -- -XNoMonomorphismRestriction.
405
   dflags <- getDynFlags
406
407
   let dflags' = (`xopt_set` LangExt.ExtendedDefaultRules)
               . (`xopt_unset` LangExt.MonomorphismRestriction)
408
409
               $ dflags
   GHC.setInteractiveDynFlags dflags'
410

411
412
413
414
415
   lastErrLocationsRef <- liftIO $ newIORef []
   progDynFlags <- GHC.getProgramDynFlags
   _ <- GHC.setProgramDynFlags $
      progDynFlags { log_action = ghciLogAction lastErrLocationsRef }

416
   when (isNothing maybe_exprs) $ do
Ian Lynagh's avatar
Ian Lynagh committed
417
418
419
        -- Only for GHCi (not runghc and ghc -e):

        -- Turn buffering off for the compiled program's stdout/stderr
420
        turnOffBuffering_ nobuffering
Ian Lynagh's avatar
Ian Lynagh committed
421
        -- Turn buffering off for GHCi's stdout
422
423
        liftIO $ hFlush stdout
        liftIO $ hSetBuffering stdout NoBuffering
Ian Lynagh's avatar
Ian Lynagh committed
424
425
        -- We don't want the cmd line to buffer any input that might be
        -- intended for the program, so unbuffer stdin.
426
427
        liftIO $ hSetBuffering stdin NoBuffering
        liftIO $ hSetBuffering stderr NoBuffering
428
#if defined(mingw32_HOST_OS)
429
430
431
        -- 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.
432
        liftIO $ hSetEncoding stdin utf8
433
#endif
Ian Lynagh's avatar
Ian Lynagh committed
434

435
   default_editor <- liftIO $ findEditor
436
   eval_wrapper <- mkEvalWrapper default_progname default_args
Ian Lynagh's avatar
Ian Lynagh committed
437
   startGHCi (runGHCi srcs maybe_exprs)
438
        GHCiState{ progname           = default_progname,
439
                   args               = default_args,
440
                   evalWrapper        = eval_wrapper,
441
442
                   prompt             = defPrompt config,
                   prompt2            = defPrompt2 config,
443
444
445
                   stop               = default_stop,
                   editor             = default_editor,
                   options            = [],
446
447
448
449
                   -- We initialize line number as 0, not 1, because we use
                   -- current line number while reporting errors which is
                   -- incremented after reading a line.
                   line_number        = 0,
450
451
452
453
                   break_ctr          = 0,
                   breaks             = [],
                   tickarrays         = emptyModuleEnv,
                   ghci_commands      = availableCommands config,
Ben Gamari's avatar
Ben Gamari committed
454
                   ghci_macros        = [],
455
456
457
458
459
460
461
                   last_command       = Nothing,
                   cmdqueue           = [],
                   remembered_ctx     = [],
                   transient_ctx      = [],
                   ghc_e              = isJust maybe_exprs,
                   short_help         = shortHelpText config,
                   long_help          = fullHelpText config,
462
                   lastErrorLocations = lastErrLocationsRef,
463
                   mod_infos          = M.empty,
464
465
                   flushStdHandles    = flush,
                   noBuffering        = nobuffering
mnislaih's avatar
mnislaih committed
466
                 }
467

468
469
   return ()

470
471
472
473
474
475
resetLastErrorLocations :: GHCi ()
resetLastErrorLocations = do
    st <- getGHCiState
    liftIO $ writeIORef (lastErrorLocations st) []

ghciLogAction :: IORef [(FastString, Int)] ->  LogAction
476
477
ghciLogAction lastErrLocations dflags flag severity srcSpan style msg = do
    defaultLogAction dflags flag severity srcSpan style msg
478
479
480
481
482
483
484
    case severity of
        SevError -> case srcSpan of
            RealSrcSpan rsp -> modifyIORef lastErrLocations
                (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])
            _ -> return ()
        _ -> return ()

485
486
withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
withGhcAppData right left = do
487
    either_dir <- tryIO (getAppUserDataDirectory "ghc")
488
489
490
491
492
    case either_dir of
        Right dir ->
            do createDirectoryIfMissing False dir `catchIO` \_ -> return ()
               right dir
        _ -> left
493

Ian Lynagh's avatar
Ian Lynagh committed
494
495
runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
runGHCi paths maybe_exprs = do
496
  dflags <- getDynFlags
497
  let
498
   ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags
499

500
501
   current_dir = return (Just ".ghci")

Ian Lynagh's avatar
Ian Lynagh committed
502
   app_user_dir = liftIO $ withGhcAppData
503
504
                    (\dir -> return (Just (dir </> "ghci.conf")))
                    (return Nothing)
505
506

   home_dir = do
507
    either_dir <- liftIO $ tryIO (getEnv "HOME")
508
509
510
511
    case either_dir of
      Right home -> return (Just (home </> ".ghci"))
      _ -> return Nothing

512
513
514
515
   canonicalizePath' :: FilePath -> IO (Maybe FilePath)
   canonicalizePath' fp = liftM Just (canonicalizePath fp)
                `catchIO` \_ -> return Nothing

516
517
   sourceConfigFile :: FilePath -> GHCi ()
   sourceConfigFile file = do
Ian Lynagh's avatar
Ian Lynagh committed
518
     exists <- liftIO $ doesFileExist file
519
     when exists $ do
520
521
522
523
524
525
526
527
528
529
       either_hdl <- liftIO $ tryIO (openFile file ReadMode)
       case either_hdl of
         Left _e   -> return ()
         -- 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 ->
             do runInputTWithPrefs defaultPrefs defaultSettings $
                          runCommands $ fileLoop hdl
                liftIO (hClose hdl `catchIO` \_ -> return ())
530
531
532
533
534
                -- Don't print a message if this is really ghc -e (#11478).
                -- Also, let the user silence the message with -v0
                -- (the default verbosity in GHCi is 1).
                when (isNothing maybe_exprs && verbosity dflags > 0) $
                  liftIO $ putStrLn ("Loaded GHCi configuration from " ++ file)
535

536
537
  --

538
  setGHCContextFromGHCiState
Ian Lynagh's avatar
Ian Lynagh committed
539

540
541
  dot_cfgs <- if ignore_dot_ghci then return [] else do
    dot_files <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]
542
    liftIO $ filterM checkFileAndDirPerms dot_files
543
544
  mdot_cfgs <- liftIO $ mapM canonicalizePath' dot_cfgs

545
546
547
548
  let arg_cfgs = reverse $ ghciScripts dflags
    -- -ghci-script are collected in reverse order
    -- We don't require that a script explicitly added by -ghci-script
    -- is owned by the current user. (#6017)
549
  mapM_ sourceConfigFile $ nub $ (catMaybes mdot_cfgs) ++ arg_cfgs
550
    -- nub, because we don't want to read .ghci twice if the CWD is $HOME.
551

552
  -- Perform a :load for files given on the GHCi command line
553
554
555
  -- 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
556
     ok <- ghciHandle (\e -> do showException e; return Failed) $
557
                -- TODO: this is a hack.
558
559
                runInputTWithPrefs defaultPrefs defaultSettings $
                    loadModule paths
Ian Lynagh's avatar
Ian Lynagh committed
560
     when (isJust maybe_exprs && failed ok) $
Ian Lynagh's avatar
Ian Lynagh committed
561
        liftIO (exitWith (ExitFailure 1))
562

563
564
  installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)

565
566
  -- 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
567
  is_tty <- liftIO (hIsTerminalDevice stdin)
568
569
  let show_prompt = verbosity dflags > 0 || is_tty

570
  -- reset line number
571
  modifyGHCiState $ \st -> st{line_number=0}
572

Ian Lynagh's avatar
Ian Lynagh committed
573
  case maybe_exprs of
Ian Lynagh's avatar
Ian Lynagh committed
574
        Nothing ->
sof's avatar
sof committed
575
          do
Ian Lynagh's avatar
Ian Lynagh committed
576
            -- enter the interactive loop
577
            runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
Ian Lynagh's avatar
Ian Lynagh committed
578
        Just exprs -> do
Ian Lynagh's avatar
Ian Lynagh committed
579
            -- just evaluate the expression we were given
Ian Lynagh's avatar
Ian Lynagh committed
580
            enqueueCommands exprs
dterei's avatar
dterei committed
581
582
583
584
585
586
587
588
            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
589
                                   -- this used to be topHandlerFastExit, see #2228
590
            runInputTWithPrefs defaultPrefs defaultSettings $ do
591
                -- make `ghc -e` exit nonzero on invalid input, see Trac #7962
592
593
594
595
                _ <- runCommands' hdle
                     (Just $ hdle (toException $ ExitFailure 1) >> return ())
                     (return Nothing)
                return ()
596
597

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

600
601
runGHCiInput :: InputT GHCi a -> GHCi a
runGHCiInput f = do
Ian Lynagh's avatar
Ian Lynagh committed
602
    dflags <- getDynFlags
ian@well-typed.com's avatar
ian@well-typed.com committed
603
    histFile <- if gopt Opt_GhciHistory dflags
Ian Lynagh's avatar
Ian Lynagh committed
604
605
606
                then liftIO $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
                                             (return Nothing)
                else return Nothing
dterei's avatar
dterei committed
607
608
609
    runInputT
        (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})
        f
610

611
-- | How to get the next input line from the user
612
613
614
nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
nextInputLine show_prompt is_tty
  | is_tty = do
dterei's avatar
dterei committed
615
616
    prmpt <- if show_prompt then lift mkPrompt else return ""
    r <- getInputLine prmpt
617
618
    incrementLineNo
    return r
619
620
621
  | otherwise = do
    when show_prompt $ lift mkPrompt >>= liftIO . putStr
    fileLoop stdin
622

623
-- NOTE: We only read .ghci files if they are owned by the current user,
624
625
626
-- and aren't world writable (files owned by root are ok, see #9324).
-- Otherwise, we could be accidentally running code planted by
-- a malicious third party.
627

rrt's avatar
rrt committed
628
629
630
631
-- 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.
632

633
634
checkFileAndDirPerms :: FilePath -> IO Bool
checkFileAndDirPerms file = do
635
  file_ok <- checkPerms file
thomie's avatar
thomie committed
636
637
638
639
  -- Do not check dir perms when .ghci doesn't exist, otherwise GHCi will
  -- print some confusing and useless warnings in some cases (e.g. in
  -- travis). Note that we can't add a test for this, as all ghci tests should
  -- run with -ignore-dot-ghci, which means we never get here.
640
  if file_ok then checkPerms (getDirectory file) else return False
641
642
643
644
645
646
  where
  getDirectory f = case takeDirectory f of
    "" -> "."
    d -> d

checkPerms :: FilePath -> IO Bool
647
#ifdef mingw32_HOST_OS
dterei's avatar
dterei committed
648
checkPerms _ = return True
sof's avatar
sof committed
649
#else
650
checkPerms file =
651
  handleIO (\_ -> return False) $ do
652
    st <- getFileStatus file
dterei's avatar
dterei committed
653
    me <- getRealUserID
654
655
656
657
658
    let mode = System.Posix.fileMode st
        ok = (fileOwner st == me || fileOwner st == 0) &&
             groupWriteMode /= mode `intersectFileModes` groupWriteMode &&
             otherWriteMode /= mode `intersectFileModes` otherWriteMode
    unless ok $
659
      -- #8248: Improving warning to include a possible fix.
660
      putStrLn $ "*** WARNING: " ++ file ++
661
                 " is writable by someone else, IGNORING!" ++
Ben Gamari's avatar
Ben Gamari committed
662
                 "\nSuggested fix: execute 'chmod go-w " ++ file ++ "'"
663
    return ok
sof's avatar
sof committed
664
#endif
665

666
incrementLineNo :: InputT GHCi ()
667
668
669
incrementLineNo = modifyGHCiState incLineNo
  where
    incLineNo st = st { line_number = line_number st + 1 }
vivian's avatar
vivian committed
670
671

fileLoop :: Handle -> InputT GHCi (Maybe String)
672
fileLoop hdl = do
673
   l <- liftIO $ tryIO $ hGetLine hdl
674
   case l of
675
        Left e | isEOFError e              -> return Nothing
676
677
678
679
680
               | -- as we share stdin with the program, the program
                 -- might have already closed it, so we might get a
                 -- handle-closed exception. We therefore catch that
                 -- too.
                 isIllegalOperation e      -> return Nothing
681
               | InvalidArgument <- etype  -> return Nothing
682
               | otherwise                 -> liftIO $ ioError e
683
684
685
686
687
                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
688
        Right l' -> do
689
           incrementLineNo
dterei's avatar
dterei committed
690
           return (Just l')
691

Simon Marlow's avatar
Simon Marlow committed
692
mkPrompt :: GHCi String
693
mkPrompt = do
694
  st <- getGHCiState
695
  imports <- GHC.getContext
696
  resumes <- GHC.getResumeContext
697
698
699
700

  context_bit <-
        case resumes of
            [] -> return empty
Simon Marlow's avatar
Simon Marlow committed
701
            r:_ -> do
702
703
704
705
706
                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
707
708
709
                        pan <- GHC.getHistorySpan hist
                        return (brackets (ppr (negate ix) <> char ':'
                                          <+> ppr pan) <> space)
710
  let
Simon Marlow's avatar
Simon Marlow committed
711
        dots | _:rs <- resumes, not (null rs) = text "... "
712
713
             | otherwise = empty

714
        rev_imports = reverse imports -- rightmost are the most recent
715
716
717
        modules_bit =
             hsep [ char '*' <> ppr m | IIModule m <- rev_imports ] <+>
             hsep (map ppr [ myIdeclName d | IIDecl d <- rev_imports ])
718
719
720
721

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

723
        deflt_prompt = dots <> context_bit <> modules_bit
724

725
        f ('%':'l':xs) = ppr (1 + line_number st) <> f xs
726
727
728
729
        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
730

731
732
  dflags <- getDynFlags
  return (showSDoc dflags (f (prompt st)))
733

734

735
736
737
738
739
740
741
742
queryQueue :: GHCi (Maybe String)
queryQueue = do
  st <- getGHCiState
  case cmdqueue st of
    []   -> return Nothing
    c:cs -> do setGHCiState st{ cmdqueue = cs }
               return (Just c)

743
744
745
746
747
748
-- Reconfigurable pretty-printing Ticket #5461
installInteractivePrint :: Maybe String -> Bool -> GHCi ()
installInteractivePrint Nothing _  = return ()
installInteractivePrint (Just ipFun) exprmode = do
  ok <- trySuccess $ do
                (name:_) <- GHC.parseName ipFun
749
                modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name
750
                                      in he{hsc_IC = new_ic})
751
752
753
754
                return Succeeded

  when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1))

755
-- | The main read-eval-print loop
756
runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
757
runCommands gCmd = runCommands' handler Nothing gCmd >> return ()
758

dterei's avatar
dterei committed
759
runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler
760
             -> Maybe (GHCi ()) -- ^ Source error handler
761
762
763
764
765
766
             -> InputT GHCi (Maybe String)
             -> InputT GHCi (Maybe Bool)
         -- We want to return () here, but have to return (Maybe Bool)
         -- because gmask is not polymorphic enough: we want to use
         -- unmask at two different types.
runCommands' eh sourceErrorHandler gCmd = gmask $ \unmask -> do
767
    b <- ghandle (\e -> case fromException e of
vivian's avatar
vivian committed
768
                          Just UserInterrupt -> return $ Just False
769
                          _ -> case fromException e of
dterei's avatar
dterei committed
770
771
                                 Just ghce ->
                                   do liftIO (print (ghce :: GhcException))
vivian's avatar
vivian committed
772
                                      return Nothing
773
774
                                 _other ->
                                   liftIO (Exception.throwIO e))
775
            (unmask $ runOneCommand eh gCmd)
vivian's avatar
vivian committed
776
    case b of
777
      Nothing -> return Nothing
778
      Just success -> do
779
        unless success $ maybe (return ()) lift sourceErrorHandler
780
        unmask $ runCommands' eh sourceErrorHandler gCmd
781

782
783
784
785
786
-- | Evaluate a single line of user input (either :<command> or Haskell code).
-- A result of Nothing means there was no more input to process.
-- Otherwise the result is Just b where b is True if the command succeeded;
-- this is relevant only to ghc -e, which will exit with status 1
-- if the commmand was unsuccessful. GHCi will continue in either case.
787
runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
vivian's avatar
vivian committed
788
            -> InputT GHCi (Maybe Bool)
dterei's avatar
dterei committed
789
runOneCommand eh gCmd = do
790
791
  -- run a previously queued command if there is one, otherwise get new
  -- input from user
dterei's avatar
dterei committed
792
793
794
  mb_cmd0 <- noSpace (lift queryQueue)
  mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0
  case mb_cmd1 of
vivian's avatar
vivian committed
795
796
    Nothing -> return Nothing
    Just c  -> ghciHandle (\e -> lift $ eh e >>= return . Just) $
797
             handleSourceError printErrorAndFail
798
               (doCommand c)
vivian's avatar
vivian committed
799
800
               -- source error's are handled by runStmt
               -- is the handler necessary here?
801
  where
802
    printErrorAndFail err = do
803
        GHC.printException err
804
        return $ Just False     -- Exit ghc -e, but not GHCi
805

806
    noSpace q = q >>= maybe (return Nothing)
dterei's avatar
dterei committed
807
808
809
                            (\c -> case removeSpaces c of
                                     ""   -> noSpace q
                                     ":{" -> multiLineCmd q
810
                                     _    -> return (Just c) )
811
    multiLineCmd q = do
812
      st <- getGHCiState
813
      let p = prompt st
814
815
816
      setGHCiState st{ prompt = prompt2 st }
      mb_cmd <- collectCommand q "" `GHC.gfinally`
                modifyGHCiState (\st' -> st' { prompt = p })
817
      return mb_cmd
dterei's avatar
dterei committed
818
    -- we can't use removeSpaces for the sublines here, so
819
    -- multiline commands are somewhat more brittle against
dterei's avatar
dterei committed
820
821
    -- fileformat errors (such as \r in dos input on unix),
    -- we get rid of any extra spaces for the ":}" test;
822
    -- we also avoid silent failure if ":}" is not found;
dterei's avatar
dterei committed
823
    -- and since there is no (?) valid occurrence of \r (as
824
825
    -- opposed to its String representation, "\r") inside a
    -- ghci command, we replace any such with ' ' (argh:-(
dterei's avatar
dterei committed
826
    collectCommand q c = q >>=
827
      maybe (liftIO (ioError collectError))
dterei's avatar
dterei committed
828
            (\l->if removeSpaces l == ":}"
829
                 then return (Just c)
830
                 else collectCommand q (c ++ "\n" ++ map normSpace l))
831
      where normSpace '\r' = ' '
dterei's avatar
dterei committed
832
            normSpace   x  = x
dterei's avatar
dterei committed
833
    -- SDM (2007-11-07): is userError the one to use here?
834
    collectError = userError "unterminated multiline command :{ .. :}"
835
836
837
838
839

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

    -- command
840
    doCommand stmt | (':' : cmd) <- removeSpaces stmt = do
vivian's avatar
vivian committed
841
842
843
844
      result <- specialCommand cmd
      case result of
        True -> return Nothing
        _    -> return $ Just True
845
846
847

    -- haskell
    doCommand stmt = do
848
849
      -- if 'stmt' was entered via ':{' it will contain '\n's
      let stmt_nl_cnt = length [ () | '\n' <- stmt ]
vivian's avatar
vivian committed
850
      ml <- lift $ isOptionSet Multiline
851
      if ml && stmt_nl_cnt == 0 -- don't trigger automatic multi-line mode for ':{'-multiline input
dterei's avatar
dterei committed
852
        then do
853
          fst_line_num <- line_number <$> getGHCiState
dterei's avatar
dterei committed
854
          mb_stmt <- checkInputForLayout stmt gCmd
vivian's avatar
vivian committed
855
856
857
          case mb_stmt of
            Nothing      -> return $ Just True
            Just ml_stmt -> do
858
              -- temporarily compensate line-number for multi-line input
859
860
861
862
              result <- timeIt runAllocs $ lift $
                runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion
              return $ Just (runSuccess result)
        else do -- single line input and :{ - multiline input
863
          last_line_num <- line_number <$> getGHCiState
864
865
866
867
868
869
          -- reconstruct first line num from last line num and stmt
          let fst_line_num | stmt_nl_cnt > 0 = last_line_num - (stmt_nl_cnt2 + 1)
                           | otherwise = last_line_num -- single line input
              stmt_nl_cnt2 = length [ () | '\n' <- stmt' ]
              stmt' = dropLeadingWhiteLines stmt -- runStmt doesn't like leading empty lines
          -- temporarily compensate line-number for multi-line input
870
871
872
          result <- timeIt runAllocs $ lift $
            runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion
          return $ Just (runSuccess result)
vivian's avatar
vivian committed
873

874
    -- runStmt wrapper for temporarily overridden line-number
875
876
    runStmtWithLineNum :: Int -> String -> SingleStep
                       -> GHCi (Maybe GHC.ExecResult)
877
878
879
880
881
882
883
884
885
886
887
888