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

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

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

dterei's avatar
dterei committed
82
-- Haskell Libraries
83
import System.Console.Haskeline as Haskeline
84

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

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

106
import Exception hiding (catch)
107
import Foreign hiding (void)
108
import GHC.Stack hiding (SrcLoc(..))
dterei's avatar
dterei committed
109 110

import System.Directory
111
import System.Environment
dterei's avatar
dterei committed
112
import System.Exit ( exitWith, ExitCode(..) )
dterei's avatar
dterei committed
113
import System.FilePath
niksaz's avatar
niksaz committed
114
import System.Info
ross's avatar
ross committed
115
import System.IO
116
import System.IO.Error
dterei's avatar
dterei committed
117
import System.IO.Unsafe ( unsafePerformIO )
118
import System.Process
Simon Marlow's avatar
Simon Marlow committed
119
import Text.Printf
120
import Text.Read ( readMaybe )
Geraldus's avatar
Geraldus committed
121
import Text.Read.Lex (isSymbolChar)
122

niksaz's avatar
niksaz committed
123 124
import Unsafe.Coerce

Ben Gamari's avatar
Ben Gamari committed
125
#if !defined(mingw32_HOST_OS)
dterei's avatar
dterei committed
126 127 128 129 130
import System.Posix hiding ( getEnv )
#else
import qualified System.Win32
#endif

dterei's avatar
dterei committed
131 132
import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
import GHC.IO.Handle ( hFlushAll )
dterei's avatar
dterei committed
133
import GHC.TopHandler ( topHandler )
134

135 136
-----------------------------------------------------------------------------

137 138 139
data GhciSettings = GhciSettings {
        availableCommands :: [Command],
        shortHelpText     :: String,
140
        fullHelpText      :: String,
niksaz's avatar
niksaz committed
141 142
        defPrompt         :: PromptFunction,
        defPromptCont     :: PromptFunction
143 144 145 146 147 148 149
    }

defaultGhciSettings :: GhciSettings
defaultGhciSettings =
    GhciSettings {
        availableCommands = ghciCommands,
        shortHelpText     = defShortHelpText,
150
        defPrompt         = default_prompt,
niksaz's avatar
niksaz committed
151
        defPromptCont     = default_prompt_cont,
152
        fullHelpText      = defFullHelpText
153 154
    }

155 156 157
ghciWelcomeMsg :: String
ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
                 ": http://www.haskell.org/ghc/  :? for help"
158

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

dterei's avatar
dterei committed
233
-- We initialize readline (in the interactiveUI function) to use
234 235 236 237
-- 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
238
--
239 240
-- NOTE: in order for us to override the default correctly, any custom entry
-- must be a SUBSET of word_break_chars.
241
word_break_chars :: String
Geraldus's avatar
Geraldus committed
242 243 244 245 246 247
word_break_chars = spaces ++ specials ++ symbols

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

249
flagWordBreakChars :: String
250 251 252
flagWordBreakChars = " \t\n"


253 254 255 256 257
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
258

259
keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
Ian Lynagh's avatar
Ian Lynagh committed
260 261
keepGoingPaths a str
 = do case toArgs str of
Ian Lynagh's avatar
Ian Lynagh committed
262
          Left err -> liftIO $ hPutStrLn stderr err
Ian Lynagh's avatar
Ian Lynagh committed
263 264
          Right args -> a args
      return False
sof's avatar
sof committed
265

266 267
defShortHelpText :: String
defShortHelpText = "use :? for help.\n"
268

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

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

Simon Marlow's avatar
Simon Marlow committed
378
findEditor :: IO String
Simon Marlow's avatar
Simon Marlow committed
379
findEditor = do
dterei's avatar
dterei committed
380
  getEnv "EDITOR"
381
    `catchIO` \_ -> do
Ben Gamari's avatar
Ben Gamari committed
382
#if defined(mingw32_HOST_OS)
Ian Lynagh's avatar
Ian Lynagh committed
383 384
        win <- System.Win32.getWindowsDirectory
        return (win </> "notepad.exe")
Simon Marlow's avatar
Simon Marlow committed
385
#else
Ian Lynagh's avatar
Ian Lynagh committed
386
        return ""
