UI.hs 157 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 105
import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,
                   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 486 487 488
                   -- 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,
489 490 491 492
                   break_ctr          = 0,
                   breaks             = [],
                   tickarrays         = emptyModuleEnv,
                   ghci_commands      = availableCommands config,
Ben Gamari's avatar
Ben Gamari committed
493
                   ghci_macros        = [],
494
                   last_command       = Nothing,
Zejun Wu's avatar
Zejun Wu committed
495
                   cmd_wrapper        = (cmdSuccess =<<),
496 497 498
                   cmdqueue           = [],
                   remembered_ctx     = [],
                   transient_ctx      = [],
499 500
                   extra_imports      = [],
                   prelude_imports    = [prelude_import],
501 502 503
                   ghc_e              = isJust maybe_exprs,
                   short_help         = shortHelpText config,
                   long_help          = fullHelpText config,
504
                   lastErrorLocations = lastErrLocationsRef,
505
                   mod_infos          = M.empty,
506 507
                   flushStdHandles    = flush,
                   noBuffering        = nobuffering
mnislaih's avatar
mnislaih committed
508
                 }
509

510 511
   return ()

512 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
{-
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.
-}

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

543 544 545 546
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
547 548 549 550 551 552 553
    case severity of
        SevError -> case srcSpan of
            RealSrcSpan rsp -> modifyIORef lastErrLocations
                (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])
            _ -> return ()
        _ -> return ()

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

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

569 570
   current_dir = return (Just ".ghci")

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

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

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

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

605 606
  --

607
  setGHCContextFromGHCiState
Ian Lynagh's avatar
Ian Lynagh committed
608

609 610
  dot_cfgs <- if ignore_dot_ghci then return [] else do
    dot_files <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]
611
    liftIO $ filterM checkFileAndDirPerms dot_files
612 613
  mdot_cfgs <- liftIO $ mapM canonicalizePath' dot_cfgs

614 615 616 617
  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)
618
  mapM_ sourceConfigFile $ nub $ (catMaybes mdot_cfgs) ++ arg_cfgs
619
    -- nub, because we don't want to read .ghci twice if the CWD is $HOME.
620

621
  -- Perform a :load for files given on the GHCi command line
622 623 624
  -- 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
625
     ok <- ghciHandle (\e -> do showException e; return Failed) $
626
                -- TODO: this is a hack.
627 628
                runInputTWithPrefs defaultPrefs defaultSettings $
                    loadModule paths
Ian Lynagh's avatar
Ian Lynagh committed
629
     when (isJust maybe_exprs && failed ok) $
Ian Lynagh's avatar
Ian Lynagh committed
630
        liftIO (exitWith (ExitFailure 1))
631

632 633
  installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)

634 635
  -- 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
636
  is_tty <- liftIO (hIsTerminalDevice stdin)
637 638
  let show_prompt = verbosity dflags > 0 || is_tty

639
  -- reset line number
640
  modifyGHCiState $ \st -> st{line_number=0}
641

Ian Lynagh's avatar
Ian Lynagh committed
642
  case maybe_exprs of
Ian Lynagh's avatar
Ian Lynagh committed
643
        Nothing ->
sof's avatar
sof committed
644
          do
Ian Lynagh's avatar
Ian Lynagh committed
645
            -- enter the interactive loop
646
            runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
Ian Lynagh's avatar
Ian Lynagh committed
647
        Just exprs -> do
Ian Lynagh's avatar
Ian Lynagh committed
648
            -- just evaluate the expression we were given
Ian Lynagh's avatar
Ian Lynagh committed
649
            enqueueCommands exprs
dterei's avatar
dterei committed
650 651 652 653 654 655 656 657
            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
658
                                   -- this used to be topHandlerFastExit, see #2228
659
            runInputTWithPrefs defaultPrefs defaultSettings $ do
660
                -- make `ghc -e` exit nonzero on invalid input, see #7962
661 662 663 664
                _ <- runCommands' hdle
                     (Just $ hdle (toException $ ExitFailure 1) >> return ())
                     (return Nothing)
                return ()
665 666

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

