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

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

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

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

32 33
#include "HsVersions.h"

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

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

import StringBuffer
Rufflewind's avatar
Rufflewind committed
71
import Outputable hiding ( printForUser, printForUserPartWay )
72

73 74
import DynamicLoading ( initializePlugins )

75
-- Other random utilities
dterei's avatar
dterei committed
76
import BasicTypes hiding ( isTopLevel )
77
import Config
dterei's avatar
dterei committed
78 79 80
import Digraph
import Encoding
import FastString
81
import Linker
dterei's avatar
dterei committed
82
import Maybes ( orElse, expectJust )
dterei's avatar
dterei committed
83 84
import NameSet
import Panic hiding ( showException )
85
import Util
86
import qualified GHC.LanguageExtensions as LangExt
87
import Bag (unitBag)
sof's avatar
sof committed
88

dterei's avatar
dterei committed
89
-- Haskell Libraries
90
import System.Console.Haskeline as Haskeline
91

dterei's avatar
dterei committed
92
import Control.Applicative hiding (empty)
93 94
import Control.DeepSeq (deepseq)
import Control.Monad as Monad
95
import Control.Monad.IO.Class
96
import Control.Monad.Trans.Class
97
import Control.Monad.Trans.Except
98

dterei's avatar
dterei committed
99
import Data.Array
Simon Marlow's avatar
Simon Marlow committed
100
import qualified Data.ByteString.Char8 as BS
dterei's avatar
dterei committed
101
import Data.Char
Ian Lynagh's avatar
Ian Lynagh committed
102
import Data.Function
103
import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )
dterei's avatar
dterei committed
104
import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,
105
                   partition, sort, sortBy, (\\) )
106
import qualified Data.Set as S
107
import Data.Maybe
108
import Data.Map (Map)
109
import qualified Data.Map as M
niksaz's avatar
niksaz committed
110 111 112
import Data.Time.LocalTime ( getZonedTime )
import Data.Time.Format ( formatTime, defaultTimeLocale )
import Data.Version ( showVersion )
113
import Prelude hiding ((<>))
dterei's avatar
dterei committed
114

115
import Exception hiding (catch)
116
import Foreign hiding (void)
117
import GHC.Stack hiding (SrcLoc(..))
dterei's avatar
dterei committed
118 119

import System.Directory
120
import System.Environment
dterei's avatar
dterei committed
121
import System.Exit ( exitWith, ExitCode(..) )
dterei's avatar
dterei committed
122
import System.FilePath
niksaz's avatar
niksaz committed
123
import System.Info
ross's avatar
ross committed
124
import System.IO
125
import System.IO.Error
dterei's avatar
dterei committed
126
import System.IO.Unsafe ( unsafePerformIO )
127
import System.Process
Simon Marlow's avatar
Simon Marlow committed
128
import Text.Printf
129
import Text.Read ( readMaybe )
Geraldus's avatar
Geraldus committed
130
import Text.Read.Lex (isSymbolChar)
131

niksaz's avatar
niksaz committed
132 133
import Unsafe.Coerce

Ben Gamari's avatar
Ben Gamari committed
134
#if !defined(mingw32_HOST_OS)
dterei's avatar
dterei committed
135 136 137 138 139
import System.Posix hiding ( getEnv )
#else
import qualified System.Win32
#endif

dterei's avatar
dterei committed
140 141
import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
import GHC.IO.Handle ( hFlushAll )
dterei's avatar
dterei committed
142
import GHC.TopHandler ( topHandler )
143

144 145
import GHCi.Leak

146 147
-----------------------------------------------------------------------------

148 149 150
data GhciSettings = GhciSettings {
        availableCommands :: [Command],
        shortHelpText     :: String,
151
        fullHelpText      :: String,
niksaz's avatar
niksaz committed
152 153
        defPrompt         :: PromptFunction,
        defPromptCont     :: PromptFunction
154 155 156 157 158 159 160
    }