Simon Marlow's avatar
Simon Marlow committed
387 388
#endif

niksaz's avatar
niksaz committed
389
default_progname, default_stop :: String
Boris Lykah's avatar
Boris Lykah committed
390 391 392
default_progname = "<interactive>"
default_stop = ""

niksaz's avatar
niksaz committed
393 394 395 396
default_prompt, default_prompt_cont :: PromptFunction
default_prompt = generatePromptFunctionFromString "%s> "
default_prompt_cont = generatePromptFunctionFromString "%s| "

Simon Marlow's avatar
Simon Marlow committed
397 398 399
default_args :: [String]
default_args = []

400
interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]
401
              -> Ghc ()
402
interactiveUI config srcs maybe_exprs = do
403 404 405 406 407 408 409 410
   -- 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.
411 412 413
   _ <- liftIO $ newStablePtr stdin
   _ <- liftIO $ newStablePtr stdout
   _ <- liftIO $ newStablePtr stderr
414

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

418
   -- The initial set of DynFlags used for interactive evaluation is the same
419 420
   -- as the global DynFlags, plus -XExtendedDefaultRules and
   -- -XNoMonomorphismRestriction.
421
   dflags <- getDynFlags
422 423
   let dflags' = (`xopt_set` LangExt.ExtendedDefaultRules)
               . (`xopt_unset` LangExt.MonomorphismRestriction)
424 425
               $ dflags
   GHC.setInteractiveDynFlags dflags'
426

427 428 429 430 431
   lastErrLocationsRef <- liftIO $ newIORef []
   progDynFlags <- GHC.getProgramDynFlags
   _ <- GHC.setProgramDynFlags $
      progDynFlags { log_action = ghciLogAction lastErrLocationsRef }

432
   when (isNothing maybe_exprs) $ do
Ian Lynagh's avatar
Ian Lynagh committed
433 434 435
        -- Only for GHCi (not runghc and ghc -e):

        -- Turn buffering off for the compiled program's stdout/stderr
436
        turnOffBuffering_ nobuffering
Ian Lynagh's avatar
Ian Lynagh committed
437
        -- Turn buffering off for GHCi's stdout
438 439
        liftIO $ hFlush stdout
        liftIO $ hSetBuffering stdout NoBuffering
Ian Lynagh's avatar
Ian Lynagh committed
440 441
        -- We don't want the cmd line to buffer any input that might be
        -- intended for the program, so unbuffer stdin.
442 443
        liftIO $ hSetBuffering stdin NoBuffering
        liftIO $ hSetBuffering stderr NoBuffering
444
#if defined(mingw32_HOST_OS)
445 446 447
        -- 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.
448
        liftIO $ hSetEncoding stdin utf8
449
#endif
Ian Lynagh's avatar
Ian Lynagh committed
450

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

487 488
   return ()

489 490 491 492 493 494
resetLastErrorLocations :: GHCi ()
resetLastErrorLocations = do
    st <- getGHCiState
    liftIO $ writeIORef (lastErrorLocations st) []

ghciLogAction :: IORef [(FastString, Int)] ->  LogAction
495 496
ghciLogAction lastErrLocations dflags flag severity srcSpan style msg = do
    defaultLogAction dflags flag severity srcSpan style msg
497 498 499 500 501 502 503
    case severity of
        SevError -> case srcSpan of
            RealSrcSpan rsp -> modifyIORef lastErrLocations
                (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])
            _ -> return ()
        _ -> return ()

504 505
withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
withGhcAppData right left = do
506
    either_dir <- tryIO (getAppUserDataDirectory "ghc")
507 508 509 510 511
    case either_dir of
        Right dir ->
            do createDirectoryIfMissing False dir `catchIO` \_ -> return ()
               right dir
        _ -> left
512

Ian Lynagh's avatar
Ian Lynagh committed
513 514
runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
runGHCi paths maybe_exprs = do
515
  dflags <- getDynFlags
516
  let
517
   ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags
518

519 520
   current_dir = return (Just ".ghci")

Ian Lynagh's avatar
Ian Lynagh committed
521
   app_user_dir = liftIO $ withGhcAppData
522 523
                    (\dir -> return (Just (dir </> "ghci.conf")))
                    (return Nothing)
