UI.hs 137 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
dterei's avatar
dterei committed
42
import DynFlags
43
import ErrUtils
44
import GhcMonad ( modifySession )
dterei's avatar
dterei committed
45
46
47
import qualified GHC
import GHC ( LoadHowMuch(..), Target(..),  TargetId(..), InteractiveImport(..),
             TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,
48
             getModuleGraph, handleSourceError )
49
import HsImpExp
50
import HsSyn
51
import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,
52
                  setInteractivePrintName, hsc_dflags )
dterei's avatar
dterei committed
53
import Module
54
import Name
55
import Packages ( trusted, getPackageDetails, listVisibleModuleNames, pprFlag )
dterei's avatar
dterei committed
56
import PprTyThing
57
58
import PrelNames
import RdrName ( RdrName, getGRE_NameQualifier_maybes, getRdrName )
59
import SrcLoc
dterei's avatar
dterei committed
60
import qualified Lexer
61
import ByteCodeTypes (BreakInfo(..))
dterei's avatar
dterei committed
62
63
64

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

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

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

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

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

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

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

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

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

124
125
-----------------------------------------------------------------------------

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

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

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

Simon Marlow's avatar
Simon Marlow committed
148
GLOBAL_VAR(macros_ref, [], [Command])
Simon Marlow's avatar
Simon Marlow committed
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
233
234
235
236
word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
                       specials = "(),;[]`{}"
                       spaces = " \t\n"
                   in spaces ++ specials ++ symbols
237

238
flagWordBreakChars :: String
239
240
241
flagWordBreakChars = " \t\n"


242
243
244
245
246
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
247

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

255
256
defShortHelpText :: String
defShortHelpText = "use :? for help.\n"
257

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

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

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

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

Simon Marlow's avatar
Simon Marlow committed
379
380
381
default_args :: [String]
default_args = []

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

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

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

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

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

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

433
   default_editor <- liftIO $ findEditor
434
   eval_wrapper <- mkEvalWrapper default_progname default_args
Ian Lynagh's avatar
Ian Lynagh committed
435
   startGHCi (runGHCi srcs maybe_exprs)
436
        GHCiState{ progname           = default_progname,
437
                   args               = default_args,
438
                   evalWrapper        = eval_wrapper,
439
440
                   prompt             = defPrompt config,
                   prompt2            = defPrompt2 config,
441
442
443
                   stop               = default_stop,
                   editor             = default_editor,
                   options            = [],
444
445
446
447
                   -- 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,
448
449
450
451
452
453
454
455
456
457
458
                   break_ctr          = 0,
                   breaks             = [],
                   tickarrays         = emptyModuleEnv,
                   ghci_commands      = availableCommands config,
                   last_command       = Nothing,
                   cmdqueue           = [],
                   remembered_ctx     = [],
                   transient_ctx      = [],
                   ghc_e              = isJust maybe_exprs,
                   short_help         = shortHelpText config,
                   long_help          = fullHelpText config,
459
                   lastErrorLocations = lastErrLocationsRef,
460
                   mod_infos          = M.empty,
461
462
                   flushStdHandles    = flush,
                   noBuffering        = nobuffering
mnislaih's avatar
mnislaih committed
463
                 }
464

465
466
   return ()

467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
resetLastErrorLocations :: GHCi ()
resetLastErrorLocations = do
    st <- getGHCiState
    liftIO $ writeIORef (lastErrorLocations st) []

ghciLogAction :: IORef [(FastString, Int)] ->  LogAction
ghciLogAction lastErrLocations dflags severity srcSpan style msg = do
    defaultLogAction dflags severity srcSpan style msg
    case severity of
        SevError -> case srcSpan of
            RealSrcSpan rsp -> modifyIORef lastErrLocations
                (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])
            _ -> return ()
        _ -> return ()

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

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

497
498
   current_dir = return (Just ".ghci")

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

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

509
510
511
512
   canonicalizePath' :: FilePath -> IO (Maybe FilePath)
   canonicalizePath' fp = liftM Just (canonicalizePath fp)
                `catchIO` \_ -> return Nothing

513
514
   sourceConfigFile :: FilePath -> GHCi ()
   sourceConfigFile file = do
Ian Lynagh's avatar
Ian Lynagh committed
515
     exists <- liftIO $ doesFileExist file
516
     when exists $ do
517
518
519
520
521
522
523
524
525
526
527
       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 ())

528
529
  --

530
  setGHCContextFromGHCiState
Ian Lynagh's avatar
Ian Lynagh committed
531

532
533
  dot_cfgs <- if ignore_dot_ghci then return [] else do
    dot_files <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]
534
    liftIO $ filterM checkFileAndDirPerms dot_files