defaultGhciSettings :: GhciSettings
defaultGhciSettings =
    GhciSettings {
        availableCommands = ghciCommands,
        shortHelpText     = defShortHelpText,
161
        defPrompt         = default_prompt,
niksaz's avatar
niksaz committed
162
        defPromptCont     = default_prompt_cont,
163
        fullHelpText      = defFullHelpText
164 165
    }

166 167
ghciWelcomeMsg :: String
ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
168
                 ": https://www.haskell.org/ghc/  :? for help"
169

170
ghciCommands :: [Command]
171
ghciCommands = map mkCmd [
172 173 174 175 176 177 178 179 180 181 182 183
  -- 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),
184 185
  ("ctags",     keepGoing createCTagsWithLineNumbersCmd, completeFilename),
  ("ctags!",    keepGoing createCTagsWithRegExesCmd, completeFilename),
186 187 188
  ("def",       keepGoing (defineMacro False),  completeExpression),
  ("def!",      keepGoing (defineMacro True),   completeExpression),
  ("delete",    keepGoing deleteCmd,            noCompletion),
189
  ("doc",       keepGoing' docCmd,              completeIdentifier),
190
  ("edit",      keepGoing' editFile,            completeFilename),
191 192 193 194 195
  ("etags",     keepGoing createETagsFileCmd,   completeFilename),
  ("force",     keepGoing forceCmd,             completeExpression),
  ("forward",   keepGoing forwardCmd,           noCompletion),
  ("help",      keepGoing help,                 noCompletion),
  ("history",   keepGoing historyCmd,           noCompletion),
196 197
  ("info",      keepGoing' (info False),        completeIdentifier),
  ("info!",     keepGoing' (info True),         completeIdentifier),
198
  ("issafe",    keepGoing' isSafeCmd,           completeModule),
199 200
  ("kind",      keepGoing' (kindOfType False),  completeIdentifier),
  ("kind!",     keepGoing' (kindOfType True),   completeIdentifier),
201 202
  ("load",      keepGoingPaths loadModule_,     completeHomeModuleOrFile),
  ("load!",     keepGoingPaths loadModuleDefer, completeHomeModuleOrFile),
203
  ("list",      keepGoing' listCmd,             noCompletion),
204
  ("module",    keepGoing moduleCmd,            completeSetModule),
205 206 207
  ("main",      keepGoing runMain,              completeFilename),
  ("print",     keepGoing printCmd,             completeExpression),
  ("quit",      quit,                           noCompletion),
208 209
  ("reload",    keepGoing' reloadModule,        noCompletion),
  ("reload!",   keepGoing' reloadModuleDefer,   noCompletion),
210
  ("run",       keepGoing runRun,               completeFilename),
vivian's avatar
vivian committed
211
  ("script",    keepGoing' scriptCmd,           completeFilename),
212
  ("set",       keepGoing setCmd,               completeSetOptions),
213
  ("seti",      keepGoing setiCmd,              completeSeti),
214
  ("show",      keepGoing showCmd,              completeShowOptions),
215
  ("showi",     keepGoing showiCmd,             completeShowiOptions),
216 217 218 219 220 221
  ("sprint",    keepGoing sprintCmd,            completeExpression),
  ("step",      keepGoing stepCmd,              completeIdentifier),
  ("steplocal", keepGoing stepLocalCmd,         completeIdentifier),
  ("stepmodule",keepGoing stepModuleCmd,        completeIdentifier),
  ("type",      keepGoing' typeOfExpr,          completeExpression),
  ("trace",     keepGoing traceCmd,             completeExpression),
222
  ("unadd",     keepGoingPaths unAddModule,     completeFilename),
223
  ("undef",     keepGoing undefineMacro,        completeMacro),
224 225
  ("unset",     keepGoing unsetOptions,         completeSetOptions),
  ("where",     keepGoing whereCmd,             noCompletion)
226
  ] ++ map mkCmdHidden [ -- hidden commands
227 228 229 230 231
  ("all-types", keepGoing' allTypesCmd),
  ("complete",  keepGoing completeCmd),
  ("loc-at",    keepGoing' locAtCmd),
  ("type-at",   keepGoing' typeAtCmd),
  ("uses",      keepGoing' usesCmd)
232
  ]
233 234 235 236 237 238 239 240 241 242 243 244
 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
                              }
245

dterei's avatar
dterei committed
246
-- We initialize readline (in the interactiveUI function) to use
247 248 249 250
-- 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
251
--
252 253
-- NOTE: in order for us to override the default correctly, any custom entry
-- must be a SUBSET of word_break_chars.
254
word_break_chars :: String
Geraldus's avatar
Geraldus committed
255 256 257 258 259 260
word_break_chars = spaces ++ specials ++ symbols

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

262
flagWordBreakChars :: String
263 264 265
flagWordBreakChars = " \t\n"


266 267 268 269 270
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
271

272
keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
Ian Lynagh's avatar
Ian Lynagh committed
273 274
keepGoingPaths a str
 = do case toArgs str of
Ian Lynagh's avatar
Ian Lynagh committed
275
          Left err -> liftIO $ hPutStrLn stderr err
Ian Lynagh's avatar
Ian Lynagh committed
276 277
          Right args -> a args
      return False
sof's avatar
sof committed
278

279 280
defShortHelpText :: String
defShortHelpText = "use :? for help.\n"
281

282 283
defFullHelpText :: String
defFullHelpText =
dterei's avatar
dterei committed
284 285 286 287 288 289 290 291 292 293
  " 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" ++
294
  "   :complete <dom> [<rng>] <s> list completions for partial input string\n" ++
295
  "   :ctags[!] [<file>]          create tags file <file> for Vi (default: \"tags\")\n" ++
dterei's avatar
dterei committed
296
  "                               (!: use regex instead of line number)\n" ++
297 298
  "   :def <cmd> <expr>           define command :<cmd> (later defined command has\n" ++
  "                               precedence, ::<cmd> is always a builtin command)\n" ++
299
  "   :doc <name>                 display docs for the given name (experimental)\n" ++
dterei's avatar
dterei committed
300 301
  "   :edit <file>                edit file\n" ++
  "   :edit                       edit last module\n" ++
302
  "   :etags [<file>]             create tags file <file> for Emacs (default: \"TAGS\")\n" ++
dterei's avatar
dterei committed
303
  "   :help, :?                   display this list of commands\n" ++
304 305
  "   :info[!] [<name> ...]       display information about the given names\n" ++
  "                               (!: do not filter instances)\n" ++
dterei's avatar
dterei committed
306
  "   :issafe [<mod>]             display safe haskell information of module <mod>\n" ++
307 308
  "   :kind[!] <type>             show the kind of <type>\n" ++
  "                               (!: also print the normalised type)\n" ++
309 310
  "   :load[!] [*]<module> ...    load module(s) and their dependents\n" ++
  "                               (!: defer type errors)\n" ++
dterei's avatar
dterei committed
311 312 313
  "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
  "   :quit                       exit GHCi\n" ++
314 315
  "   :reload[!]                  reload the current module set\n" ++
  "                               (!: defer type errors)\n" ++
dterei's avatar
dterei committed
316
  "   :run function [<arguments> ...] run the function with the given arguments\n" ++
317
  "   :script <file>              run the script <file>\n" ++
dterei's avatar
dterei committed
318
  "   :type <expr>                show the type of <expr>\n" ++
319 320
  "   :type +d <expr>             show the type of <expr>, defaulting type variables\n" ++
  "   :type +v <expr>             show the type of <expr>, with its specified tyvars\n" ++
321
  "   :unadd <module> ...         remove module(s) from the current target set\n" ++
dterei's avatar
dterei committed
322 323 324 325 326 327
  "   :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" ++
328
  "   :back [<n>]                 go back in the history N steps (after :trace)\n" ++
dterei's avatar
dterei committed
329 330 331 332 333 334
  "   :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" ++
335
  "   :forward [<n>]              go forward in the history N step s(after :back)\n" ++
dterei's avatar
dterei committed
336 337
  "   :history [<n>]              after :trace, show the execution history\n" ++
  "   :list                       show the source code around current breakpoint\n" ++
338
  "   :list <identifier>          show the source code for <identifier>\n" ++
dterei's avatar
dterei committed
339
  "   :list [<module>] <line>     show the source code around line number <line>\n" ++
Austin Seipp's avatar
Austin Seipp committed
340 341
  "   :print [<name> ...]         show a value without forcing its computation\n" ++
  "   :sprint [<name> ...]        simplified version of :print\n" ++
dterei's avatar
dterei committed
342 343 344 345 346 347
  "   :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
348

dterei's avatar
dterei committed
349 350 351 352
  "\n" ++
  " -- Commands for changing settings:\n" ++
  "\n" ++
  "   :set <option> ...           set options\n" ++
353
  "   :seti <option> ...          set options for interactive evaluation only\n" ++
dterei's avatar
dterei committed
354 355 356
  "   :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" ++
niksaz's avatar
niksaz committed
357 358 359 360
  "   :set prompt-cont <prompt>   set the continuation prompt used in GHCi\n" ++
  "   :set prompt-function <expr> set the function to handle the prompt\n" ++
  "   :set prompt-cont-function <expr>" ++
                     "set the function to handle the continuation prompt\n" ++
dterei's avatar
dterei committed
361 362 363 364 365 366
  "   :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
367
  "    +m            allow multiline commands\n" ++
dterei's avatar
dterei committed
368 369 370
  "    +r            revert top-level expressions after each evaluation\n" ++
  "    +s            print timing/memory stats after each evaluation\n" ++
  "    +t            print type after evaluation\n" ++
371
  "    +c            collect type/location info after loading modules\n" ++
dterei's avatar
dterei committed
372
  "    -<flags>      most GHC command line flags can also be set here\n" ++
373
  "                         (eg. -v2, -XFlexibleInstances, etc.)\n" ++
dterei's avatar
dterei committed
374 375 376 377 378 379 380 381
  "                    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" ++
382
  "   :show imports               show the current imports\n" ++
383
  "   :show linker                show current linker state\n" ++
dterei's avatar
dterei committed
384 385
  "   :show modules               show the currently loaded modules\n" ++
  "   :show packages              show the currently active package flags\n" ++
386
  "   :show paths                 show the currently active search paths\n" ++
387
  "   :show language              show the currently active language flags\n" ++
388
  "   :show targets               show the current set of targets\n" ++
dterei's avatar
dterei committed
389
  "   :show <setting>             show value of <setting>, which is one of\n" ++
niksaz's avatar
niksaz committed
390
  "                                  [args, prog, editor, stop]\n" ++
391
  "   :showi language             show language flags for interactive evaluation\n" ++
dterei's avatar
dterei committed
392
  "\n"
393

Simon Marlow's avatar
Simon Marlow committed
394
findEditor :: IO String
Simon Marlow's avatar
Simon Marlow committed
395
findEditor = do
dterei's avatar
dterei committed
396
  getEnv "EDITOR"
397
    `catchIO` \_ -> do
Ben Gamari's avatar
Ben Gamari committed
398
#if defined(mingw32_HOST_OS)
Ian Lynagh's avatar
Ian Lynagh committed
399 400
        win <- System.Win32.getWindowsDirectory
        return (win </> "notepad.exe")
Simon Marlow's avatar
Simon Marlow committed
401
#else
Ian Lynagh's avatar
Ian Lynagh committed
402
        return ""
Simon Marlow's avatar
Simon Marlow committed
403 404
#endif

niksaz's avatar
niksaz committed
405
default_progname, default_stop :: String
Boris Lykah's avatar
Boris Lykah committed
406 407 408
default_progname = "<interactive>"
default_stop = ""

niksaz's avatar
niksaz committed
409 410 411 412
default_prompt, default_prompt_cont :: PromptFunction
default_prompt = generatePromptFunctionFromString "%s> "
default_prompt_cont = generatePromptFunctionFromString "%s| "

Simon Marlow's avatar
Simon Marlow committed
413 414 415
default_args :: [String]
default_args = []

416
interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]
417
              -> Ghc ()
418
interactiveUI config srcs maybe_exprs = do
419 420 421 422 423 424 425 426
   -- 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.
427 428 429
   _ <- liftIO $ newStablePtr stdin
   _ <- liftIO $ newStablePtr stdout
   _ <- liftIO $ newStablePtr stderr
430

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

434
   -- The initial set of DynFlags used for interactive evaluation is the same
435 436
   -- as the global DynFlags, plus -XExtendedDefaultRules and
   -- -XNoMonomorphismRestriction.
437
   -- See note [Changing language extensions for interactive evaluation] #10857
438
   dflags <- getDynFlags
439 440 441 442
   let dflags' = (xopt_set_unlessExplSpec
                      LangExt.ExtendedDefaultRules xopt_set)
               . (xopt_set_unlessExplSpec
                      LangExt.MonomorphismRestriction xopt_unset)
443 444
               $ dflags
   GHC.setInteractiveDynFlags dflags'
445

446 447 448
   lastErrLocationsRef <- liftIO $ newIORef []
   progDynFlags <- GHC.getProgramDynFlags
   _ <- GHC.setProgramDynFlags $
449 450 451 452
      -- Ensure we don't override the user's log action lest we break
      -- -ddump-json (#14078)
      progDynFlags { log_action = ghciLogAction (log_action progDynFlags)
                                                lastErrLocationsRef }
453

454
   when (isNothing maybe_exprs) $ do
Ian Lynagh's avatar
Ian Lynagh committed
455 456 457
        -- Only for GHCi (not runghc and ghc -e):

        -- Turn buffering off for the compiled program's stdout/stderr
458
        turnOffBuffering_ nobuffering
Ian Lynagh's avatar
Ian Lynagh committed
459
        -- Turn buffering off for GHCi's stdout
460 461
        liftIO $ hFlush stdout
        liftIO $ hSetBuffering stdout NoBuffering
Ian Lynagh's avatar
Ian Lynagh committed
462 463
        -- We don't want the cmd line to buffer any input that might be
        -- intended for the program, so unbuffer stdin.
464 465
        liftIO $ hSetBuffering stdin NoBuffering
        liftIO $ hSetBuffering stderr NoBuffering
466
#if defined(mingw32_HOST_OS)
467 468 469
        -- 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.
470
        liftIO $ hSetEncoding stdin utf8
471
#endif
Ian Lynagh's avatar
Ian Lynagh committed
472

473
   default_editor <- liftIO $ findEditor
474
   eval_wrapper <- mkEvalWrapper default_progname default_args
475
   let prelude_import = simpleImportDecl preludeModuleName
Ian Lynagh's avatar
Ian Lynagh committed
476
   startGHCi (runGHCi srcs maybe_exprs)
477
        GHCiState{ progname           = default_progname,
478
                   args               = default_args,
479
                   evalWrapper        = eval_wrapper,
Zejun Wu's avatar
Zejun Wu committed
480 481
                   prompt             = defPrompt config,
                   prompt_cont        = defPromptCont config,
482 483 484
                   stop               = default_stop,
                   editor             = default_editor,
                   options            = [],
485
                   localConfig        = SourceLocalConfig,
486 487 488 489
                   -- 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,
490 491 492 493
                   break_ctr          = 0,
                   breaks             = [],
                   tickarrays         = emptyModuleEnv,
                   ghci_commands      = availableCommands config,
Ben Gamari's avatar
Ben Gamari committed
494
                   ghci_macros        = [],
495
                   last_command       = Nothing,
Zejun Wu's avatar
Zejun Wu committed
496
                   cmd_wrapper        = (cmdSuccess =<<),
497 498 499
                   cmdqueue           = [],
                   remembered_ctx     = [],
                   transient_ctx      = [],
500 501
                   extra_imports      = [],
                   prelude_imports    = [prelude_import],
502 503 504
                   ghc_e              = isJust maybe_exprs,
                   short_help         = shortHelpText config,
                   long_help          = fullHelpText config,
505
                   lastErrorLocations = lastErrLocationsRef,
506
                   mod_infos          = M.empty,
507 508
                   flushStdHandles    = flush,
                   noBuffering        = nobuffering
mnislaih's avatar
mnislaih committed
509
                 }
510

511 512
   return ()

513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538
{-
Note [Changing language extensions for interactive evaluation]
--------------------------------------------------------------
GHCi maintains two sets of options:

- The "loading options" apply when loading modules
- The "interactive options" apply when evaluating expressions and commands
    typed at the GHCi prompt.

The loading options are mostly created in ghc/Main.hs:main' from the command
line flags. In the function ghc/GHCi/UI.hs:interactiveUI the loading options
are copied to the interactive options.

These interactive options (but not the loading options!) are supplemented
unconditionally by setting ExtendedDefaultRules ON and
MonomorphismRestriction OFF. The unconditional setting of these options
eventually overwrite settings already specified at the command line.

Therefore instead of unconditionally setting ExtendedDefaultRules and
NoMonomorphismRestriction for the interactive options, we use the function
'xopt_set_unlessExplSpec' to first check whether the extension has already
specified at the command line.

The ghci config file has not yet been processed.
-}

539
resetLastErrorLocations :: GhciMonad m => m ()
540 541 542 543
resetLastErrorLocations = do
    st <- getGHCiState
    liftIO $ writeIORef (lastErrorLocations st) []

544 545 546 547
ghciLogAction :: LogAction -> IORef [(FastString, Int)] ->  LogAction
ghciLogAction old_log_action lastErrLocations
              dflags flag severity srcSpan style msg = do
    old_log_action dflags flag severity srcSpan style msg
548 549 550 551 552 553 554
    case severity of
        SevError -> case srcSpan of
            RealSrcSpan rsp -> modifyIORef lastErrLocations
                (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])
            _ -> return ()
        _ -> return ()

555 556
withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
withGhcAppData right left = do
557
    either_dir <- tryIO (getAppUserDataDirectory "ghc")
558 559 560 561 562
    case either_dir of
        Right dir ->
            do createDirectoryIfMissing False dir `catchIO` \_ -> return ()
               right dir
        _ -> left
563

Ian Lynagh's avatar
Ian Lynagh committed
564 565
runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
runGHCi paths maybe_exprs = do
566
  dflags <- getDynFlags
567
  let
568
   ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags
569

Ian Lynagh's avatar
Ian Lynagh committed
570
   app_user_dir = liftIO $ withGhcAppData
571 572
                    (\dir -> return (Just (dir </> "ghci.conf")))
                    (return Nothing)
573 574

   home_dir = do
575
    either_dir <- liftIO $ tryIO (getEnv "HOME")
576 577 578 579
    case either_dir of
      Right home -> return (Just (home </> ".ghci"))
      _ -> return Nothing

580 581 582 583
   canonicalizePath' :: FilePath -> IO (Maybe FilePath)
   canonicalizePath' fp = liftM Just (canonicalizePath fp)
                `catchIO` \_ -> return Nothing

584 585
   sourceConfigFile :: FilePath -> GHCi ()
   sourceConfigFile file = do
Ian Lynagh's avatar
Ian Lynagh committed
586
     exists <- liftIO $ doesFileExist file
587
     when exists $ do
588 589 590 591 592 593 594 595 596 597
       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 ())
598 599 600 601 602
                -- 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)
603

604 605
  --

606
  setGHCContextFromGHCiState
Ian Lynagh's avatar
Ian Lynagh committed
607

608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635
  processedCfgs <- if ignore_dot_ghci
    then pure []
    else do
      userCfgs <- do
        paths <- catMaybes <$> sequence [ app_user_dir, home_dir ]
        checkedPaths <- liftIO $ filterM checkFileAndDirPerms paths
        liftIO . fmap (nub . catMaybes) $ mapM canonicalizePath' checkedPaths

      localCfg <- do
        let path = ".ghci"
        ok <- liftIO $ checkFileAndDirPerms path
        if ok then liftIO $ canonicalizePath' path else pure Nothing

      mapM_ sourceConfigFile userCfgs
        -- Process the global and user .ghci
        -- (but not $CWD/.ghci or CLI args, yet)

      behaviour <- localConfig <$> getGHCiState

      processedLocalCfg <- case localCfg of
        Just path | path `notElem` userCfgs ->
          -- don't read .ghci twice if CWD is $HOME
          case behaviour of
            SourceLocalConfig -> localCfg <$ sourceConfigFile path
            IgnoreLocalConfig -> pure Nothing
        _ -> pure Nothing

      pure $ maybe id (:) processedLocalCfg userCfgs
636

637 638 639 640
  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)
641 642 643 644 645

  mapM_ sourceConfigFile $ nub arg_cfgs \\ processedCfgs
    -- Dedup, and remove any configs we already processed.
    -- Importantly, if $PWD/.ghci was ignored due to configuration,
    -- explicitly specifying it does cause it to be processed.
646

647
  -- Perform a :load for files given on the GHCi command line
648 649 650
  -- 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
651
     ok <- ghciHandle (\e -> do showException e; return Failed) $
652
                -- TODO: this is a hack.
653 654
                runInputTWithPrefs defaultPrefs defaultSettings $
                    loadModule paths
Ian Lynagh's avatar
Ian Lynagh committed
655
     when (isJust maybe_exprs && failed ok) $
Ian Lynagh's avatar
Ian Lynagh committed
656
        liftIO (exitWith (ExitFailure 1))
657

658 659
  installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)

660 661
  -- 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
662
  is_tty <- liftIO (hIsTerminalDevice stdin)
663 664
  let show_prompt = verbosity dflags > 0 || is_tty

665
  -- reset line number
666
  modifyGHCiState $ \st -> st{line_number=0}
667

Ian Lynagh's avatar
Ian Lynagh committed
668
  case maybe_exprs of
Ian Lynagh's avatar
Ian Lynagh committed
669
        Nothing ->
sof's avatar
sof committed
670
          do
Ian Lynagh's avatar
Ian Lynagh committed
671
            -- enter the interactive loop
672
            runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
Ian Lynagh's avatar
Ian Lynagh committed
673
        Just exprs -> do
Ian Lynagh's avatar
Ian Lynagh committed
674
            -- just evaluate the expression we were given
Ian Lynagh's avatar
Ian Lynagh committed
675
            enqueueCommands exprs
dterei's avatar
dterei committed
676 677 678 679 680 681 682 683
            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
684
                                   -- this used to be topHandlerFastExit, see #2228
685
            runInputTWithPrefs defaultPrefs defaultSettings $ do
686
                -- make `ghc -e` exit nonzero on invalid input, see #7962
687 688 689 690
                _ <- runCommands' hdle
                     (Just $ hdle (toException $ ExitFailure 1) >> return ())
                     (return Nothing)
                return ()
691 692

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

695 696
runGHCiInput :: InputT GHCi a -> GHCi a
runGHCiInput f = do
Ian Lynagh's avatar
Ian Lynagh committed
697
    dflags <- getDynFlags
698 699 700 701 702 703 704 705 706 707
    let ghciHistory = gopt Opt_GhciHistory dflags
    let localGhciHistory = gopt Opt_LocalGhciHistory dflags
    currentDirectory <- liftIO $ getCurrentDirectory

    histFile <- case (ghciHistory, localGhciHistory) of
      (True, True) -> return (Just (currentDirectory </> ".ghci_history"))
      (True, _) -> liftIO $ withGhcAppData
        (\dir -> return (Just (dir </> "ghci_history"))) (return Nothing)
      _ -> return Nothing

dterei's avatar
dterei committed
708 709 710
    runInputT
        (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})
        f
711

712
-- | How to get the next input line from the user
713 714 715
nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
nextInputLine show_prompt is_tty
  | is_tty = do
dterei's avatar
dterei committed
716 717
    prmpt <- if show_prompt then lift mkPrompt else return ""
    r <- getInputLine prmpt
718 719
    incrementLineNo
    return r
720 721 722
  | otherwise = do
    when show_prompt $ lift mkPrompt >>= liftIO . putStr
    fileLoop stdin
723

724
-- NOTE: We only read .ghci files if they are owned by the current user,
725 726 727
-- 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.
728

rrt's avatar
rrt committed
729 730 731 732
-- 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.
733

734 735
checkFileAndDirPerms :: FilePath -> IO Bool
checkFileAndDirPerms file = do
736
  file_ok <- checkPerms file
thomie's avatar
thomie committed
737 738 739 740
  -- 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.
741
  if file_ok then checkPerms (getDirectory file) else return False
742 743 744 745 746 747
  where
  getDirectory f = case takeDirectory f of
    "" -> "."
    d -> d

checkPerms :: FilePath -> IO Bool
Ben Gamari's avatar
Ben Gamari committed
748
#if defined(mingw32_HOST_OS)
dterei's avatar
dterei committed
749
checkPerms _ = return True
sof's avatar
sof committed
750
#else
751
checkPerms file =
752
  handleIO (\_ -> return False) $ do
753
    st <- getFileStatus file
dterei's avatar
dterei committed
754
    me <- getRealUserID
755 756 757 758 759
    let mode = System.Posix.fileMode st
        ok = (fileOwner st == me || fileOwner st == 0) &&
             groupWriteMode /= mode `intersectFileModes` groupWriteMode &&
             otherWriteMode /= mode `intersectFileModes` otherWriteMode
    unless ok $
760
      -- #8248: Improving warning to include a possible fix.
761
      putStrLn $ "*** WARNING: " ++ file ++
762
                 " is writable by someone else, IGNORING!" ++
Ben Gamari's avatar
Ben Gamari committed
763
                 "\nSuggested fix: execute 'chmod go-w " ++ file ++ "'"
764
    return ok
sof's avatar
sof committed
765
#endif
766

767
incrementLineNo :: GhciMonad m => m ()
768 769 770
incrementLineNo = modifyGHCiState incLineNo
  where
    incLineNo st = st { line_number = line_number st + 1 }
vivian's avatar
vivian committed
771

772
fileLoop :: GhciMonad m => Handle -> m (Maybe String)
773
fileLoop hdl = do
774
   l <- liftIO $ tryIO $ hGetLine hdl
775
   case l of
776
        Left e | isEOFError e              -> return Nothing
777 778 779 780 781
               | -- 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
782
               | InvalidArgument <- etype  -> return Nothing
783
               | otherwise                 -> liftIO $ ioError e
784 785 786 787 788
                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
789
        Right l' -> do
790
           incrementLineNo
dterei's avatar
dterei committed
791
           return (Just l')
792

niksaz's avatar
niksaz committed
793 794 795 796 797 798
formatCurrentTime :: String -> IO String
formatCurrentTime format =
  getZonedTime >>= return . (formatTime defaultTimeLocale format)

getUserName :: IO String
getUserName = do
Ben Gamari's avatar
Ben Gamari committed
799
#if defined(mingw32_HOST_OS)