InteractiveUI.hs 128 KB
Newer Older
1
{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, TupleSections,
2
             RecordWildCards, MultiWayIf #-}
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
65
import qualified GHC.LanguageExtensions as LangExt
sof's avatar
sof committed
66

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

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

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

85
import Exception hiding (catch)
86
import Foreign
dterei's avatar
dterei committed
87 88

import System.Directory
89
import System.Environment
dterei's avatar
dterei committed
90
import System.Exit ( exitWith, ExitCode(..) )
dterei's avatar
dterei committed
91
import System.FilePath
ross's avatar
ross committed
92
import System.IO
93
import System.IO.Error
dterei's avatar
dterei committed
94
import System.IO.Unsafe ( unsafePerformIO )
95
import System.Process
Simon Marlow's avatar
Simon Marlow committed
96
import Text.Printf
97
import Text.Read ( readMaybe )
98

dterei's avatar
dterei committed
99 100 101 102 103 104 105
#ifndef mingw32_HOST_OS
import System.Posix hiding ( getEnv )
#else
import qualified System.Win32
#endif

import GHC.Exts ( unsafeCoerce# )
dterei's avatar
dterei committed
106 107
import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
import GHC.IO.Handle ( hFlushAll )
dterei's avatar
dterei committed
108
import GHC.TopHandler ( topHandler )
109

110 111
-----------------------------------------------------------------------------

112 113 114
data GhciSettings = GhciSettings {
        availableCommands :: [Command],
        shortHelpText     :: String,
115 116 117
        fullHelpText      :: String,
        defPrompt         :: String,
        defPrompt2        :: String
118 119 120 121 122 123 124
    }

defaultGhciSettings :: GhciSettings
defaultGhciSettings =
    GhciSettings {
        availableCommands = ghciCommands,
        shortHelpText     = defShortHelpText,
125 126
        defPrompt         = default_prompt,
        defPrompt2        = default_prompt2,
127
        fullHelpText      = defFullHelpText
128 129
    }

130 131 132
ghciWelcomeMsg :: String
ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
                 ": http://www.haskell.org/ghc/  :? for help"
133

Simon Marlow's avatar
Simon Marlow committed
134
GLOBAL_VAR(macros_ref, [], [Command])
Simon Marlow's avatar
Simon Marlow committed
135

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

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

219
flagWordBreakChars :: String
220 221 222
flagWordBreakChars = " \t\n"


223 224 225 226 227
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
228

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

236 237
defShortHelpText :: String
defShortHelpText = "use :? for help.\n"
238

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

dterei's avatar
dterei committed
302 303 304 305
  "\n" ++
  " -- Commands for changing settings:\n" ++
  "\n" ++
  "   :set <option> ...           set options\n" ++
306
  "   :seti <option> ...          set options for interactive evaluation only\n" ++
dterei's avatar
dterei committed
307 308 309
  "   :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" ++
310
  "   :set prompt2 <prompt>       set the continuation prompt used in GHCi\n" ++
dterei's avatar
dterei committed
311 312 313 314 315 316
  "   :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
317
  "    +m            allow multiline commands\n" ++
dterei's avatar
dterei committed
318 319 320 321
  "    +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" ++
322
  "                         (eg. -v2, -XFlexibleInstances, etc.)\n" ++
dterei's avatar
dterei committed
323 324 325 326 327 328 329 330
  "                    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" ++
331
  "   :show imports               show the current imports\n" ++
332
  "   :show linker                show current linker state\n" ++
dterei's avatar
dterei committed
333 334
  "   :show modules               show the currently loaded modules\n" ++
  "   :show packages              show the currently active package flags\n" ++
335
  "   :show paths                 show the currently active search paths\n" ++
336
  "   :show language              show the currently active language flags\n" ++
dterei's avatar
dterei committed
337 338
  "   :show <setting>             show value of <setting>, which is one of\n" ++
  "                                  [args, prog, prompt, editor, stop]\n" ++
339
  "   :showi language             show language flags for interactive evaluation\n" ++
dterei's avatar
dterei committed
340
  "\n"
341

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

353
default_progname, default_prompt, default_prompt2, default_stop :: String
Boris Lykah's avatar
Boris Lykah committed
354
default_progname = "<interactive>"
355 356
default_prompt = "%s> "
default_prompt2 = "%s| "
Boris Lykah's avatar
Boris Lykah committed
357 358
default_stop = ""

Simon Marlow's avatar
Simon Marlow committed
359 360 361
default_args :: [String]
default_args = []

362
interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]
363
              -> Ghc ()
364
interactiveUI config srcs maybe_exprs = do
365 366 367 368 369 370 371 372
   -- 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.
373 374 375
   _ <- liftIO $ newStablePtr stdin
   _ <- liftIO $ newStablePtr stdout
   _ <- liftIO $ newStablePtr stderr
376

Ian Lynagh's avatar
Ian Lynagh committed
377
    -- Initialise buffering for the *interpreted* I/O system
378
   initInterpBuffering
379

380
   -- The initial set of DynFlags used for interactive evaluation is the same
381 382
   -- as the global DynFlags, plus -XExtendedDefaultRules and
   -- -XNoMonomorphismRestriction.
383
   dflags <- getDynFlags
384 385
   let dflags' = (`xopt_set` LangExt.ExtendedDefaultRules)
               . (`xopt_unset` LangExt.MonomorphismRestriction)
386 387
               $ dflags
   GHC.setInteractiveDynFlags dflags'
388

389 390 391 392 393
   lastErrLocationsRef <- liftIO $ newIORef []
   progDynFlags <- GHC.getProgramDynFlags
   _ <- GHC.setProgramDynFlags $
      progDynFlags { log_action = ghciLogAction lastErrLocationsRef }

394
   liftIO $ when (isNothing maybe_exprs) $ do
Ian Lynagh's avatar
Ian Lynagh committed
395 396 397 398 399 400 401 402 403 404
        -- 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
405
        hSetBuffering stderr NoBuffering
406
#if defined(mingw32_HOST_OS)
407 408 409 410 411
        -- 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
412

413
   default_editor <- liftIO $ findEditor
Ian Lynagh's avatar
Ian Lynagh committed
414
   startGHCi (runGHCi srcs maybe_exprs)
415 416
        GHCiState{ progname           = default_progname,
                   GhciMonad.args     = default_args,
417 418
                   prompt             = defPrompt config,
                   prompt2            = defPrompt2 config,
419 420 421
                   stop               = default_stop,
                   editor             = default_editor,
                   options            = [],
422 423 424 425
                   -- 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,
426 427 428 429 430 431 432 433 434 435 436 437
                   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
438
                 }
439

440 441
   return ()

442 443 444 445 446 447 448 449 450 451 452 453 454 455 456
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 ()

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

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

472 473
   current_dir = return (Just ".ghci")

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

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

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

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

503 504
  --

505
  setGHCContextFromGHCiState
Ian Lynagh's avatar
Ian Lynagh committed
506

507 508
  dot_cfgs <- if ignore_dot_ghci then return [] else do
    dot_files <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]
