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

import StringBuffer
import Outputable hiding ( printForUser, printForUserPartWay, bold )
66 67

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

dterei's avatar
dterei committed
80
-- Haskell Libraries
81
import System.Console.Haskeline as Haskeline
82

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

dterei's avatar
dterei committed
90
import Data.Array
Simon Marlow's avatar
Simon Marlow committed
91
import qualified Data.ByteString.Char8 as BS
dterei's avatar
dterei committed
92
import Data.Char
Ian Lynagh's avatar
Ian Lynagh committed
93
import Data.Function
94
import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )
dterei's avatar
dterei committed
95 96
import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,
                   partition, sort, sortBy )
97
import Data.Maybe
98
import qualified Data.Map as M
dterei's avatar
dterei committed
99

100
import Exception hiding (catch)
101
import Foreign
102
import GHC.Stack hiding (SrcLoc(..))
dterei's avatar
dterei committed
103 104

import System.Directory
105
import System.Environment
dterei's avatar
dterei committed
106
import System.Exit ( exitWith, ExitCode(..) )
dterei's avatar
dterei committed
107
import System.FilePath
ross's avatar
ross committed
108
import System.IO
109
import System.IO.Error
dterei's avatar
dterei committed
110
import System.IO.Unsafe ( unsafePerformIO )
111
import System.Process
Simon Marlow's avatar
Simon Marlow committed
112
import Text.Printf
113
import Text.Read ( readMaybe )
Geraldus's avatar
Geraldus committed
114
import Text.Read.Lex (isSymbolChar)
115

dterei's avatar
dterei committed
116 117 118 119 120 121
#ifndef mingw32_HOST_OS
import System.Posix hiding ( getEnv )
#else
import qualified System.Win32
#endif

dterei's avatar
dterei committed
122 123
import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
import GHC.IO.Handle ( hFlushAll )
dterei's avatar
dterei committed
124
import GHC.TopHandler ( topHandler )
125

126 127
-----------------------------------------------------------------------------

128 129 130
data GhciSettings = GhciSettings {
        availableCommands :: [Command],
        shortHelpText     :: String,
131 132 133
        fullHelpText      :: String,
        defPrompt         :: String,
        defPrompt2        :: String
134 135 136 137 138 139 140
    }

defaultGhciSettings :: GhciSettings
defaultGhciSettings =
    GhciSettings {
        availableCommands = ghciCommands,
        shortHelpText     = defShortHelpText,
141 142
        defPrompt         = default_prompt,
        defPrompt2        = default_prompt2,
143
        fullHelpText      = defFullHelpText
144 145
    }

146 147 148
ghciWelcomeMsg :: String
ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
                 ": http://www.haskell.org/ghc/  :? for help"
149

Simon Marlow's avatar
Simon Marlow committed
150
GLOBAL_VAR(macros_ref, [], [Command])
Simon Marlow's avatar
Simon Marlow committed
151

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

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

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

242
flagWordBreakChars :: String
243 244 245
flagWordBreakChars = " \t\n"


246 247 248 249 250
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
251

252
keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
Ian Lynagh's avatar
Ian Lynagh committed
253 254
keepGoingPaths a str
 = do case toArgs str of
Ian Lynagh's avatar
Ian Lynagh committed
255
          Left err -> liftIO $ hPutStrLn stderr err
Ian Lynagh's avatar
Ian Lynagh committed
256 257
          Right args -> a args
      return False
sof's avatar
sof committed
258

259 260
defShortHelpText :: String
defShortHelpText = "use :? for help.\n"
261

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

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

Simon Marlow's avatar
Simon Marlow committed
366
findEditor :: IO String
Simon Marlow's avatar
Simon Marlow committed
367
findEditor = do
dterei's avatar
dterei committed
368
  getEnv "EDITOR"
369
    `catchIO` \_ -> do
370
#if mingw32_HOST_OS
Ian Lynagh's avatar
Ian Lynagh committed
371 372
        win <- System.Win32.getWindowsDirectory
        return (win </> "notepad.exe")
Simon Marlow's avatar
Simon Marlow committed
373
#else
Ian Lynagh's avatar
Ian Lynagh committed
374
        return ""
Simon Marlow's avatar
Simon Marlow committed
375 376
#endif

377
default_progname, default_prompt, default_prompt2, default_stop :: String
Boris Lykah's avatar
Boris Lykah committed
378
default_progname = "<interactive>"
379 380
default_prompt = "%s> "
default_prompt2 = "%s| "
Boris Lykah's avatar
Boris Lykah committed
381 382
default_stop = ""

Simon Marlow's avatar
Simon Marlow committed
383 384 385
default_args :: [String]
default_args = []