535
536
537
538
539
540
541
  let arg_cfgs = reverse $ ghciScripts dflags
    -- -ghci-script are collected in reverse order
  mcfgs <- liftIO $ mapM canonicalizePath' $ dot_cfgs ++ arg_cfgs
    -- We don't require that a script explicitly added by -ghci-script
    -- is owned by the current user. (#6017)
  mapM_ sourceConfigFile $ nub $ catMaybes mcfgs
    -- nub, because we don't want to read .ghci twice if the CWD is $HOME.
542

543
  -- Perform a :load for files given on the GHCi command line
544
545
546
  -- 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
547
     ok <- ghciHandle (\e -> do showException e; return Failed) $
548
                -- TODO: this is a hack.
549
550
                runInputTWithPrefs defaultPrefs defaultSettings $
                    loadModule paths
Ian Lynagh's avatar
Ian Lynagh committed
551
     when (isJust maybe_exprs && failed ok) $
Ian Lynagh's avatar
Ian Lynagh committed
552
        liftIO (exitWith (ExitFailure 1))
553

554
555
  installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)

556
557
  -- 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
558
  is_tty <- liftIO (hIsTerminalDevice stdin)
559
560
  let show_prompt = verbosity dflags > 0 || is_tty

561
  -- reset line number
562
  modifyGHCiState $ \st -> st{line_number=0}
563

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

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

591
592
runGHCiInput :: InputT GHCi a -> GHCi a
runGHCiInput f = do
Ian Lynagh's avatar
Ian Lynagh committed
593
    dflags <- getDynFlags
ian@well-typed.com's avatar
ian@well-typed.com committed
594
    histFile <- if gopt Opt_GhciHistory dflags
Ian Lynagh's avatar
Ian Lynagh committed
595
596
597
                then liftIO $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
                                             (return Nothing)
                else return Nothing
dterei's avatar
dterei committed
598
599
600
    runInputT
        (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})
        f
601

602
-- | How to get the next input line from the user
603
604
605
nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
nextInputLine show_prompt is_tty
  | is_tty = do
dterei's avatar
dterei committed
606
607
    prmpt <- if show_prompt then lift mkPrompt else return ""
    r <- getInputLine prmpt
608
609
    incrementLineNo
    return r
610
611
612
  | otherwise = do
    when show_prompt $ lift mkPrompt >>= liftIO . putStr
    fileLoop stdin
613

614
-- NOTE: We only read .ghci files if they are owned by the current user,
615
616
617
-- 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.
618

rrt's avatar
rrt committed
619
620
621
622
-- 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.
623

624
625
checkFileAndDirPerms :: FilePath -> IO Bool
checkFileAndDirPerms file = do
626
  file_ok <- checkPerms file
thomie's avatar
thomie committed
627
628
629
630
  -- 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.
631
  if file_ok then checkPerms (getDirectory file) else return False
632
633
634
635
636
637
  where
  getDirectory f = case takeDirectory f of
    "" -> "."
    d -> d

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

657
incrementLineNo :: InputT GHCi ()
658
659
660
incrementLineNo = modifyGHCiState incLineNo
  where
    incLineNo st = st { line_number = line_number st + 1 }
vivian's avatar
vivian committed
661
662

fileLoop :: Handle -> InputT GHCi (Maybe String)
663
fileLoop hdl = do
664
   l <- liftIO $ tryIO $ hGetLine hdl
665
   case l of
666
        Left e | isEOFError e              -> return Nothing
667
668
669
670
671
               | -- 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
672
               | InvalidArgument <- etype  -> return Nothing
673
               | otherwise                 -> liftIO $ ioError e
674
675
676
677
678
                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
679
        Right l' -> do
680
           incrementLineNo
dterei's avatar
dterei committed
681
           return (Just l')
682

Simon Marlow's avatar
Simon Marlow committed
683
mkPrompt :: GHCi String
684
mkPrompt = do
685
  st <- getGHCiState
686
  imports <- GHC.getContext
687
  resumes <- GHC.getResumeContext
688
689
690
691

  context_bit <-
        case resumes of
            [] -> return empty
Simon Marlow's avatar
Simon Marlow committed
692
            r:_ -> do
693
694
695
696
697
                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
698
699
700
                        pan <- GHC.getHistorySpan hist
                        return (brackets (ppr (negate ix) <> char ':'
                                          <+> ppr pan) <> space)
701
  let
Simon Marlow's avatar
Simon Marlow committed
702
        dots | _:rs <- resumes, not (null rs) = text "... "
703
704
             | otherwise = empty

705
        rev_imports = reverse imports -- rightmost are the most recent
706
707
708
        modules_bit =
             hsep [ char '*' <> ppr m | IIModule m <- rev_imports ] <+>
             hsep (map ppr [ myIdeclName d | IIDecl d <- rev_imports ])
709
710
711
712

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

714
        deflt_prompt = dots <> context_bit <> modules_bit
715

716
        f ('%':'l':xs) = ppr (1 + line_number st) <> f xs
717
718
719
720
        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
721

722
723
  dflags <- getDynFlags
  return (showSDoc dflags (f (prompt st)))
724

725

726
727
728
729
730
731
732
733
queryQueue :: GHCi (Maybe String)
queryQueue = do
  st <- getGHCiState
  case cmdqueue st of
    []   -> return Nothing
    c:cs -> do setGHCiState st{ cmdqueue = cs }
               return (Just c)

734
735
736
737
738
739
-- 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
740
                modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name
741
                                      in he{hsc_IC = new_ic})