669 670
runGHCiInput :: InputT GHCi a -> GHCi a
runGHCiInput f = do
Ian Lynagh's avatar
Ian Lynagh committed
671
    dflags <- getDynFlags
672 673 674 675 676 677 678 679 680 681
    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
682 683 684
    runInputT
        (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})
        f
685

686
-- | How to get the next input line from the user
687 688 689
nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
nextInputLine show_prompt is_tty
  | is_tty = do
dterei's avatar
dterei committed
690 691
    prmpt <- if show_prompt then lift mkPrompt else return ""
    r <- getInputLine prmpt
692 693
    incrementLineNo
    return r
694 695 696
  | otherwise = do
    when show_prompt $ lift mkPrompt >>= liftIO . putStr
    fileLoop stdin
697

698
-- NOTE: We only read .ghci files if they are owned by the current user,
699 700 701
-- 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.
702

rrt's avatar
rrt committed
703 704 705 706
-- 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.
707

708 709
checkFileAndDirPerms :: FilePath -> IO Bool
checkFileAndDirPerms file = do
710
  file_ok <- checkPerms file
thomie's avatar
thomie committed
711 712 713 714
  -- 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.
715
  if file_ok then checkPerms (getDirectory file) else return False
716 717 718 719 720 721
  where
  getDirectory f = case takeDirectory f of
    "" -> "."
    d -> d

checkPerms :: FilePath -> IO Bool
Ben Gamari's avatar
Ben Gamari committed
722
#if defined(mingw32_HOST_OS)
dterei's avatar
dterei committed
723
checkPerms _ = return True
sof's avatar
sof committed
724
#else
725
checkPerms file =
726
  handleIO (\_ -> return False) $ do
727
    st <- getFileStatus file
dterei's avatar
dterei committed
728
    me <- getRealUserID
729 730 731 732 733
    let mode = System.Posix.fileMode st
        ok = (fileOwner st == me || fileOwner st == 0) &&
             groupWriteMode /= mode `intersectFileModes` groupWriteMode &&
             otherWriteMode /= mode `intersectFileModes` otherWriteMode
    unless ok $
734
      -- #8248: Improving warning to include a possible fix.
735
      putStrLn $ "*** WARNING: " ++ file ++
736
                 " is writable by someone else, IGNORING!" ++
Ben Gamari's avatar
Ben Gamari committed
737
                 "\nSuggested fix: execute 'chmod go-w " ++ file ++ "'"
738
    return ok
sof's avatar
sof committed
739
#endif
740

741
incrementLineNo :: GhciMonad m => m ()
742 743 744
incrementLineNo = modifyGHCiState incLineNo
  where
    incLineNo st = st { line_number = line_number st + 1 }
vivian's avatar
vivian committed
745

746
fileLoop :: GhciMonad m => Handle -> m (Maybe String)
747
fileLoop hdl = do
748
   l <- liftIO $ tryIO $ hGetLine hdl
749
   case l of
750
        Left e | isEOFError e              -> return Nothing
751 752 753 754 755
               | -- 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
756
               | InvalidArgument <- etype  -> return Nothing
757
               | otherwise                 -> liftIO $ ioError e
758 759 760 761 762
                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
763
        Right l' -> do
764
           incrementLineNo
dterei's avatar
dterei committed
765
           return (Just l')
766

niksaz's avatar
niksaz committed
767 768 769 770 771 772
formatCurrentTime :: String -> IO String
formatCurrentTime format =
  getZonedTime >>= return . (formatTime defaultTimeLocale format)

getUserName :: IO String
getUserName = do
Ben Gamari's avatar
Ben Gamari committed
773
#if defined(mingw32_HOST_OS)
niksaz's avatar
niksaz committed
774 775 776 777 778 779 780 781
  getEnv "USERNAME"
    `catchIO` \e -> do
      putStrLn $ show e
      return ""
#else
  getLoginName
#endif

782
getInfoForPrompt :: GhciMonad m => m (SDoc, [String], Int)
niksaz's avatar
niksaz committed
783
getInfoForPrompt = do
784
  st <-