386
interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]
387
              -> Ghc ()
388
interactiveUI config srcs maybe_exprs = do
389 390 391 392 393 394 395 396
   -- 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.
397 398 399
   _ <- liftIO $ newStablePtr stdin
   _ <- liftIO $ newStablePtr stdout
   _ <- liftIO $ newStablePtr stderr
400

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

404
   -- The initial set of DynFlags used for interactive evaluation is the same
405 406
   -- as the global DynFlags, plus -XExtendedDefaultRules and
   -- -XNoMonomorphismRestriction.
407
   dflags <- getDynFlags
408 409
   let dflags' = (`xopt_set` LangExt.ExtendedDefaultRules)
               . (`xopt_unset` LangExt.MonomorphismRestriction)
410 411
               $ dflags
   GHC.setInteractiveDynFlags dflags'
412

413 414 415 416 417
   lastErrLocationsRef <- liftIO $ newIORef []
   progDynFlags <- GHC.getProgramDynFlags
   _ <- GHC.setProgramDynFlags $
      progDynFlags { log_action = ghciLogAction lastErrLocationsRef }

418
   when (isNothing maybe_exprs) $ do
Ian Lynagh's avatar
Ian Lynagh committed
419 420 421
        -- Only for GHCi (not runghc and ghc -e):

        -- Turn buffering off for the compiled program's stdout/stderr
422
        turnOffBuffering_ nobuffering
Ian Lynagh's avatar
Ian Lynagh committed
423
        -- Turn buffering off for GHCi's stdout
424 425
        liftIO $ hFlush stdout
        liftIO $ hSetBuffering stdout NoBuffering
Ian Lynagh's avatar
Ian Lynagh committed
426 427
        -- We don't want the cmd line to buffer any input that might be
        -- intended for the program, so unbuffer stdin.
428 429
        liftIO $ hSetBuffering stdin NoBuffering
        liftIO $ hSetBuffering stderr NoBuffering
430
#if defined(mingw32_HOST_OS)
431 432 433
        -- 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.
434
        liftIO $ hSetEncoding stdin utf8
435
#endif
Ian Lynagh's avatar
Ian Lynagh committed
436

437
   default_editor <- liftIO $ findEditor
438
   eval_wrapper <- mkEvalWrapper default_progname default_args
Ian Lynagh's avatar
Ian Lynagh committed
439
   startGHCi (runGHCi srcs maybe_exprs)
440
        GHCiState{ progname           = default_progname,
441
                   args               = default_args,
442
                   evalWrapper        = eval_wrapper,
443 444
                   prompt             = defPrompt config,
                   prompt2            = defPrompt2 config,
445 446 447
                   stop               = default_stop,
                   editor             = default_editor,
                   options            = [],
448 449 450 451
                   -- 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,
452 453 454 455 456 457 458 459 460 461 462
                   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,
463
                   lastErrorLocations = lastErrLocationsRef,
464
                   mod_infos          = M.empty,
465 466
                   flushStdHandles    = flush,
                   noBuffering        = nobuffering
mnislaih's avatar
mnislaih committed
467
                 }
468

469 470
   return ()

471 472 473 474 475 476 477 478 479 480 481 482 483 484 485
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 ()

486 487
withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
withGhcAppData right left = do
488
    either_dir <- tryIO (getAppUserDataDirectory "ghc")
489 490 491 492 493
    case either_dir of
        Right dir ->
            do createDirectoryIfMissing False dir `catchIO` \_ -> return ()
               right dir
        _ -> left
494

Ian Lynagh's avatar
Ian Lynagh committed
495 496
runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
runGHCi paths maybe_exprs = do
497
  dflags <- getDynFlags
498
  let
499
   ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags
500

501 502
   current_dir = return (Just ".ghci")

Ian Lynagh's avatar
Ian Lynagh committed
503
   app_user_dir = liftIO $ withGhcAppData
504 505
                    (\dir -> return (Just (dir </> "ghci.conf")))
                    (return Nothing)
506 507

   home_dir = do
508
    either_dir <- liftIO $ tryIO (getEnv "HOME")
509 510 511 512
    case either_dir of
      Right home -> return (Just (home </> ".ghci"))
      _ -> return Nothing

513 514 515 516
   canonicalizePath' :: FilePath -> IO (Maybe FilePath)
   canonicalizePath' fp = liftM Just (canonicalizePath fp)
                `catchIO` \_ -> return Nothing

517 518
   sourceConfigFile :: FilePath -> GHCi ()
   sourceConfigFile file = do
Ian Lynagh's avatar
Ian Lynagh committed
519
     exists <- liftIO $ doesFileExist file
