InteractiveUI.hs 128 KB
Newer Older
1 2
{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, TupleSections,
             RecordWildCards #-}
3 4 5
{-# OPTIONS -fno-cse #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly

6 7 8 9
-----------------------------------------------------------------------------
--
-- GHC Interactive User Interface
--
10
-- (c) The GHC Team 2005-2006
11 12
--
-----------------------------------------------------------------------------
13

14 15 16 17 18 19 20
module InteractiveUI (
        interactiveUI,
        GhciSettings(..),
        defaultGhciSettings,
        ghciCommands,
        ghciWelcomeMsg
    ) where
21

22 23
#include "HsVersions.h"

dterei's avatar
dterei committed
24 25 26
-- GHCi
import qualified GhciMonad ( args, runStmt )
import GhciMonad hiding ( args, runStmt )
27
import GhciTags
28
import Debugger
29

30
-- The GHC interface
dterei's avatar
dterei committed
31
import DynFlags
32
import ErrUtils
33
import GhcMonad ( modifySession )
dterei's avatar
dterei committed
34 35 36 37
import qualified GHC
import GHC ( LoadHowMuch(..), Target(..),  TargetId(..), InteractiveImport(..),
             TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,
             handleSourceError )
38
import HsImpExp
39
import HsSyn
40
import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,
41
                  setInteractivePrintName )
dterei's avatar
dterei committed
42
import Module
43
import Name
44
import Packages ( trusted, getPackageDetails, listVisibleModuleNames, pprFlag )
dterei's avatar
dterei committed
45
import PprTyThing
46 47
import PrelNames
import RdrName ( RdrName, getGRE_NameQualifier_maybes, getRdrName )
48
import SrcLoc
dterei's avatar
dterei committed
49 50 51 52
import qualified Lexer

import StringBuffer
import Outputable hiding ( printForUser, printForUserPartWay, bold )
53 54

-- Other random utilities
dterei's avatar
dterei committed
55
import BasicTypes hiding ( isTopLevel )
56
import Config
dterei's avatar
dterei committed
57 58 59
import Digraph
import Encoding
import FastString
60
import Linker
dterei's avatar
dterei committed
61
import Maybes ( orElse, expectJust )
dterei's avatar
dterei committed
62 63
import NameSet
import Panic hiding ( showException )
64
import Util
sof's avatar
sof committed
65

dterei's avatar
dterei committed
66
-- Haskell Libraries
67
import System.Console.Haskeline as Haskeline
68

dterei's avatar
dterei committed
69
import Control.Applicative hiding (empty)
70 71
import Control.DeepSeq (deepseq)
import Control.Monad as Monad
72
import Control.Monad.IO.Class
73
import Control.Monad.Trans.Class
74

dterei's avatar
dterei committed
75
import Data.Array
Simon Marlow's avatar
Simon Marlow committed
76
import qualified Data.ByteString.Char8 as BS
dterei's avatar
dterei committed
77
import Data.Char
Ian Lynagh's avatar
Ian Lynagh committed
78
import Data.Function
79
import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )
dterei's avatar
dterei committed
80 81
import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,
                   partition, sort, sortBy )
82
import Data.Maybe
dterei's avatar
dterei committed
83

84
import Exception hiding (catch)
dterei's avatar
dterei committed
85 86

import Foreign.C
87 88 89
#if __GLASGOW_HASKELL__ >= 709
import Foreign
#else
dterei's avatar
dterei committed
90
import Foreign.Safe
91
#endif
dterei's avatar
dterei committed
92 93

import System.Directory
94
import System.Environment
dterei's avatar
dterei committed
95
import System.Exit ( exitWith, ExitCode(..) )
dterei's avatar
dterei committed
96
import System.FilePath
ross's avatar
ross committed
97
import System.IO
98
import System.IO.Error
dterei's avatar
dterei committed
99
import System.IO.Unsafe ( unsafePerformIO )
100
import System.Process
Simon Marlow's avatar
Simon Marlow committed
101
import Text.Printf
102
import Text.Read ( readMaybe )
103

dterei's avatar
dterei committed
104 105 106 107 108 109 110
#ifndef mingw32_HOST_OS
import System.Posix hiding ( getEnv )
#else
import qualified System.Win32
#endif