509
    liftIO $ filterM checkFileAndDirPerms dot_files
510 511 512 513 514 515 516
  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.
517

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

529 530
  installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)

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

536
  -- reset line number
537
  modifyGHCiState $ \st -> st{line_number=0}
538

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

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

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

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

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

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

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

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

632
incrementLineNo :: InputT GHCi ()
633 634 635
incrementLineNo = modifyGHCiState incLineNo
  where
    incLineNo st = st { line_number = line_number st + 1 }
vivian's avatar
vivian committed
636 637

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

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

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

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

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

689
        deflt_prompt = dots <> context_bit <> modules_bit
690

691
        f ('%':'l':xs) = ppr (1 + line_number st) <> f xs
692 693 694 695
        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
696

697 698
  dflags <- getDynFlags
  return (showSDoc dflags (f (prompt st)))
699

700

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

709 710 711 712 713 714
-- 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
715
                modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name
716
                                      in he{hsc_IC = new_ic})
717 718 719 720
                return Succeeded

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

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

dterei's avatar
dterei committed
725
runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler
726
             -> Maybe (GHCi ()) -- ^ Source error handler
727 728 729 730 731 732
             -> 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
733
    b <- ghandle (\e -> case fromException e of
vivian's avatar
vivian committed
734
                          Just UserInterrupt -> return $ Just False
735
                          _ -> case fromException e of
dterei's avatar
dterei committed
736 737
                                 Just ghce ->
                                   do liftIO (print (ghce :: GhcException))
vivian's avatar
vivian committed
738
                                      return Nothing
739 740
                                 _other ->
                                   liftIO (Exception.throwIO e))
741
            (unmask $ runOneCommand eh gCmd)
vivian's avatar
vivian committed
742
    case b of
743
      Nothing -> return Nothing
744
      Just success -> do
745
        unless success $ maybe (return ()) lift sourceErrorHandler
746
        unmask $ runCommands' eh sourceErrorHandler gCmd
747

748 749 750 751 752
-- | 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.
753
runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
vivian's avatar
vivian committed
754
            -> InputT GHCi (Maybe Bool)
dterei's avatar
dterei committed
755
runOneCommand eh gCmd = do
756 757
  -- run a previously queued command if there is one, otherwise get new
  -- input from user
dterei's avatar
dterei committed
758 759 760
  mb_cmd0 <- noSpace (lift queryQueue)
  mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0
  case mb_cmd1 of
vivian's avatar
vivian committed
761 762
    Nothing -> return Nothing
    Just c  -> ghciHandle (\e -> lift $ eh e >>= return . Just) $
763
             handleSourceError printErrorAndFail
764
               (doCommand c)
vivian's avatar
vivian committed
765 766
               -- source error's are handled by runStmt
               -- is the handler necessary here?
767
  where
768
    printErrorAndFail err = do
769
        GHC.printException err
770
        return $ Just False     -- Exit ghc -e, but not GHCi
771

772
    noSpace q = q >>= maybe (return Nothing)
dterei's avatar
dterei committed
773 774 775
                            (\c -> case removeSpaces c of
                                     ""   -> noSpace q
                                     ":{" -> multiLineCmd q
776
                                     _    -> return (Just c) )
777
    multiLineCmd q = do
778
      st <- getGHCiState
779
      let p = prompt st
780 781 782
      setGHCiState st{ prompt = prompt2 st }
      mb_cmd <- collectCommand q "" `GHC.gfinally`
                modifyGHCiState (\st' -> st' { prompt = p })
783
      return mb_cmd
dterei's avatar
dterei committed
784
    -- we can't use removeSpaces for the sublines here, so
785
    -- multiline commands are somewhat more brittle against
dterei's avatar