520
     when exists $ do
521 522 523 524 525 526 527 528 529 530
       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 ())
531
                liftIO $ putStrLn ("Loaded GHCi configuration from " ++ file)
532

533 534
  --

535
  setGHCContextFromGHCiState
Ian Lynagh's avatar
Ian Lynagh committed
536

537 538
  dot_cfgs <- if ignore_dot_ghci then return [] else do
    dot_files <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]
539
    liftIO $ filterM checkFileAndDirPerms dot_files
540 541
  mdot_cfgs <- liftIO $ mapM canonicalizePath' dot_cfgs

542 543 544 545
  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)
546
  mapM_ sourceConfigFile $ nub $ (catMaybes mdot_cfgs) ++ arg_cfgs
547
    -- nub, because we don't want to read .ghci twice if the CWD is $HOME.
548

549
  -- Perform a :load for files given on the GHCi command line
550 551 552
  -- 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
553
     ok <- ghciHandle (\e -> do showException e; return Failed) $
554
                -- TODO: this is a hack.
555 556
                runInputTWithPrefs defaultPrefs defaultSettings $
                    loadModule paths
Ian Lynagh's avatar
Ian Lynagh committed
557
     when (isJust maybe_exprs && failed ok) $
Ian Lynagh's avatar
Ian Lynagh committed
558
        liftIO (exitWith (ExitFailure 1))
559

560 561
  installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)

562 563
  -- 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
564
  is_tty <- liftIO (hIsTerminalDevice stdin)
565 566
  let show_prompt = verbosity dflags > 0 || is_tty

567
  -- reset line number
568
  modifyGHCiState $ \st -> st{line_number=0}
569

Ian Lynagh's avatar
Ian Lynagh committed
570
  case maybe_exprs of
Ian Lynagh's avatar
Ian Lynagh committed
571
        Nothing ->
sof's avatar
sof committed
572
          do
Ian Lynagh's avatar
Ian Lynagh committed
573
            -- enter the interactive loop
574
            runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
Ian Lynagh's avatar
Ian Lynagh committed
575
        Just exprs -> do
Ian Lynagh's avatar
Ian Lynagh committed
576
            -- just evaluate the expression we were given
Ian Lynagh's avatar
Ian Lynagh committed
577
            enqueueCommands exprs
dterei's avatar
dterei committed
578 579 580 581 582 583 584 585
            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
586
                                   -- this used to be topHandlerFastExit, see #2228
587
            runInputTWithPrefs defaultPrefs defaultSettings $ do
588
                -- make `ghc -e` exit nonzero on invalid input, see Trac #7962
589 590 591 592
                _ <- runCommands' hdle
                     (Just $ hdle (toException $ ExitFailure 1) >> return ())
                     (return Nothing)
                return ()
593 594

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

597 598
runGHCiInput :: InputT GHCi a -> GHCi a
runGHCiInput f = do
Ian Lynagh's avatar
Ian Lynagh committed
599
    dflags <- getDynFlags
ian@well-typed.com's avatar
ian@well-typed.com committed
600
    histFile <- if gopt Opt_GhciHistory dflags
Ian Lynagh's avatar
Ian Lynagh committed
601 602 603
                then liftIO $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
                                             (return Nothing)
                else return Nothing
dterei's avatar
dterei committed
604 605 606
    runInputT
        (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})
        f
607

608
-- | How to get the next input line from the user
609 610 611
nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
nextInputLine show_prompt is_tty
  | is_tty = do
dterei's avatar
dterei committed
612 613
    prmpt <- if show_prompt then lift mkPrompt else return ""
    r <- getInputLine prmpt
614 615
    incrementLineNo
    return r
616 617 618
  | otherwise = do
    when show_prompt $ lift mkPrompt >>= liftIO . putStr
    fileLoop stdin
619

620
-- NOTE: We only read .ghci files if they are owned by the current user,
621 622 623
-- 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.
624

rrt's avatar
rrt committed
625 626 627 628
-- 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.
629

630 631
checkFileAndDirPerms :: FilePath -> IO Bool
checkFileAndDirPerms file = do
632
  file_ok <- checkPerms file
thomie's avatar
thomie committed
633 634 635 636
  -- 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.
637
  if file_ok then checkPerms (getDirectory file) else return False
638 639 640 641 642 643
  where
  getDirectory f = case takeDirectory f of
    "" -> "."
    d -> d

checkPerms :: FilePath -> IO Bool
644
#ifdef mingw32_HOST_OS
dterei's avatar
dterei committed
645
checkPerms _ = return True
sof's avatar
sof committed
646
#else
647
checkPerms file =
648
  handleIO (\_ -> return False) $ do