import GHC.Exts ( unsafeCoerce# )
dterei's avatar
dterei committed
111 112
import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
import GHC.IO.Handle ( hFlushAll )
dterei's avatar
dterei committed
113
import GHC.TopHandler ( topHandler )
114

115 116
-----------------------------------------------------------------------------

117 118 119 120
data GhciSettings = GhciSettings {
        availableCommands :: [Command],
        shortHelpText     :: String,
        fullHelpText      :: String,
121 122
        defPrompt         :: String,
        defPrompt2        :: String
123 124 125 126 127 128 129 130
    }

defaultGhciSettings :: GhciSettings
defaultGhciSettings =
    GhciSettings {
        availableCommands = ghciCommands,
        shortHelpText     = defShortHelpText,
        fullHelpText      = defFullHelpText,
131 132
        defPrompt         = default_prompt,
        defPrompt2        = default_prompt2
133 134
    }

135 136 137
ghciWelcomeMsg :: String
ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
                 ": http://www.haskell.org/ghc/  :? for help"
138

Simon Marlow's avatar
Simon Marlow committed
139
cmdName :: Command -> String
140
cmdName (n,_,_) = n
141

Simon Marlow's avatar
Simon Marlow committed
142
GLOBAL_VAR(macros_ref, [], [Command])
Simon Marlow's avatar
Simon Marlow committed
143

144 145
ghciCommands :: [Command]
ghciCommands = [
146 147 148 149 150 151 152 153 154 155 156
  -- 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),
157
  ("complete",  keepGoing completeCmd,          noCompletion),
158
  ("cmd",       keepGoing cmdCmd,               completeExpression),
159 160
  ("ctags",     keepGoing createCTagsWithLineNumbersCmd, completeFilename),
  ("ctags!",    keepGoing createCTagsWithRegExesCmd, completeFilename),
161 162 163
  ("def",       keepGoing (defineMacro False),  completeExpression),
  ("def!",      keepGoing (defineMacro True),   completeExpression),
  ("delete",    keepGoing deleteCmd,            noCompletion),
164
  ("edit",      keepGoing' editFile,            completeFilename),
165 166 167 168 169
  ("etags",     keepGoing createETagsFileCmd,   completeFilename),
  ("force",     keepGoing forceCmd,             completeExpression),
  ("forward",   keepGoing forwardCmd,           noCompletion),
  ("help",      keepGoing help,                 noCompletion),
  ("history",   keepGoing historyCmd,           noCompletion),
170 171
  ("info",      keepGoing' (info False),        completeIdentifier),
  ("info!",     keepGoing' (info True),         completeIdentifier),
172
  ("issafe",    keepGoing' isSafeCmd,           completeModule),
173 174
  ("kind",      keepGoing' (kindOfType False),  completeIdentifier),
  ("kind!",     keepGoing' (kindOfType True),   completeIdentifier),
175 176
  ("load",      keepGoingPaths (loadModule_ False), completeHomeModuleOrFile),
  ("load!",     keepGoingPaths (loadModule_ True), completeHomeModuleOrFile),
177
  ("list",      keepGoing' listCmd,             noCompletion),
178
  ("module",    keepGoing moduleCmd,            completeSetModule),
179 180 181
  ("main",      keepGoing runMain,              completeFilename),
  ("print",     keepGoing printCmd,             completeExpression),
  ("quit",      quit,                           noCompletion),
182 183
  ("reload",    keepGoing' (reloadModule False), noCompletion),
  ("reload!",   keepGoing' (reloadModule True), noCompletion),
184
  ("run",       keepGoing runRun,               completeFilename),
vivian's avatar
vivian committed
185
  ("script",    keepGoing' scriptCmd,           completeFilename),
186
  ("set",       keepGoing setCmd,               completeSetOptions),
187
  ("seti",      keepGoing setiCmd,              completeSeti),
188
  ("show",      keepGoing showCmd,              completeShowOptions),
189
  ("showi",     keepGoing showiCmd,             completeShowiOptions),
190 191 192 193 194 195 196 197
  ("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),
  ("unset",     keepGoing unsetOptions,         completeSetOptions)
198 199
  ]

200

dterei's avatar
dterei committed
201
-- We initialize readline (in the interactiveUI function) to use
202 203 204 205
-- 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
206
--
207 208
-- NOTE: in order for us to override the default correctly, any custom entry
-- must be a SUBSET of word_break_chars.
209
word_break_chars :: String
210 211 212 213
word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
                       specials = "(),;[]`{}"
                       spaces = " \t\n"
                   in spaces ++ specials ++ symbols
214

215
flagWordBreakChars :: String
216 217 218
flagWordBreakChars = " \t\n"


219 220 221 222 223
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
224

225
keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
Ian Lynagh's avatar
Ian Lynagh committed
226 227
keepGoingPaths a str
 = do case toArgs str of
Ian Lynagh's avatar
Ian Lynagh committed
228
          Left err -> liftIO $ hPutStrLn stderr err
Ian Lynagh's avatar
Ian Lynagh committed
229 230
          Right args -> a args
      return False
sof's avatar
sof committed
231

232 233
defShortHelpText :: String
defShortHelpText = "use :? for help.\n"
234

235 236
defFullHelpText :: String
defFullHelpText =
dterei's avatar
dterei committed
237 238 239 240 241 242 243 244 245 246
  " 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" ++
247
  "   :complete <dom> [<rng>] <s> list completions for partial input string\n" ++
dterei's avatar
dterei committed
248 249
  "   :ctags[!] [<file>]          create tags file for Vi (default: \"tags\")\n" ++
  "                               (!: use regex instead of line number)\n" ++
250 251
  "   :def <cmd> <expr>           define command :<cmd> (later defined command has\n" ++
  "                               precedence, ::<cmd> is always a builtin command)\n" ++
dterei's avatar
dterei committed
252 253 254 255
  "   :edit <file>                edit file\n" ++
  "   :edit                       edit last module\n" ++
  "   :etags [<file>]             create tags file for Emacs (default: \"TAGS\")\n" ++
  "   :help, :?                   display this list of commands\n" ++
256 257
  "   :info[!] [<name> ...]       display information about the given names\n" ++
  "                               (!: do not filter instances)\n" ++
dterei's avatar
dterei committed
258
  "   :issafe [<mod>]             display safe haskell information of module <mod>\n" ++
259 260
  "   :kind[!] <type>             show the kind of <type>\n" ++
  "                               (!: also print the normalised type)\n" ++
261 262
  "   :load[!] [*]<module> ...    load module(s) and their dependents\n" ++
  "                               (!: defer type errors)\n" ++
dterei's avatar
dterei committed
263 264 265
  "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
  "   :quit                       exit GHCi\n" ++
266 267
  "   :reload[!]                  reload the current module set\n" ++
  "                               (!: defer type errors)\n" ++
dterei's avatar
dterei committed
268
  "   :run function [<arguments> ...] run the function with the given arguments\n" ++
269
  "   :script <filename>          run the script <filename>\n" ++
dterei's avatar
dterei committed
270 271 272 273 274 275 276
  "   :type <expr>                show the type of <expr>\n" ++
  "   :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" ++
277
  "   :back [<n>]                 go back in the history N steps (after :trace)\n" ++
dterei's avatar
dterei committed
278 279 280 281 282 283
  "   :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" ++
284
  "   :forward [<n>]              go forward in the history N step s(after :back)\n" ++
dterei's avatar
dterei committed
285 286
  "   :history [<n>]              after :trace, show the execution history\n" ++
  "   :list                       show the source code around current breakpoint\n" ++
287
  "   :list <identifier>          show the source code for <identifier>\n" ++
dterei's avatar
dterei committed
288
  "   :list [<module>] <line>     show the source code around line number <line>\n" ++
Austin Seipp's avatar
Austin Seipp committed
289 290
  "   :print [<name> ...]         show a value without forcing its computation\n" ++
  "   :sprint [<name> ...]        simplified version of :print\n" ++
dterei's avatar
dterei committed
291 292 293 294 295 296
  "   :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
297

dterei's avatar
dterei committed
298 299 300 301
  "\n" ++
  " -- Commands for changing settings:\n" ++
  "\n" ++
  "   :set <option> ...           set options\n" ++
302
  "   :seti <option> ...          set options for interactive evaluation only\n" ++
dterei's avatar
dterei committed
303 304 305
  "   :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" ++
306
  "   :set prompt2 <prompt>       set the continuation prompt used in GHCi\n" ++
dterei's avatar
dterei committed
307 308 309 310 311 312
  "   :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
313
  "    +m            allow multiline commands\n" ++
dterei's avatar
dterei committed
314 315 316 317
  "    +r            revert top-level expressions after each evaluation\n" ++
  "    +s            print timing/memory stats after each evaluation\n" ++
  "    +t            print type after evaluation\n" ++
  "    -<flags>      most GHC command line flags can also be set here\n" ++
318
  "                         (eg. -v2, -XFlexibleInstances, etc.)\n" ++
dterei's avatar
dterei committed
319 320 321 322 323 324 325 326
  "                    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" ++
327
  "   :show imports               show the current imports\n" ++
328
  "   :show linker                show current linker state\n" ++
dterei's avatar
dterei committed
329 330
  "   :show modules               show the currently loaded modules\n" ++
  "   :show packages              show the currently active package flags\n" ++
331
  "   :show paths                 show the currently active search paths\n" ++
332
  "   :show language              show the currently active language flags\n" ++
dterei's avatar
dterei committed
333 334
  "   :show <setting>             show value of <setting>, which is one of\n" ++
  "                                  [args, prog, prompt, editor, stop]\n" ++
335
  "   :showi language             show language flags for interactive evaluation\n" ++
dterei's avatar
dterei committed
336
  "\n"
337

Simon Marlow's avatar
Simon Marlow committed
338
findEditor :: IO String
Simon Marlow's avatar
Simon Marlow committed
339
findEditor = do
dterei's avatar
dterei committed
340
  getEnv "EDITOR"
341
    `catchIO` \_ -> do
342
#if mingw32_HOST_OS
Ian Lynagh's avatar
Ian Lynagh committed
343 344
        win <- System.Win32.getWindowsDirectory
        return (win </> "notepad.exe")
Simon Marlow's avatar
Simon Marlow committed
345
#else
Ian Lynagh's avatar
Ian Lynagh committed
346
        return ""
Simon Marlow's avatar
Simon Marlow committed
347 348
#endif

Simon Marlow's avatar
Simon Marlow committed
349 350
foreign import ccall unsafe "rts_isProfiled" isProfiled :: IO CInt

351
default_progname, default_prompt, default_prompt2, default_stop :: String
boris's avatar
boris committed
352 353
default_progname = "<interactive>"
default_prompt = "%s> "
354
default_prompt2 = "%s| "
boris's avatar
boris committed
355 356
default_stop = ""

Simon Marlow's avatar
Simon Marlow committed
357 358 359
default_args :: [String]
default_args = []

360
interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]
361
              -> Ghc ()
362
interactiveUI config srcs maybe_exprs = do
363 364 365
   -- although GHCi compiles with -prof, it is not usable: the byte-code
   -- compiler and interpreter don't work with profiling.  So we check for
   -- this up front and emit a helpful error message (#2197)
Simon Marlow's avatar
Simon Marlow committed
366
   i <- liftIO $ isProfiled
dterei's avatar
dterei committed
367
   when (i /= 0) $
368
     throwGhcException (InstallationError "GHCi cannot be used when compiled with -prof")
369

370 371 372 373 374 375 376 377
   -- 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.
378 379 380
   _ <- liftIO $ newStablePtr stdin
   _ <- liftIO $ newStablePtr stdout
   _ <- liftIO $ newStablePtr stderr
381

Ian Lynagh's avatar
Ian Lynagh committed
382
    -- Initialise buffering for the *interpreted* I/O system
383
   initInterpBuffering
384

385
   -- The initial set of DynFlags used for interactive evaluation is the same
386 387
   -- as the global DynFlags, plus -XExtendedDefaultRules and
   -- -XNoMonomorphismRestriction.
388
   dflags <- getDynFlags
389 390 391 392
   let dflags' = (`xopt_set` Opt_ExtendedDefaultRules)
               . (`xopt_unset` Opt_MonomorphismRestriction)
               $ dflags
   GHC.setInteractiveDynFlags dflags'
393

394 395 396 397 398
   lastErrLocationsRef <- liftIO $ newIORef []
   progDynFlags <- GHC.getProgramDynFlags
   _ <- GHC.setProgramDynFlags $
      progDynFlags { log_action = ghciLogAction lastErrLocationsRef }

399
   liftIO $ when (isNothing maybe_exprs) $ do
Ian Lynagh's avatar
Ian Lynagh committed
400 401 402 403 404 405 406 407 408 409
        -- Only for GHCi (not runghc and ghc -e):

        -- Turn buffering off for the compiled program's stdout/stderr
        turnOffBuffering
        -- Turn buffering off for GHCi's stdout
        hFlush stdout
        hSetBuffering stdout NoBuffering
        -- We don't want the cmd line to buffer any input that might be
        -- intended for the program, so unbuffer stdin.
        hSetBuffering stdin NoBuffering
parcs's avatar
parcs committed
410
        hSetBuffering stderr NoBuffering
411
#if defined(mingw32_HOST_OS)
412 413 414 415 416
        -- 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.
        hSetEncoding stdin utf8
#endif
Ian Lynagh's avatar
Ian Lynagh committed
417

418
   default_editor <- liftIO $ findEditor
Ian Lynagh's avatar
Ian Lynagh committed
419
   startGHCi (runGHCi srcs maybe_exprs)
420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439
        GHCiState{ progname           = default_progname,
                   GhciMonad.args     = default_args,
                   prompt             = defPrompt config,
                   prompt2            = defPrompt2 config,
                   stop               = default_stop,
                   editor             = default_editor,
                   options            = [],
                   line_number        = 1,
                   break_ctr          = 0,
                   breaks             = [],
                   tickarrays         = emptyModuleEnv,
                   ghci_commands      = availableCommands config,
                   last_command       = Nothing,
                   cmdqueue           = [],
                   remembered_ctx     = [],
                   transient_ctx      = [],
                   ghc_e              = isJust maybe_exprs,
                   short_help         = shortHelpText config,
                   long_help          = fullHelpText config,
                   lastErrorLocations = lastErrLocationsRef
mnislaih's avatar
mnislaih committed
440
                 }
441

442 443
   return ()

444 445 446 447 448 449 450 451 452 453 454 455 456 457 458
resetLastErrorLocations :: GHCi ()
resetLastErrorLocations = do
    st <- getGHCiState
    liftIO $ writeIORef (lastErrorLocations st) []

ghciLogAction :: IORef [(FastString, Int)] ->  LogAction
ghciLogAction lastErrLocations dflags severity srcSpan style msg = do
    defaultLogAction dflags severity srcSpan style msg
    case severity of
        SevError -> case srcSpan of
            RealSrcSpan rsp -> modifyIORef lastErrLocations
                (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])
            _ -> return ()
        _ -> return ()

459 460
withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
withGhcAppData right left = do
461
    either_dir <- tryIO (getAppUserDataDirectory "ghc")
462 463 464 465 466
    case either_dir of
        Right dir ->
            do createDirectoryIfMissing False dir `catchIO` \_ -> return ()
               right dir
        _ -> left
467

Ian Lynagh's avatar
Ian Lynagh committed
468 469
runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
runGHCi paths maybe_exprs = do
470
  dflags <- getDynFlags
471
  let
472
   ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags
473

474 475
   current_dir = return (Just ".ghci")

Ian Lynagh's avatar
Ian Lynagh committed
476
   app_user_dir = liftIO $ withGhcAppData
477 478
                    (\dir -> return (Just (dir </> "ghci.conf")))
                    (return Nothing)
479 480

   home_dir = do
481
    either_dir <- liftIO $ tryIO (getEnv "HOME")
482 483 484 485
    case either_dir of
      Right home -> return (Just (home </> ".ghci"))
      _ -> return Nothing

486 487 488 489
   canonicalizePath' :: FilePath -> IO (Maybe FilePath)
   canonicalizePath' fp = liftM Just (canonicalizePath fp)
                `catchIO` \_ -> return Nothing

490 491
   sourceConfigFile :: FilePath -> GHCi ()
   sourceConfigFile file = do
Ian Lynagh's avatar
Ian Lynagh committed
492
     exists <- liftIO $ doesFileExist file
493
     when exists $ do
494 495 496 497 498 499 500 501 502 503 504
       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 ())

505 506
  --

507
  setGHCContextFromGHCiState
Ian Lynagh's avatar
Ian Lynagh committed
508

509 510
  dot_cfgs <- if ignore_dot_ghci then return [] else do
    dot_files <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]
511
    liftIO $ filterM checkFileAndDirPerms dot_files
512 513 514 515 516 517 518
  let arg_cfgs = reverse $ ghciScripts dflags
    -- -ghci-script are collected in reverse order
  mcfgs <- liftIO $ mapM canonicalizePath' $ dot_cfgs ++ arg_cfgs
    -- We don't require that a script explicitly added by -ghci-script
    -- is owned by the current user. (#6017)
  mapM_ sourceConfigFile $ nub $ catMaybes mcfgs
    -- nub, because we don't want to read .ghci twice if the CWD is $HOME.
519

520
  -- Perform a :load for files given on the GHCi command line
521 522 523
  -- 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
524
     ok <- ghciHandle (\e -> do showException e; return Failed) $
525
                -- TODO: this is a hack.
526 527
                runInputTWithPrefs defaultPrefs defaultSettings $
                    loadModule paths
Ian Lynagh's avatar
Ian Lynagh committed
528
     when (isJust maybe_exprs && failed ok) $
Ian Lynagh's avatar
Ian Lynagh committed
529
        liftIO (exitWith (ExitFailure 1))
530

531 532
  installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)

533 534
  -- 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
535
  is_tty <- liftIO (hIsTerminalDevice stdin)
536 537
  let show_prompt = verbosity dflags > 0 || is_tty

538
  -- reset line number
539
  modifyGHCiState $ \st -> st{line_number=1}
540

Ian Lynagh's avatar
Ian Lynagh committed
541
  case maybe_exprs of
Ian Lynagh's avatar
Ian Lynagh committed
542
        Nothing ->
sof's avatar
sof committed
543
          do
Ian Lynagh's avatar
Ian Lynagh committed
544
            -- enter the interactive loop
545
            runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
Ian Lynagh's avatar
Ian Lynagh committed
546
        Just exprs -> do
Ian Lynagh's avatar
Ian Lynagh committed
547
            -- just evaluate the expression we were given
Ian Lynagh's avatar
Ian Lynagh committed
548
            enqueueCommands exprs
dterei's avatar
dterei committed
549 550 551 552 553 554 555 556
            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
557
                                   -- this used to be topHandlerFastExit, see #2228
558
            runInputTWithPrefs defaultPrefs defaultSettings $ do
559
                -- make `ghc -e` exit nonzero on invalid input, see Trac #7962
560 561 562 563
                _ <- runCommands' hdle
                     (Just $ hdle (toException $ ExitFailure 1) >> return ())
                     (return Nothing)
                return ()
564 565

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

568 569
runGHCiInput :: InputT GHCi a -> GHCi a
runGHCiInput f = do
Ian Lynagh's avatar
Ian Lynagh committed
570
    dflags <- getDynFlags
ian@well-typed.com's avatar
ian@well-typed.com committed
571
    histFile <- if gopt Opt_GhciHistory dflags
Ian Lynagh's avatar
Ian Lynagh committed
572 573 574
                then liftIO $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
                                             (return Nothing)
                else return Nothing
dterei's avatar
dterei committed
575 576 577
    runInputT
        (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})
        f
578

579
-- | How to get the next input line from the user
580 581 582
nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
nextInputLine show_prompt is_tty
  | is_tty = do
dterei's avatar
dterei committed
583 584
    prmpt <- if show_prompt then lift mkPrompt else return ""
    r <- getInputLine prmpt
585 586
    incrementLineNo
    return r
587 588 589
  | otherwise = do
    when show_prompt $ lift mkPrompt >>= liftIO . putStr
    fileLoop stdin
590

591
-- NOTE: We only read .ghci files if they are owned by the current user,
592 593 594
-- 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.
595

rrt's avatar
rrt committed
596 597 598 599
-- 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.
600

601 602
checkFileAndDirPerms :: FilePath -> IO Bool
checkFileAndDirPerms file = do
603
  file_ok <- checkPerms file
thomie's avatar
thomie committed
604 605 606 607
  -- 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.
608
  if file_ok then checkPerms (getDirectory file) else return False
609 610 611 612 613 614
  where
  getDirectory f = case takeDirectory f of
    "" -> "."
    d -> d

checkPerms :: FilePath -> IO Bool
615
#ifdef mingw32_HOST_OS
dterei's avatar
dterei committed
616
checkPerms _ = return True
sof's avatar
sof committed
617
#else
618
checkPerms file =
619
  handleIO (\_ -> return False) $ do
620
    st <- getFileStatus file
dterei's avatar
dterei committed
621
    me <- getRealUserID
622 623 624 625 626
    let mode = System.Posix.fileMode st
        ok = (fileOwner st == me || fileOwner st == 0) &&
             groupWriteMode /= mode `intersectFileModes` groupWriteMode &&
             otherWriteMode /= mode `intersectFileModes` otherWriteMode
    unless ok $
627
      -- #8248: Improving warning to include a possible fix.
628
      putStrLn $ "*** WARNING: " ++ file ++
629
                 " is writable by someone else, IGNORING!" ++
630
                 "\nSuggested fix: execute 'chmod 644 " ++ file ++ "'"
631
    return ok
sof's avatar
sof committed
632
#endif
633

634 635
incrementLineNo :: InputT GHCi ()
incrementLineNo = do
vivian's avatar
vivian committed
636 637 638 639 640
   st <- lift $ getGHCiState
   let ln = 1+(line_number st)
   lift $ setGHCiState st{line_number=ln}

fileLoop :: Handle -> InputT GHCi (Maybe String)
641
fileLoop hdl = do
642
   l <- liftIO $ tryIO $ hGetLine hdl
643
   case l of
644
        Left e | isEOFError e              -> return Nothing
645 646 647 648 649
               | -- 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
650
               | InvalidArgument <- etype  -> return Nothing
651
               | otherwise                 -> liftIO $ ioError e
652 653 654 655 656
                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
657
        Right l' -> do
658
           incrementLineNo
dterei's avatar
dterei committed
659
           return (Just l')
660

Simon Marlow's avatar
Simon Marlow committed
661
mkPrompt :: GHCi String
662
mkPrompt = do
663
  st <- getGHCiState
664
  imports <- GHC.getContext
665
  resumes <- GHC.getResumeContext
666 667 668 669

  context_bit <-
        case resumes of
            [] -> return empty
Simon Marlow's avatar
Simon Marlow committed
670
            r:_ -> do
671 672 673 674 675
                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
676 677 678
                        pan <- GHC.getHistorySpan hist
                        return (brackets (ppr (negate ix) <> char ':'
                                          <+> ppr pan) <> space)
679
  let
Simon Marlow's avatar
Simon Marlow committed
680
        dots | _:rs <- resumes, not (null rs) = text "... "
681 682
             | otherwise = empty

683 684
        rev_imports = reverse imports -- rightmost are the most recent
        modules_bit =
685
             hsep [ char '*' <> ppr m | IIModule m <- rev_imports ] <+>
686 687 688 689 690
             hsep (map ppr [ myIdeclName d | IIDecl d <- rev_imports ])

         --  use the 'as' name if there is one
        myIdeclName d | Just m <- ideclAs d = m
                      | otherwise           = unLoc (ideclName d)
691

692 693
        deflt_prompt = dots <> context_bit <> modules_bit

694
        f ('%':'l':xs) = ppr (1 + line_number st) <> f xs
695 696 697 698
        f ('%':'s':xs) = deflt_prompt <> f xs
        f ('%':'%':xs) = char '%' <> f xs
        f (x:xs) = char x <> f xs
        f [] = empty
dterei's avatar
dterei committed
699

Ian Lynagh's avatar
Ian Lynagh committed
700 701
  dflags <- getDynFlags
  return (showSDoc dflags (f (prompt st)))
702

703

704 705 706 707 708 709 710 711
queryQueue :: GHCi (Maybe String)
queryQueue = do
  st <- getGHCiState
  case cmdqueue st of
    []   -> return Nothing
    c:cs -> do setGHCiState st{ cmdqueue = cs }
               return (Just c)

712 713 714 715 716 717
-- Reconfigurable pretty-printing Ticket #5461
installInteractivePrint :: Maybe String -> Bool -> GHCi ()
installInteractivePrint Nothing _  = return ()
installInteractivePrint (Just ipFun) exprmode = do
  ok <- trySuccess $ do
                (name:_) <- GHC.parseName ipFun
718
                modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name
719
                                      in he{hsc_IC = new_ic})
720 721 722 723
                return Succeeded

  when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1))

724
-- | The main read-eval-print loop
725
runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
726
runCommands gCmd = runCommands' handler Nothing gCmd >> return ()
727

dterei's avatar
dterei committed
728
runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler
729
             -> Maybe (GHCi ()) -- ^ Source error handler
730 731 732 733 734 735
             -> InputT GHCi (Maybe String)
             -> InputT GHCi (Maybe Bool)
         -- We want to return () here, but have to return (Maybe Bool)
         -- because gmask is not polymorphic enough: we want to use
         -- unmask at two different types.
runCommands' eh sourceErrorHandler gCmd = gmask $ \unmask -> do
736
    b <- ghandle (\e -> case fromException e of
vivian's avatar
vivian committed
737
                          Just UserInterrupt -> return $ Just False
738
                          _ -> case fromException e of
dterei's avatar
dterei committed
739 740
                                 Just ghce ->
                                   do liftIO (print (ghce :: GhcException))
vivian's avatar
vivian committed
741
                                      return Nothing
742 743
                                 _other ->
                                   liftIO (Exception.throwIO e))
744
            (unmask $ runOneCommand eh gCmd)
vivian's avatar
vivian committed
745
    case b of
746
      Nothing -> return Nothing
747
      Just success -> do
748
        when (not success) $ maybe (return ()) lift sourceErrorHandler
749
        unmask $ runCommands' eh sourceErrorHandler gCmd
750

751 752 753 754 755
-- | Evaluate a single line of user input (either :<command> or Haskell code).
-- A result of Nothing means there was no more input to process.
-- Otherwise the result is Just b where b is True if the command succeeded;
-- this is relevant only to ghc -e, which will exit with status 1
-- if the commmand was unsuccessful. GHCi will continue in either case.
756
runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
vivian's avatar
vivian committed
757
            -> InputT GHCi (Maybe Bool)
dterei's avatar
dterei committed
758
runOneCommand eh gCmd = do
759 760
  -- run a previously queued command if there is one, otherwise get new
  -- input from user
dterei's avatar
dterei committed
761 762 763
  mb_cmd0 <- noSpace (lift queryQueue)
  mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0
  case mb_cmd1 of
vivian's avatar
vivian committed
764 765
    Nothing -> return Nothing
    Just c  -> ghciHandle (\e -> lift $ eh e >>= return . Just) $
766
             handleSourceError printErrorAndFail
767
               (doCommand c)
vivian's avatar
vivian committed
768 769
               -- source error's are handled by runStmt
               -- is the handler necessary here?
770
  where
771
    printErrorAndFail err = do
772
        GHC.printException err
773
        return $ Just False     -- Exit ghc -e, but not GHCi
774

775
    noSpace q = q >>= maybe (return Nothing)
dterei's avatar
dterei committed
776 777 778
                            (\c -> case removeSpaces c of
                                     ""   -> noSpace q
                                     ":{" -> multiLineCmd q
779
                                     _    -> return (Just c) )
780
    multiLineCmd q = do
781
      st <- lift getGHCiState
782
      let p = prompt st
783
      lift $ setGHCiState st{ prompt = prompt2 st }
784
      mb_cmd <- collectCommand q "" `GHC.gfinally` lift (getGHCiState >>= \st' -> setGHCiState st' { prompt = p })
785
      return mb_cmd
dterei's avatar
dterei committed
786
    -- we can't use removeSpaces for the sublines here, so
787
    -- multiline commands are somewhat more brittle against
dterei's avatar
dterei committed
788 789
    -- fileformat errors (such as \r in dos input on unix),
    -- we get rid of any extra spaces for the ":}" test;
790
    -- we also avoid silent failure if ":}" is not found;
dterei's avatar
dterei committed
791
    -- and since there is no (?) valid occurrence of \r (as
792 793
    -- opposed to its String representation, "\r") inside a
    -- ghci command, we replace any such with ' ' (argh:-(
dterei's avatar
dterei committed
794
    collectCommand q c = q >>=
795
      maybe (liftIO (ioError collectError))
dterei's avatar
dterei committed
796
            (\l->if removeSpaces l == ":}"
797
                 then return (Just c)
798
                 else collectCommand q (c ++ "\n" ++ map normSpace l))
799
      where normSpace '\r' = ' '
dterei's avatar
dterei committed
800
            normSpace   x  = x
dterei's avatar
dterei committed
801
    -- SDM (2007-11-07): is userError the one to use here?
802
    collectError = userError "unterminated multiline command :{ .. :}"
803 804 805 806 807

    -- | Handle a line of input
    doCommand :: String -> InputT GHCi (Maybe Bool)

    -- command
808
    doCommand stmt | (':' : cmd) <- removeSpaces stmt = do
vivian's avatar
vivian committed
809 810 811 812
      result <- specialCommand cmd
      case result of
        True -> return Nothing
        _    -> return $ Just True
813 814 815

    -- haskell
    doCommand stmt = do
816 817
      -- if 'stmt' was entered via ':{' it will contain '\n's
      let stmt_nl_cnt = length [ () | '\n' <- stmt ]
vivian's avatar
vivian committed
818
      ml <- lift $ isOptionSet Multiline
819
      if ml && stmt_nl_cnt == 0 -- don't trigger automatic multi-line mode for ':{'-multiline input
dterei's avatar
dterei committed