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

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

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

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

31 32
#include "HsVersions.h"

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

40
-- The GHC interface
41
import GHCi
42 43
import GHCi.RemoteTypes
import GHCi.BreakArray
dterei's avatar
dterei committed
44
import DynFlags
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 HsImpExp
54
import HsSyn
55
import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,
56
                  setInteractivePrintName, hsc_dflags, msObjFilePath )
dterei's avatar
dterei committed
57
import Module
58
import Name
59 60
import Packages ( trusted, getPackageDetails, getInstalledPackageDetails,
                  listVisibleModuleNames, pprFlag )
61
import IfaceSyn ( showToHeader )
dterei's avatar
dterei committed
62
import PprTyThing
63
import PrelNames
64
import RdrName ( getGRE_NameQualifier_maybes, getRdrName )
65
import SrcLoc
dterei's avatar
dterei committed
66 67 68
import qualified Lexer

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

71 72
import DynamicLoading ( initializePlugins )

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

dterei's avatar
dterei committed
86
-- Haskell Libraries
87
import System.Console.Haskeline as Haskeline
88

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

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

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

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

niksaz's avatar
niksaz committed
129 130
import Unsafe.Coerce

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

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

141 142
import GHCi.Leak

143 144
-----------------------------------------------------------------------------

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

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

163 164 165
ghciWelcomeMsg :: String
ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
                 ": http://www.haskell.org/ghc/  :? for help"
166

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

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

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

259
flagWordBreakChars :: String
260 261 262
flagWordBreakChars = " \t\n"


263 264 265 266 267
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
268

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

276 277
defShortHelpText :: String
defShortHelpText = "use :? for help.\n"
278

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

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

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

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

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

Simon Marlow's avatar
Simon Marlow committed
410 411 412
default_args :: [String]
default_args = []

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

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

431
   -- The initial set of DynFlags used for interactive evaluation is the same
432 433
   -- as the global DynFlags, plus -XExtendedDefaultRules and
   -- -XNoMonomorphismRestriction.
434
   dflags <- getDynFlags
435 436
   let dflags' = (`xopt_set` LangExt.ExtendedDefaultRules)
               . (`xopt_unset` LangExt.MonomorphismRestriction)
437 438
               $ dflags
   GHC.setInteractiveDynFlags dflags'
439

440 441 442 443 444
   lastErrLocationsRef <- liftIO $ newIORef []
   progDynFlags <- GHC.getProgramDynFlags
   _ <- GHC.setProgramDynFlags $
      progDynFlags { log_action = ghciLogAction lastErrLocationsRef }

445
   when (isNothing maybe_exprs) $ do
Ian Lynagh's avatar
Ian Lynagh committed
446 447 448
        -- Only for GHCi (not runghc and ghc -e):

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

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

500 501
   return ()

502 503 504 505 506 507
resetLastErrorLocations :: GHCi ()
resetLastErrorLocations = do
    st <- getGHCiState
    liftIO $ writeIORef (lastErrorLocations st) []

ghciLogAction :: IORef [(FastString, Int)] ->  LogAction
508 509
ghciLogAction lastErrLocations dflags flag severity srcSpan style msg = do
    defaultLogAction dflags flag severity srcSpan style msg
510 511 512 513 514 515 516
    case severity of
        SevError -> case srcSpan of
            RealSrcSpan rsp -> modifyIORef lastErrLocations
                (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])
            _ -> return ()
        _ -> return ()

517 518
withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
withGhcAppData right left = do
519
    either_dir <- tryIO (getAppUserDataDirectory "ghc")
520 521 522 523 524
    case either_dir of
        Right dir ->
            do createDirectoryIfMissing False dir `catchIO` \_ -> return ()
               right dir
        _ -> left
525

Ian Lynagh's avatar
Ian Lynagh committed
526 527
runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
runGHCi paths maybe_exprs = do
528
  dflags <- getDynFlags
529
  let
530
   ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags
531

532 533
   current_dir = return (Just ".ghci")

Ian Lynagh's avatar
Ian Lynagh committed
534
   app_user_dir = liftIO $ withGhcAppData
535 536
                    (\dir -> return (Just (dir </> "ghci.conf")))
                    (return Nothing)
537 538

   home_dir = do
539
    either_dir <- liftIO $ tryIO (getEnv "HOME")