524 525

   home_dir = do
526
    either_dir <- liftIO $ tryIO (getEnv "HOME")
527 528 529 530
    case either_dir of
      Right home -> return (Just (home </> ".ghci"))
      _ -> return Nothing

531 532 533 534
   canonicalizePath' :: FilePath -> IO (Maybe FilePath)
   canonicalizePath' fp = liftM Just (canonicalizePath fp)
                `catchIO` \_ -> return Nothing

535 536
   sourceConfigFile :: FilePath -> GHCi ()
   sourceConfigFile file = do
Ian Lynagh's avatar
Ian Lynagh committed
537
     exists <- liftIO $ doesFileExist file
538
     when exists $ do
539 540 541 542 543 544 545 546 547 548
       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 ())
549 550 551 552 553
                -- 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)
554

555 556
  --

557
  setGHCContextFromGHCiState
Ian Lynagh's avatar
Ian Lynagh committed
558

559 560
  dot_cfgs <- if ignore_dot_ghci then return [] else do
    dot_files <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]
561
    liftIO $ filterM checkFileAndDirPerms dot_files
562 563
  mdot_cfgs <- liftIO $ mapM canonicalizePath' dot_cfgs

564 565 566 567
  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)
568
  mapM_ sourceConfigFile $ nub $ (catMaybes mdot_cfgs) ++ arg_cfgs
569
    -- nub, because we don't want to read .ghci twice if the CWD is $HOME.
570

571
  -- Perform a :load for files given on the GHCi command line
572 573 574
  -- 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
575
     ok <- ghciHandle (\e -> do showException e; return Failed) $
576
                -- TODO: this is a hack.
577 578
                runInputTWithPrefs defaultPrefs defaultSettings $
                    loadModule paths
Ian Lynagh's avatar
Ian Lynagh committed
579
     when (isJust maybe_exprs && failed ok) $
Ian Lynagh's avatar
Ian Lynagh committed
580
        liftIO (exitWith (ExitFailure 1))
581

582 583
  installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)

584 585
  -- 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
586
  is_tty <- liftIO (hIsTerminalDevice stdin)
587 588
  let show_prompt = verbosity dflags > 0 || is_tty

589
  -- reset line number
590
  modifyGHCiState $ \st -> st{line_number=0}
591

Ian Lynagh's avatar
Ian Lynagh committed
592
  case maybe_exprs of
Ian Lynagh's avatar
Ian Lynagh committed
593
        Nothing ->
sof's avatar
sof committed
594
          do
Ian Lynagh's avatar
Ian Lynagh committed
595
            -- enter the interactive loop
596
            runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
Ian Lynagh's avatar
Ian Lynagh committed
597
        Just exprs -> do
Ian Lynagh's avatar
Ian Lynagh committed
598
            -- just evaluate the expression we were given
Ian Lynagh's avatar
Ian Lynagh committed
599
            enqueueCommands exprs
dterei's avatar
dterei committed
600 601 602 603 604 605 606 607
            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
608
                                   -- this used to be topHandlerFastExit, see #2228
609
            runInputTWithPrefs defaultPrefs defaultSettings $ do
610
                -- make `ghc -e` exit nonzero on invalid input, see Trac #7962
611 612 613 614
                _ <- runCommands' hdle
                     (Just $ hdle (toException $ ExitFailure 1) >> return ())
                     (return Nothing)
                return ()
615 616

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

619 620
runGHCiInput :: InputT GHCi a -> GHCi a
runGHCiInput f = do
Ian Lynagh's avatar
Ian Lynagh committed
621
    dflags <- getDynFlags
622 623 624 625 626 627 628 629 630 631
    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
632 633 634
    runInputT
        (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})
        f
635

636
-- | How to get the next input line from the user
637 638 639
nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
nextInputLine show_prompt is_tty
  | is_tty = do
dterei's avatar
dterei committed
640 641
    prmpt <- if show_prompt then lift mkPrompt else return ""
    r <- getInputLine prmpt
642 643
    incrementLineNo
    return r
644 645 646
  | otherwise = do
    when show_prompt $ lift mkPrompt >>= liftIO . putStr
    fileLoop stdin
647

648
-- NOTE: We only read .ghci files if they are owned by the current user,
649 650 651
-- 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.
652

