UI.hs 155 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
import qualified GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls' )
import GHCi.UI.Monad hiding ( args, runStmt )
36 37
import GHCi.UI.Tags
import GHCi.UI.Info
38
import Debugger
39

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

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

72 73
import DynamicLoading ( initializePlugins )

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

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

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

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

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

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

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

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

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

143 144
import GHCi.Leak

145 146
-----------------------------------------------------------------------------

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

445 446 447 448 449
   lastErrLocationsRef <- liftIO $ newIORef []
   progDynFlags <- GHC.getProgramDynFlags
   _ <- GHC.setProgramDynFlags $
      progDynFlags { log_action = ghciLogAction lastErrLocationsRef }

450
   when (isNothing maybe_exprs) $ do
Ian Lynagh's avatar
Ian Lynagh committed
451 452 453
        -- Only for GHCi (not runghc and ghc -e):

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

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

505 506
   return ()

507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532
{-
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.
-}

533 534 535 536 537 538
resetLastErrorLocations :: GHCi ()
resetLastErrorLocations = do
    st <- getGHCiState
    liftIO $ writeIORef (lastErrorLocations st) []

ghciLogAction :: IORef [(FastString, Int)] ->  LogAction
539 540
ghciLogAction lastErrLocations dflags flag severity srcSpan style msg = do
    defaultLogAction dflags flag severity srcSpan style msg
541 542 543 544 545 546 547
    case severity of
        SevError -> case srcSpan of
            RealSrcSpan rsp -> modifyIORef lastErrLocations
                (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])
            _ -> return ()
        _ -> return ()

548 549
withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
withGhcAppData right left = do
550
    either_dir <- tryIO (getAppUserDataDirectory "ghc")
551 552 553 554 555
    case either_dir of
        Right dir ->
            do createDirectoryIfMissing False dir `catchIO` \_ -> return ()
               right dir
        _ -> left
556

Ian Lynagh's avatar
Ian Lynagh committed
557 558
runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
runGHCi paths maybe_exprs = do
559
  dflags <- getDynFlags
560
  let
561
   ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags
562

563 564
   current_dir = return (Just ".ghci")

Ian Lynagh's avatar
Ian Lynagh committed
565
   app_user_dir = liftIO $ withGhcAppData
566 567
                    (\dir -> return (Just (dir </> "ghci.conf")))
                    (return Nothing)
568 569

   home_dir = do
570
    either_dir <- liftIO $ tryIO (getEnv "HOME")
571 572 573 574
    case either_dir of
      Right home -> return (Just (home </> ".ghci"))
      _ -> return Nothing

575 576 577 578
   canonicalizePath' :: FilePath -> IO (Maybe FilePath)
   canonicalizePath' fp = liftM Just (canonicalizePath fp)
                `catchIO` \_ -> return Nothing

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

599 600
  --

601
  setGHCContextFromGHCiState
Ian Lynagh's avatar
Ian Lynagh committed
602

603 604
  dot_cfgs <- if ignore_dot_ghci then return [] else do
    dot_files <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]
605
    liftIO $ filterM checkFileAndDirPerms dot_files
606 607
  mdot_cfgs <- liftIO $ mapM canonicalizePath' dot_cfgs

608 609 610 611
  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)
612
  mapM_ sourceConfigFile $ nub $ (catMaybes mdot_cfgs) ++ arg_cfgs
613
    -- nub, because we don't want to read .ghci twice if the CWD is $HOME.
614

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

626 627
  installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)

628 629
  -- 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
630
  is_tty <- liftIO (hIsTerminalDevice stdin)
631 632
  let show_prompt = verbosity dflags > 0 || is_tty

633
  -- reset line number
634
  modifyGHCiState $ \st -> st{line_number=0}
635

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

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

663 664
runGHCiInput :: InputT GHCi a -> GHCi a
runGHCiInput f = do
Ian Lynagh's avatar
Ian Lynagh committed
665
    dflags <- getDynFlags
666 667 668 669 670 671 672 673 674 675
    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
676 677 678
    runInputT
        (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})
        f
679

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

692
-- NOTE: We only read .ghci files if they are owned by the current user,
693 694 695
-- 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.
696

rrt's avatar
rrt committed
697 698 699 700
-- 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.
701

702 703
checkFileAndDirPerms :: FilePath -> IO Bool
checkFileAndDirPerms file = do
704
  file_ok <- checkPerms file
thomie's avatar
thomie committed
705 706 707 708
  -- 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.
709
  if file_ok then checkPerms (getDirectory file) else return False
710 711 712 713 714 715
  where
  getDirectory f = case takeDirectory f of
    "" -> "."
    d -> d

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

735
incrementLineNo :: InputT GHCi ()
736 737 738
incrementLineNo = modifyGHCiState incLineNo
  where
    incLineNo st = st { line_number = line_number st + 1 }
vivian's avatar
vivian committed
739 740

fileLoop :: Handle -> InputT GHCi (Maybe String)
741
fileLoop hdl = do
742
   l <- liftIO $ tryIO $ hGetLine hdl
743
   case l of
744
        Left e | isEOFError e              -> return Nothing
745 746 747 748 749
               | -- 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
750
               | InvalidArgument <- etype  -> return Nothing
751
               | otherwise                 -> liftIO $ ioError e
752 753 754 755 756
                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
757
        Right l' -> do
758
           incrementLineNo
dterei's avatar
dterei committed
759
           return (Just l')
760

niksaz's avatar
niksaz committed
761 762 763 764 765 766
formatCurrentTime :: String -> IO String
formatCurrentTime format =
  getZonedTime >>= return . (formatTime defaultTimeLocale format)

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

getInfoForPrompt :: GHCi (SDoc, [String], Int)
getInfoForPrompt = do
778
  st <- getGHCiState
779
  imports <- GHC.getContext
780
  resumes <- GHC.getResumeContext
781 782 783 784

  context_bit <-
        case resumes of
            [] -> return empty
Simon Marlow's avatar
Simon Marlow committed
785
            r:_ -> do
786 787 788 789 790
                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
791 792 793
                        pan <- GHC.getHistorySpan hist
                        return (brackets (ppr (negate ix) <> char ':'
                                          <+> ppr pan) <> space)