540 541 542 543
    case either_dir of
      Right home -> return (Just (home </> ".ghci"))
      _ -> return Nothing

544 545 546 547
   canonicalizePath' :: FilePath -> IO (Maybe FilePath)
   canonicalizePath' fp = liftM Just (canonicalizePath fp)
                `catchIO` \_ -> return Nothing

548 549
   sourceConfigFile :: FilePath -> GHCi ()
   sourceConfigFile file = do
Ian Lynagh's avatar
Ian Lynagh committed
550
     exists <- liftIO $ doesFileExist file
551
     when exists $ do
552 553 554 555 556 557 558 559 560 561
       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 ())
562 563 564 565 566
                -- 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)
567

568 569
  --

570
  setGHCContextFromGHCiState
Ian Lynagh's avatar
Ian Lynagh committed
571

572 573
  dot_cfgs <- if ignore_dot_ghci then return [] else do
    dot_files <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]
574
    liftIO $ filterM checkFileAndDirPerms dot_files
575 576
  mdot_cfgs <- liftIO $ mapM canonicalizePath' dot_cfgs

577 578 579 580
  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)
581
  mapM_ sourceConfigFile $ nub $ (catMaybes mdot_cfgs) ++ arg_cfgs
582
    -- nub, because we don't want to read .ghci twice if the CWD is $HOME.
583

584
  -- Perform a :load for files given on the GHCi command line
585 586 587
  -- 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
588
     ok <- ghciHandle (\e -> do showException e; return Failed) $
589
                -- TODO: this is a hack.
590 591
                runInputTWithPrefs defaultPrefs defaultSettings $
                    loadModule paths
Ian Lynagh's avatar
Ian Lynagh committed
592
     when (isJust maybe_exprs && failed ok) $
Ian Lynagh's avatar
Ian Lynagh committed
593
        liftIO (exitWith (ExitFailure 1))
594

595 596
  installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)

597 598
  -- 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
599
  is_tty <- liftIO (hIsTerminalDevice stdin)
600 601
  let show_prompt = verbosity dflags > 0 || is_tty

602
  -- reset line number
603
  modifyGHCiState $ \st -> st{line_number=0}
604

Ian Lynagh's avatar
Ian Lynagh committed
605
  case maybe_exprs of
Ian Lynagh's avatar
Ian Lynagh committed
606
        Nothing ->
sof's avatar
sof committed
607
          do
Ian Lynagh's avatar
Ian Lynagh committed
608
            -- enter the interactive loop
609
            runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
Ian Lynagh's avatar
Ian Lynagh committed
610
        Just exprs -> do
Ian Lynagh's avatar
Ian Lynagh committed
611
            -- just evaluate the expression we were given
Ian Lynagh's avatar
Ian Lynagh committed
612
            enqueueCommands exprs
dterei's avatar
dterei committed
613 614 615 616 617 618 619 620
            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
621
                                   -- this used to be topHandlerFastExit, see #2228
622
            runInputTWithPrefs defaultPrefs defaultSettings $ do
623
                -- make `ghc -e` exit nonzero on invalid input, see Trac #7962
624 625 626 627
                _ <- runCommands' hdle
                     (Just $ hdle (toException $ ExitFailure 1) >> return ())
                     (return Nothing)
                return ()
628 629

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

632 633
runGHCiInput :: InputT GHCi a -> GHCi a
runGHCiInput f = do
Ian Lynagh's avatar
Ian Lynagh committed
634
    dflags <- getDynFlags
635 636 637 638 639 640 641 642 643 644
    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
645 646 647
    runInputT
        (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})
        f
648

649
-- | How to get the next input line from the user
650 651 652
nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
nextInputLine show_prompt is_tty
  | is_tty = do
dterei's avatar
dterei committed
653 654
    prmpt <- if show_prompt then lift mkPrompt else return ""
    r <- getInputLine prmpt
655 656
    incrementLineNo
    return r
657 658 659
  | otherwise = do
    when show_prompt $ lift mkPrompt >>= liftIO . putStr
    fileLoop stdin
660

661
-- NOTE: We only read .ghci files if they are owned by the current user,
662 663 664
-- 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.
665

rrt's avatar
rrt committed
666 667 668 669
-- 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.
670