742
743
744
745
                return Succeeded

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

746
-- | The main read-eval-print loop
747
runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
748
runCommands gCmd = runCommands' handler Nothing gCmd >> return ()
749

dterei's avatar
dterei committed
750
runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler
751
             -> Maybe (GHCi ()) -- ^ Source error handler
752
753
754
755
756
757
             -> 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
758
    b <- ghandle (\e -> case fromException e of
vivian's avatar
vivian committed
759
                          Just UserInterrupt -> return $ Just False
760
                          _ -> case fromException e of
dterei's avatar
dterei committed
761
762
                                 Just ghce ->
                                   do liftIO (print (ghce :: GhcException))
vivian's avatar
vivian committed
763
                                      return Nothing
764
765
                                 _other ->
                                   liftIO (Exception.throwIO e))
766
            (unmask $ runOneCommand eh gCmd)
vivian's avatar
vivian committed
767
    case b of
768
      Nothing -> return Nothing
769
      Just success -> do
770
        unless success $ maybe (return ()) lift sourceErrorHandler
771
        unmask $ runCommands' eh sourceErrorHandler gCmd
772

773
774
775
776
777
-- | 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.
778
runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
vivian's avatar
vivian committed
779
            -> InputT GHCi (Maybe Bool)
dterei's avatar
dterei committed
780
runOneCommand eh gCmd = do
781
782
  -- run a previously queued command if there is one, otherwise get new
  -- input from user
dterei's avatar
dterei committed
783
784
785
  mb_cmd0 <- noSpace (lift queryQueue)
  mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0
  case mb_cmd1 of
vivian's avatar
vivian committed
786
787
    Nothing -> return Nothing
    Just c  -> ghciHandle (\e -> lift $ eh e >>= return . Just) $
788
             handleSourceError printErrorAndFail
789
               (doCommand c)
vivian's avatar
vivian committed
790
791
               -- source error's are handled by runStmt
               -- is the handler necessary here?
792
  where
793
    printErrorAndFail err = do
794
        GHC.printException err
795
        return $ Just False     -- Exit ghc -e, but not GHCi
796

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

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

    -- command
831
    doCommand stmt | (':' : cmd) <- removeSpaces stmt = do
vivian's avatar
vivian committed
832
833
834
835
      result <- specialCommand cmd
      case result of
        True -> return Nothing
        _    -> return $ Just True
836
837
838

    -- haskell
    doCommand stmt = do
839
840
      -- if 'stmt' was entered via ':{' it will contain '\n's
      let stmt_nl_cnt = length [ () | '\n' <- stmt ]
vivian's avatar
vivian committed
841
      ml <- lift $ isOptionSet Multiline
842
      if ml && stmt_nl_cnt == 0 -- don't trigger automatic multi-line mode for ':{'-multiline input
dterei's avatar
dterei committed
843
        then do
844
          fst_line_num <- line_number <$> getGHCiState
dterei's avatar
dterei committed
845
          mb_stmt <- checkInputForLayout stmt gCmd
vivian's avatar
vivian committed
846
847
848
          case mb_stmt of
            Nothing      -> return $ Just True
            Just ml_stmt -> do
849
              -- temporarily compensate line-number for multi-line input
850
851
852
853
              result <- timeIt runAllocs $ lift $
                runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion
              return $ Just (runSuccess result)
        else do -- single line input and :{ - multiline input
854
          last_line_num <- line_number <$> getGHCiState
855
856
857
858
859
860
          -- 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
861
862
863
          result <- timeIt runAllocs $ lift $
            runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion
          return $ Just (runSuccess result)
vivian's avatar
vivian committed
864

865
    -- runStmt wrapper for temporarily overridden line-number
866
867
    runStmtWithLineNum :: Int -> String -> SingleStep
                       -> GHCi (Maybe GHC.ExecResult)
868
869
870
871
872
873
874
875
876
877
878
879
880
881
    runStmtWithLineNum lnum stmt step = do
        st0 <- getGHCiState
        setGHCiState st0 { line_number = lnum }
        result <- runStmt stmt step
        -- restore original line_number
        getGHCiState >>= \st -> setGHCiState st { line_number = line_number st0 }
        return result

    -- note: this is subtly different from 'unlines . dropWhile (all isSpace) . lines'
    dropLeadingWhiteLines s | (l0,'\n':r) <- break (=='\n') s
                            , all isSpace l0 = dropLeadingWhiteLines r
                            | otherwise = s


vivian's avatar
vivian committed
882
883
-- #4316
-- lex the input.  If there is an unclosed layout context, request input
vivian's avatar
vivian committed
884
checkInputForLayout :: String -> InputT GHCi (Maybe String)
vivian's avatar
vivian committed
885
                    -> InputT GHCi (Maybe String)
vivian's avatar
vivian committed
886
checkInputForLayout stmt getStmt = do
887
   dflags' <- getDynFlags
Ben Gamari's avatar