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

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

dterei's avatar
dterei committed
84
-- Haskell Libraries
85
import System.Console.Haskeline as Haskeline
86

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

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

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

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

niksaz's avatar
niksaz committed
127 128
import Unsafe.Coerce

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

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

139 140
import GHCi.Leak

141 142
-----------------------------------------------------------------------------

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

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

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

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

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

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

257
flagWordBreakChars :: String
258 259 260
flagWordBreakChars = " \t\n"


261 262 263 264 265
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
266

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

274 275
defShortHelpText :: String
defShortHelpText = "use :? for help.\n"
276

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

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

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

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

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

Simon Marlow's avatar
Simon Marlow committed
408 409 410
default_args :: [String]
default_args = []

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

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

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

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

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

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

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

498 499
   return ()

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

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

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

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

530 531
   current_dir = return (Just ".ghci")

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

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

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

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

566 567
  --

568
  setGHCContextFromGHCiState
Ian Lynagh's avatar
Ian Lynagh committed
569

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

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

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

593 594
  installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)

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

600
  -- reset line number
601
  modifyGHCiState $ \st -> st{line_number=0}
602

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

766 767
        rev_imports = reverse imports -- rightmost are the most recent

768
        myIdeclName d | Just m <- ideclAs d = unLoc m
769
                      | otherwise           = unLoc (ideclName d)
770

niksaz's avatar
niksaz committed
771 772 773 774 775 776
        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)
777

niksaz's avatar
niksaz committed
778 779 780 781 782 783 784