671 672
checkFileAndDirPerms :: FilePath -> IO Bool
checkFileAndDirPerms file = do
673
  file_ok <- checkPerms file
thomie's avatar
thomie committed
674 675 676 677
  -- 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.
678
  if file_ok then checkPerms (getDirectory file) else return False
679 680 681 682 683 684
  where
  getDirectory f = case takeDirectory f of
    "" -> "."
    d -> d

checkPerms :: FilePath -> IO Bool
Ben Gamari's avatar
Ben Gamari committed
685
#if defined(mingw32_HOST_OS)
dterei's avatar
dterei committed
686
checkPerms _ = return True
sof's avatar
sof committed
687
#else
688
checkPerms file =
689
  handleIO (\_ -> return False) $ do
690
    st <- getFileStatus file
dterei's avatar
dterei committed
691
    me <- getRealUserID
692 693 694 695 696
    let mode = System.Posix.fileMode st
        ok = (fileOwner st == me || fileOwner st == 0) &&
             groupWriteMode /= mode `intersectFileModes` groupWriteMode &&
             otherWriteMode /= mode `intersectFileModes` otherWriteMode
    unless ok $
697
      -- #8248: Improving warning to include a possible fix.
698
      putStrLn $ "*** WARNING: " ++ file ++
699
                 " is writable by someone else, IGNORING!" ++
Ben Gamari's avatar
Ben Gamari committed
700
                 "\nSuggested fix: execute 'chmod go-w " ++ file ++ "'"
701
    return ok
sof's avatar
sof committed
702
#endif
703

704
incrementLineNo :: InputT GHCi ()
705 706 707
incrementLineNo = modifyGHCiState incLineNo
  where
    incLineNo st = st { line_number = line_number st + 1 }
vivian's avatar
vivian committed
708 709

fileLoop :: Handle -> InputT GHCi (Maybe String)
710
fileLoop hdl = do
711
   l <- liftIO $ tryIO $ hGetLine hdl
712
   case l of
713
        Left e | isEOFError e              -> return Nothing
714 715 716 717 718
               | -- 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
719
               | InvalidArgument <- etype  -> return Nothing
720
               | otherwise                 -> liftIO $ ioError e
721 722 723 724 725
                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
726
        Right l' -> do
727
           incrementLineNo
dterei's avatar
dterei committed
728
           return (Just l')
729

niksaz's avatar
niksaz committed
730 731 732 733 734 735
formatCurrentTime :: String -> IO String
formatCurrentTime format =
  getZonedTime >>= return . (formatTime defaultTimeLocale format)

getUserName :: IO String
getUserName = do
Ben Gamari's avatar
Ben Gamari committed
736
#if defined(mingw32_HOST_OS)
niksaz's avatar
niksaz committed
737 738 739 740 741 742 743 744 745 746
  getEnv "USERNAME"
    `catchIO` \e -> do
      putStrLn $ show e
      return ""
#else
  getLoginName
#endif

getInfoForPrompt :: GHCi (SDoc, [String], Int)
getInfoForPrompt = do
747
  st <- getGHCiState
748
  imports <- GHC.getContext
749
  resumes <- GHC.getResumeContext
750 751 752 753

  context_bit <-
        case resumes of
            [] -> return empty
Simon Marlow's avatar
Simon Marlow committed
754
            r:_ -> do
755 756 757 758 759
                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
760 761 762
                        pan <- GHC.getHistorySpan hist
                        return (brackets (ppr (negate ix) <> char ':'
                                          <+> ppr pan) <> space)
niksaz's avatar
niksaz committed
763

764
  let
Simon Marlow's avatar
Simon Marlow committed
765
        dots | _:rs <- resumes, not (null rs) = text "... "
766 767
             | otherwise = empty

768 769
        rev_imports = reverse imports -- rightmost are the most recent

770
        myIdeclName d | Just m <- ideclAs d = unLoc m
771
                      | otherwise           = unLoc (ideclName d)
772

niksaz's avatar
niksaz committed
773 774 775 776 777 778
        modules_names =
             ['*':(moduleNameString m) | IIModule m <- rev_imports] ++
             [moduleNameString (myIdeclName d) | IIDecl d <- rev_imports]
        line = 1 + line_number st

  return (dots <> context_bit, modules_names, line)