649
    st <- getFileStatus file
dterei's avatar
dterei committed
650
    me <- getRealUserID
651 652 653 654 655
    let mode = System.Posix.fileMode st
        ok = (fileOwner st == me || fileOwner st == 0) &&
             groupWriteMode /= mode `intersectFileModes` groupWriteMode &&
             otherWriteMode /= mode `intersectFileModes` otherWriteMode
    unless ok $
656
      -- #8248: Improving warning to include a possible fix.
657
      putStrLn $ "*** WARNING: " ++ file ++
658
                 " is writable by someone else, IGNORING!" ++
Ben Gamari's avatar
Ben Gamari committed
659
                 "\nSuggested fix: execute 'chmod go-w " ++ file ++ "'"
660
    return ok
sof's avatar
sof committed
661
#endif
662

663
incrementLineNo :: InputT GHCi ()
664 665 666
incrementLineNo = modifyGHCiState incLineNo
  where
    incLineNo st = st { line_number = line_number st + 1 }
vivian's avatar
vivian committed
667 668

fileLoop :: Handle -> InputT GHCi (Maybe String)
669
fileLoop hdl = do
670
   l <- liftIO $ tryIO $ hGetLine hdl
671
   case l of
672
        Left e | isEOFError e              -> return Nothing
673 674 675 676 677
               | -- 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
678
               | InvalidArgument <- etype  -> return Nothing
679
               | otherwise                 -> liftIO $ ioError e
680 681 682 683 684
                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
685
        Right l' -> do
686
           incrementLineNo
dterei's avatar
dterei committed
687
           return (Just l')
688

Simon Marlow's avatar
Simon Marlow committed
689
mkPrompt :: GHCi String
690
mkPrompt = do
691
  st <- getGHCiState
692
  imports <- GHC.getContext
693
  resumes <- GHC.getResumeContext
694 695 696 697

  context_bit <-
        case resumes of
            [] -> return empty
Simon Marlow's avatar
Simon Marlow committed
698
            r:_ -> do
699 700 701 702 703
                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
704 705 706
                        pan <- GHC.getHistorySpan hist
                        return (brackets (ppr (negate ix) <> char ':'
                                          <+> ppr pan) <> space)
707
  let
Simon Marlow's avatar
Simon Marlow committed
708
        dots | _:rs <- resumes, not (null rs) = text "... "
709 710
             | otherwise = empty

711
        rev_imports = reverse imports -- rightmost are the most recent
712 713 714
        modules_bit =
             hsep [ char '*' <> ppr m | IIModule m <- rev_imports ] <+>
             hsep (map ppr [ myIdeclName d | IIDecl d <- rev_imports ])
715 716 717 718

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

720
        deflt_prompt = dots <> context_bit <> modules_bit
721

722
        f ('%':'l':xs) = ppr (1 + line_number st) <> f xs
723 724 725 726
        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
727

728 729
  dflags <- getDynFlags
  return (showSDoc dflags (f (prompt st)))
730

731

732 733 734 735 736 737 738 739
queryQueue :: GHCi (Maybe String)
queryQueue = do
  st <- getGHCiState
  case cmdqueue st of
    []   -> return Nothing
    c:cs -> do setGHCiState st{ cmdqueue = cs }
               return (Just c)

740 741 742 743 744 745
-- 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
746
                modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name
747
                                      in he{hsc_IC = new_ic})
748 749 750 751
                return Succeeded

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

752
-- | The main read-eval-print loop
753
runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
754
runCommands gCmd = runCommands' handler Nothing gCmd >> return ()
755

dterei's avatar
dterei committed
756
runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler
757
             -> Maybe (GHCi ()) -- ^ Source error handler
758 759 760 761 762 763
             -> 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
764
    b <- ghandle (\e -> case fromException e of
vivian's avatar
vivian committed
765
                          Just UserInterrupt -> return $ Just False
766
                          _ -> case fromException e of
dterei's avatar
dterei committed
767 768
                                 Just ghce ->
                                   do liftIO (print (ghce :: GhcException))
vivian's avatar
vivian committed
769
                                      return Nothing
770 771
                                 _other ->
                                   liftIO (Exception.throwIO e))
772
            (unmask $ runOneCommand eh gCmd)
vivian's avatar
vivian committed
773
    case b of
774
      Nothing -> return Nothing
775
      Just success -> do
776
        unless success $ maybe (return ()) lift sourceErrorHandler
777
        unmask $ runCommands' eh sourceErrorHandler gCmd
778

779 780 781 782 783
-- | 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.
784
runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)