rrt's avatar
rrt committed
653 654 655 656
-- 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.
657

658 659
checkFileAndDirPerms :: FilePath -> IO Bool
checkFileAndDirPerms file = do
660
  file_ok <- checkPerms file
thomie's avatar
thomie committed
661 662 663 664
  -- 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.
665
  if file_ok then checkPerms (getDirectory file) else return False
666 667 668 669 670 671
  where
  getDirectory f = case takeDirectory f of
    "" -> "."
    d -> d

checkPerms :: FilePath -> IO Bool
Ben Gamari's avatar
Ben Gamari committed
672
#if defined(mingw32_HOST_OS)
dterei's avatar
dterei committed
673
checkPerms _ = return True
sof's avatar
sof committed
674
#else
675
checkPerms file =
676
  handleIO (\_ -> return False) $ do
677
    st <- getFileStatus file
dterei's avatar
dterei committed
678
    me <- getRealUserID
679 680 681 682 683
    let mode = System.Posix.fileMode st
        ok = (fileOwner st == me || fileOwner st == 0) &&
             groupWriteMode /= mode `intersectFileModes` groupWriteMode &&
             otherWriteMode /= mode `intersectFileModes` otherWriteMode
    unless ok $
684
      -- #8248: Improving warning to include a possible fix.
685
      putStrLn $ "*** WARNING: " ++ file ++
686
                 " is writable by someone else, IGNORING!" ++
Ben Gamari's avatar
Ben Gamari committed
687
                 "\nSuggested fix: execute 'chmod go-w " ++ file ++ "'"
688
    return ok
sof's avatar
sof committed
689
#endif
690

691
incrementLineNo :: InputT GHCi ()
692 693 694
incrementLineNo = modifyGHCiState incLineNo
  where
    incLineNo st = st { line_number = line_number st + 1 }
vivian's avatar
vivian committed
695 696

fileLoop :: Handle -> InputT GHCi (Maybe String)
697
fileLoop hdl = do
698
   l <- liftIO $ tryIO $ hGetLine hdl
699
   case l of
700
        Left e | isEOFError e              -> return Nothing
701 702 703 704 705
               | -- 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
706
               | InvalidArgument <- etype  -> return Nothing
707
               | otherwise                 -> liftIO $ ioError e
708 709 710 711 712
                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
713
        Right l' -> do
714
           incrementLineNo
dterei's avatar
dterei committed
715
           return (Just l')
716

niksaz's avatar
niksaz committed
717 718 719 720 721 722
formatCurrentTime :: String -> IO String
formatCurrentTime format =
  getZonedTime >>= return . (formatTime defaultTimeLocale format)

getUserName :: IO String
getUserName = do
Ben Gamari's avatar
Ben Gamari committed
723
#if defined(mingw32_HOST_OS)
niksaz's avatar
niksaz committed
724 725 726 727 728 729 730 731 732 733
  getEnv "USERNAME"
    `catchIO` \e -> do
      putStrLn $ show e
      return ""
#else
  getLoginName
#endif

getInfoForPrompt :: GHCi (SDoc, [String], Int)
getInfoForPrompt = do
734
  st <- getGHCiState
735
  imports <- GHC.getContext
736
  resumes <- GHC.getResumeContext
737 738 739 740

  context_bit <-
        case resumes of
            [] -> return empty
Simon Marlow's avatar
Simon Marlow committed
741
            r:_ -> do
742 743 744 745 746
                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
747 748 749
                        pan <- GHC.getHistorySpan hist
                        return (brackets (ppr (negate ix) <> char ':'
                                          <+> ppr pan) <> space)
niksaz's avatar
niksaz committed
750

751
  let
Simon Marlow's avatar
Simon Marlow committed
752
        dots | _:rs <- resumes, not (null rs) = text "... "
753 754
             | otherwise = empty

755 756
        rev_imports = reverse imports -- rightmost are the most recent

757
        myIdeclName d | Just m <- ideclAs d = unLoc m
758
                      | otherwise           = unLoc (ideclName d)
759

niksaz's avatar
niksaz committed
760 761 762 763 764 765
        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)
766

niksaz's avatar
niksaz committed
767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852