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

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

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

21 22
#include "HsVersions.h"

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

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

import StringBuffer
import Outputable hiding ( printForUser, printForUserPartWay, bold )
50 51

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

dterei's avatar
dterei committed
63
-- Haskell Libraries
64
import System.Console.Haskeline as Haskeline
65

66
import Control.Monad as Monad
67

dterei's avatar
dterei committed
68
import Control.Applicative hiding (empty)
69 70
import Control.Monad.Trans.Class
import Control.Monad.IO.Class
71

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

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

import Foreign.C
import Foreign.Safe

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

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

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

108 109
-----------------------------------------------------------------------------

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

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

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

Simon Marlow's avatar
Simon Marlow committed
132
cmdName :: Command -> String
133
cmdName (n,_,_) = n
134

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

137 138
ghciCommands :: [Command]
ghciCommands = [
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),
150
  ("complete",  keepGoing completeCmd,          noCompletion),
151
  ("cmd",       keepGoing cmdCmd,               completeExpression),
152 153
  ("ctags",     keepGoing createCTagsWithLineNumbersCmd, completeFilename),
  ("ctags!",    keepGoing createCTagsWithRegExesCmd, completeFilename),
154 155 156
  ("def",       keepGoing (defineMacro False),  completeExpression),
  ("def!",      keepGoing (defineMacro True),   completeExpression),
  ("delete",    keepGoing deleteCmd,            noCompletion),
157
  ("edit",      keepGoing' editFile,            completeFilename),
158 159 160 161 162
  ("etags",     keepGoing createETagsFileCmd,   completeFilename),
  ("force",     keepGoing forceCmd,             completeExpression),
  ("forward",   keepGoing forwardCmd,           noCompletion),
  ("help",      keepGoing help,                 noCompletion),
  ("history",   keepGoing historyCmd,           noCompletion),
163 164
  ("info",      keepGoing' (info False),        completeIdentifier),
  ("info!",     keepGoing' (info True),         completeIdentifier),
165
  ("issafe",    keepGoing' isSafeCmd,           completeModule),
166 167
  ("kind",      keepGoing' (kindOfType False),  completeIdentifier),
  ("kind!",     keepGoing' (kindOfType True),   completeIdentifier),
168 169
  ("load",      keepGoingPaths loadModule_,     completeHomeModuleOrFile),
  ("list",      keepGoing' listCmd,             noCompletion),
170
  ("module",    keepGoing moduleCmd,            completeSetModule),
171 172 173 174 175
  ("main",      keepGoing runMain,              completeFilename),
  ("print",     keepGoing printCmd,             completeExpression),
  ("quit",      quit,                           noCompletion),
  ("reload",    keepGoing' reloadModule,        noCompletion),
  ("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
  ]

191

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

206
flagWordBreakChars :: String
207 208 209
flagWordBreakChars = " \t\n"


210 211 212 213 214
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
215

216
keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
Ian Lynagh's avatar
Ian Lynagh committed
217 218
keepGoingPaths a str
 = do case toArgs str of
Ian Lynagh's avatar
Ian Lynagh committed
219
          Left err -> liftIO $ hPutStrLn stderr err
Ian Lynagh's avatar
Ian Lynagh committed
220 221
          Right args -> a args
      return False
sof's avatar
sof committed
222

223 224
defShortHelpText :: String
defShortHelpText = "use :? for help.\n"
225

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

dterei's avatar
dterei committed
287 288 289 290
  "\n" ++
  " -- Commands for changing settings:\n" ++
  "\n" ++
  "   :set <option> ...           set options\n" ++
291
  "   :seti <option> ...          set options for interactive evaluation only\n" ++
dterei's avatar
dterei committed
292 293 294
  "   :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" ++
295
  "   :set prompt2 <prompt>       set the continuation prompt used in GHCi\n" ++
dterei's avatar
dterei committed
296 297 298 299 300 301
  "   :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
302
  "    +m            allow multiline commands\n" ++
dterei's avatar
dterei committed
303 304 305 306
  "    +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" ++
307
  "                         (eg. -v2, -XFlexibleInstances, etc.)\n" ++
dterei's avatar
dterei committed
308 309 310 311 312 313 314 315
  "                    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" ++
316
  "   :show imports               show the current imports\n" ++
317
  "   :show linker                show current linker state\n" ++
dterei's avatar
dterei committed
318 319
  "   :show modules               show the currently loaded modules\n" ++
  "   :show packages              show the currently active package flags\n" ++
320
  "   :show paths                 show the currently active search paths\n" ++
321
  "   :show language              show the currently active language flags\n" ++
dterei's avatar
dterei committed
322 323
  "   :show <setting>             show value of <setting>, which is one of\n" ++
  "                                  [args, prog, prompt, editor, stop]\n" ++
324
  "   :showi language             show language flags for interactive evaluation\n" ++
dterei's avatar
dterei committed
325
  "\n"
326

Simon Marlow's avatar
Simon Marlow committed
327
findEditor :: IO String
Simon Marlow's avatar
Simon Marlow committed
328
findEditor = do
dterei's avatar
dterei committed
329
  getEnv "EDITOR"
330
    `catchIO` \_ -> do
331
#if mingw32_HOST_OS
Ian Lynagh's avatar
Ian Lynagh committed
332 333
        win <- System.Win32.getWindowsDirectory
        return (win </> "notepad.exe")
Simon Marlow's avatar
Simon Marlow committed
334
#else
Ian Lynagh's avatar
Ian Lynagh committed
335
        return ""
Simon Marlow's avatar
Simon Marlow committed
336 337
#endif

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

340
default_progname, default_prompt, default_prompt2, default_stop :: String
boris's avatar
boris committed
341 342
default_progname = "<interactive>"
default_prompt = "%s> "
343
default_prompt2 = "%s| "
boris's avatar
boris committed
344 345
default_stop = ""

Simon Marlow's avatar
Simon Marlow committed
346 347 348
default_args :: [String]
default_args = []

349
interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]
350
              -> Ghc ()
351
interactiveUI config srcs maybe_exprs = do
352 353 354
   -- 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
355
   i <- liftIO $ isProfiled
dterei's avatar
dterei committed
356
   when (i /= 0) $
357
     throwGhcException (InstallationError "GHCi cannot be used when compiled with -prof")
358

359 360 361 362 363 364 365 366
   -- 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.
367 368 369
   _ <- liftIO $ newStablePtr stdin
   _ <- liftIO $ newStablePtr stdout
   _ <- liftIO $ newStablePtr stderr
370

Ian Lynagh's avatar
Ian Lynagh committed
371
    -- Initialise buffering for the *interpreted* I/O system
372
   initInterpBuffering
373

374
   -- The initial set of DynFlags used for interactive evaluation is the same
375 376
   -- as the global DynFlags, plus -XExtendedDefaultRules and
   -- -XNoMonomorphismRestriction.
377
   dflags <- getDynFlags
378 379 380 381
   let dflags' = (`xopt_set` Opt_ExtendedDefaultRules)
               . (`xopt_unset` Opt_MonomorphismRestriction)
               $ dflags
   GHC.setInteractiveDynFlags dflags'
382

383 384 385 386 387
   lastErrLocationsRef <- liftIO $ newIORef []
   progDynFlags <- GHC.getProgramDynFlags
   _ <- GHC.setProgramDynFlags $
      progDynFlags { log_action = ghciLogAction lastErrLocationsRef }

388
   liftIO $ when (isNothing maybe_exprs) $ do
Ian Lynagh's avatar
Ian Lynagh committed
389 390 391 392 393 394 395 396 397 398
        -- 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
399
        hSetBuffering stderr NoBuffering
400
#if defined(mingw32_HOST_OS)
401 402 403 404 405
        -- 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
406

407
   default_editor <- liftIO $ findEditor
Ian Lynagh's avatar
Ian Lynagh committed
408
   startGHCi (runGHCi srcs maybe_exprs)
409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428
        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
429
                 }
430

431 432
   return ()

433 434 435 436 437 438 439 440 441 442 443 444 445 446 447
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 ()

448 449
withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
withGhcAppData right left = do
450
    either_dir <- tryIO (getAppUserDataDirectory "ghc")
451 452 453 454 455
    case either_dir of
        Right dir ->
            do createDirectoryIfMissing False dir `catchIO` \_ -> return ()
               right dir
        _ -> left
456

Ian Lynagh's avatar
Ian Lynagh committed
457 458
runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
runGHCi paths maybe_exprs = do
459
  dflags <- getDynFlags
460
  let
ian@well-typed.com's avatar
ian@well-typed.com committed
461
   read_dot_files = not (gopt Opt_IgnoreDotGhci dflags)
462

463 464
   current_dir = return (Just ".ghci")

Ian Lynagh's avatar
Ian Lynagh committed
465
   app_user_dir = liftIO $ withGhcAppData
466 467
                    (\dir -> return (Just (dir </> "ghci.conf")))
                    (return Nothing)
468 469

   home_dir = do
470
    either_dir <- liftIO $ tryIO (getEnv "HOME")
471 472 473 474
    case either_dir of
      Right home -> return (Just (home </> ".ghci"))
      _ -> return Nothing

475 476 477 478
   canonicalizePath' :: FilePath -> IO (Maybe FilePath)
   canonicalizePath' fp = liftM Just (canonicalizePath fp)
                `catchIO` \_ -> return Nothing

479 480
   sourceConfigFile :: (FilePath, Bool) -> GHCi ()
   sourceConfigFile (file, check_perms) = do
Ian Lynagh's avatar
Ian Lynagh committed
481
     exists <- liftIO $ doesFileExist file
482
     when exists $ do
483 484 485 486 487 488 489 490
       perms_ok <-
         if not check_perms
            then return True
            else do
              dir_ok  <- liftIO $ checkPerms (getDirectory file)
              file_ok <- liftIO $ checkPerms file
              return (dir_ok && file_ok)
       when perms_ok $ do
491
         either_hdl <- liftIO $ tryIO (openFile file ReadMode)
492 493
         case either_hdl of
           Left _e   -> return ()
494 495 496
           -- 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.
497 498
           Right hdl ->
               do runInputTWithPrefs defaultPrefs defaultSettings $
499
                            runCommands $ fileLoop hdl
500
                  liftIO (hClose hdl `catchIO` \_ -> return ())
501 502
     where
      getDirectory f = case takeDirectory f of "" -> "."; d -> d
503 504
  --

505
  setGHCContextFromGHCiState
Ian Lynagh's avatar
Ian Lynagh committed
506

507
  when (read_dot_files) $ do
508 509 510 511 512 513 514 515
    mcfgs0 <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]
    let mcfgs1 = zip mcfgs0 (repeat True)
              ++ zip (ghciScripts dflags) (repeat False)
         -- False says "don't check permissions".  We don't
         -- require that a script explicitly added by
         -- -ghci-script is owned by the current user. (#6017)
    mcfgs <- liftIO $ mapM (\(f, b) -> (,b) <$> canonicalizePath' f) mcfgs1
    mapM_ sourceConfigFile $ nub $ [ (f,b) | (Just f, b) <- mcfgs ]
516 517
        -- nub, because we don't want to read .ghci twice if the
        -- CWD is $HOME.
518

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

530 531
  installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)

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

537 538 539
  -- reset line number
  getGHCiState >>= \st -> setGHCiState st{line_number=1}

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

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

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

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

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

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

checkPerms :: String -> IO Bool
598
#ifdef mingw32_HOST_OS
dterei's avatar
dterei committed
599
checkPerms _ = return True
sof's avatar
sof committed
600
#else
Simon Marlow's avatar
Simon Marlow committed
601
checkPerms name =
602
  handleIO (\_ -> return False) $ do
dterei's avatar
dterei committed
603 604
    st <- getFileStatus name
    me <- getRealUserID
605 606 607 608 609 610 611 612
    let mode = System.Posix.fileMode st
        ok = (fileOwner st == me || fileOwner st == 0) &&
             groupWriteMode /= mode `intersectFileModes` groupWriteMode &&
             otherWriteMode /= mode `intersectFileModes` otherWriteMode
    unless ok $
      putStrLn $ "*** WARNING: " ++ name ++
                 " is writable by someone else, IGNORING!"
    return ok
sof's avatar
sof committed
613
#endif
614

615 616
incrementLineNo :: InputT GHCi ()
incrementLineNo = do
vivian's avatar
vivian committed
617 618 619 620 621
   st <- lift $ getGHCiState
   let ln = 1+(line_number st)
   lift $ setGHCiState st{line_number=ln}

fileLoop :: Handle -> InputT GHCi (Maybe String)
622
fileLoop hdl = do
623
   l <- liftIO $ tryIO $ hGetLine hdl
624
   case l of
625
        Left e | isEOFError e              -> return Nothing
626 627 628 629 630
               | -- 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
631
               | InvalidArgument <- etype  -> return Nothing
632
               | otherwise                 -> liftIO $ ioError e
633 634 635 636 637
                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
638
        Right l' -> do
639
           incrementLineNo
dterei's avatar
dterei committed
640
           return (Just l')
641

Simon Marlow's avatar
Simon Marlow committed
642
mkPrompt :: GHCi String
643
mkPrompt = do
644
  st <- getGHCiState
645
  imports <- GHC.getContext
646
  resumes <- GHC.getResumeContext
647 648 649 650

  context_bit <-
        case resumes of
            [] -> return empty
Simon Marlow's avatar
Simon Marlow committed
651
            r:_ -> do
652 653 654 655 656
                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
657 658 659
                        pan <- GHC.getHistorySpan hist
                        return (brackets (ppr (negate ix) <> char ':'
                                          <+> ppr pan) <> space)
660
  let
Simon Marlow's avatar
Simon Marlow committed
661
        dots | _:rs <- resumes, not (null rs) = text "... "
662 663
             | otherwise = empty

664 665
        rev_imports = reverse imports -- rightmost are the most recent
        modules_bit =
666
             hsep [ char '*' <> ppr m | IIModule m <- rev_imports ] <+>
667 668 669 670 671
             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)
672

673 674
        deflt_prompt = dots <> context_bit <> modules_bit

675
        f ('%':'l':xs) = ppr (1 + line_number st) <> f xs
676 677 678 679
        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
680

Ian Lynagh's avatar
Ian Lynagh committed
681 682
  dflags <- getDynFlags
  return (showSDoc dflags (f (prompt st)))
683

684

685 686 687 688 689 690 691 692
queryQueue :: GHCi (Maybe String)
queryQueue = do
  st <- getGHCiState
  case cmdqueue st of
    []   -> return Nothing
    c:cs -> do setGHCiState st{ cmdqueue = cs }
               return (Just c)

693 694 695 696 697 698
-- 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
699
                modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name
700
                                      in he{hsc_IC = new_ic})
701 702 703 704
                return Succeeded

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

705
-- | The main read-eval-print loop
706
runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
707
runCommands = runCommands' handler Nothing
708

dterei's avatar
dterei committed
709
runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler
710
             -> Maybe (GHCi ()) -- ^ Source error handler
711
             -> InputT GHCi (Maybe String) -> InputT GHCi ()
712
runCommands' eh sourceErrorHandler gCmd = do
713
    b <- ghandle (\e -> case fromException e of
vivian's avatar
vivian committed
714
                          Just UserInterrupt -> return $ Just False
715
                          _ -> case fromException e of
dterei's avatar
dterei committed
716 717
                                 Just ghce ->
                                   do liftIO (print (ghce :: GhcException))
vivian's avatar
vivian committed
718
                                      return Nothing
719 720
                                 _other ->
                                   liftIO (Exception.throwIO e))
dterei's avatar
dterei committed
721
            (runOneCommand eh gCmd)
vivian's avatar
vivian committed
722 723
    case b of
      Nothing -> return ()
724
      Just success -> do
725 726
        when (not success) $ maybe (return ()) lift sourceErrorHandler
        runCommands' eh sourceErrorHandler gCmd
727

728
-- | Evaluate a single line of user input (either :<command> or Haskell code)
729
runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
vivian's avatar
vivian committed
730
            -> InputT GHCi (Maybe Bool)
dterei's avatar
dterei committed
731
runOneCommand eh gCmd = do
732 733
  -- run a previously queued command if there is one, otherwise get new
  -- input from user
dterei's avatar
dterei committed
734 735 736
  mb_cmd0 <- noSpace (lift queryQueue)
  mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0
  case mb_cmd1 of
vivian's avatar
vivian committed
737 738
    Nothing -> return Nothing
    Just c  -> ghciHandle (\e -> lift $ eh e >>= return . Just) $
739 740
             handleSourceError printErrorAndKeepGoing
               (doCommand c)
vivian's avatar
vivian committed
741 742
               -- source error's are handled by runStmt
               -- is the handler necessary here?
743
  where
744
    printErrorAndKeepGoing err = do
745
        GHC.printException err
vivian's avatar
vivian committed
746
        return $ Just True
747

748
    noSpace q = q >>= maybe (return Nothing)
dterei's avatar
dterei committed
749 750 751
                            (\c -> case removeSpaces c of
                                     ""   -> noSpace q
                                     ":{" -> multiLineCmd q
752
                                     _    -> return (Just c) )
753
    multiLineCmd q = do
754
      st <- lift getGHCiState
755
      let p = prompt st
756
      lift $ setGHCiState st{ prompt = prompt2 st }
757
      mb_cmd <- collectCommand q "" `GHC.gfinally` lift (getGHCiState >>= \st' -> setGHCiState st' { prompt = p })
758
      return mb_cmd
dterei's avatar
dterei committed
759
    -- we can't use removeSpaces for the sublines here, so
760
    -- multiline commands are somewhat more brittle against
dterei's avatar
dterei committed
761 762
    -- fileformat errors (such as \r in dos input on unix),
    -- we get rid of any extra spaces for the ":}" test;
763
    -- we also avoid silent failure if ":}" is not found;
dterei's avatar
dterei committed
764
    -- and since there is no (?) valid occurrence of \r (as
765 766
    -- opposed to its String representation, "\r") inside a
    -- ghci command, we replace any such with ' ' (argh:-(
dterei's avatar
dterei committed
767
    collectCommand q c = q >>=
768
      maybe (liftIO (ioError collectError))
dterei's avatar
dterei committed
769
            (\l->if removeSpaces l == ":}"
770
                 then return (Just c)
771
                 else collectCommand q (c ++ "\n" ++ map normSpace l))
772
      where normSpace '\r' = ' '
dterei's avatar
dterei committed
773
            normSpace   x  = x
dterei's avatar
dterei committed
774
    -- SDM (2007-11-07): is userError the one to use here?
775
    collectError = userError "unterminated multiline command :{ .. :}"
776 777 778 779 780

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

    -- command
781
    doCommand stmt | (':' : cmd) <- removeSpaces stmt = do
vivian's avatar
vivian committed
782 783 784 785
      result <- specialCommand cmd
      case result of
        True -> return Nothing
        _    -> return $ Just True
786 787 788

    -- haskell
    doCommand stmt = do
789 790
      -- if 'stmt' was entered via ':{' it will contain '\n's
      let stmt_nl_cnt = length [ () | '\n' <- stmt ]
vivian's avatar
vivian committed
791
      ml <- lift $ isOptionSet Multiline
792
      if ml && stmt_nl_cnt == 0 -- don't trigger automatic multi-line mode for ':{'-multiline input
dterei's avatar
dterei committed
793
        then do
794
          fst_line_num <- lift (line_number <$> getGHCiState)
dterei's avatar
dterei committed
795
          mb_stmt <- checkInputForLayout stmt gCmd
vivian's avatar
vivian committed
796 797 798
          case mb_stmt of
            Nothing      -> return $ Just True
            Just ml_stmt -> do
799 800
              -- temporarily compensate line-number for multi-line input
              result <- timeIt $ lift $ runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion
vivian's avatar
vivian committed
801
              return $ Just result
802 803 804 805 806 807 808 809 810
        else do -- single line input and :{-multiline input
          last_line_num <- lift (line_number <$> getGHCiState)
          -- reconstruct first line num from last line num and stmt
          let fst_line_num | stmt_nl_cnt > 0 = last_line_num - (stmt_nl_cnt2 + 1)
                           | otherwise = last_line_num -- single line input
              stmt_nl_cnt2 = length [ () | '\n' <- stmt' ]
              stmt' = dropLeadingWhiteLines stmt -- runStmt doesn't like leading empty lines
          -- temporarily compensate line-number for multi-line input
          result <- timeIt $ lift $ runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion
vivian's avatar
vivian committed
811 812
          return $ Just result

813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828
    -- runStmt wrapper for temporarily overridden line-number
    runStmtWithLineNum :: Int -> String -> SingleStep -> GHCi Bool
    runStmtWithLineNum lnum stmt step = do
        st0 <- getGHCiState
        setGHCiState st0 { line_number = lnum }
        result <- runStmt stmt step
        -- restore original line_number
        getGHCiState >>= \st -> setGHCiState st { line_number = line_number st0 }
        return result

    -- note: this is subtly different from 'unlines . dropWhile (all isSpace) . lines'
    dropLeadingWhiteLines s | (l0,'\n':r) <- break (=='\n') s
                            , all isSpace l0 = dropLeadingWhiteLines r
                            | otherwise = s


vivian's avatar
vivian committed
829 830
-- #4316
-- lex the input.  If there is an unclosed layout context, request input
vivian's avatar
vivian committed
831
checkInputForLayout :: String -> InputT GHCi (Maybe String)
vivian's avatar
vivian committed
832
                    -> InputT GHCi (Maybe String)
vivian's avatar
vivian committed
833
checkInputForLayout stmt getStmt = do
vivian's avatar
vivian committed
834 835
   dflags' <- lift $ getDynFlags
   let dflags = xopt_set dflags' Opt_AlternativeLayoutRule
dterei's avatar
dterei committed
836 837 838 839
   st0 <- lift $ getGHCiState
   let buf'   =  stringToStringBuffer stmt
       loc    = mkRealSrcLoc (fsLit (progname st0)) (line_number st0) 1
       pstate = Lexer.mkPState dflags buf' loc
vivian's avatar
vivian committed
840 841 842
   case Lexer.unP goToEnd pstate of
     (Lexer.POk _ False) -> return $ Just stmt
     _other              -> do
dterei's avatar
dterei committed
843 844
       st1 <- lift getGHCiState
       let p = prompt st1
845
       lift $ setGHCiState st1{ prompt = prompt2 st1 }
vivian's avatar
vivian committed
846 847 848
       mb_stmt <- ghciHandle (\ex -> case fromException ex of
                            Just UserInterrupt -> return Nothing
                            _ -> case fromException ex of
dterei's avatar
dterei committed
849 850
                                 Just ghce ->
                                   do liftIO (print (ghce :: GhcException))
vivian's avatar
vivian committed
851
                                      return Nothing
dterei's avatar
dterei committed
852
                                 _other -> liftIO (Exception.throwIO ex))
vivian's avatar
vivian committed
853
                     getStmt
dterei's avatar
dterei committed
854
       lift $ getGHCiState >>= \st' -> setGHCiState st'{ prompt = p }
vivian's avatar
vivian committed
855 856 857 858 859 860
       -- the recursive call does not recycle parser state
       -- as we use a new string buffer
       case mb_stmt of
         Nothing  -> return Nothing
         Just str -> if str == ""
           then return $ Just stmt
vivian's avatar
vivian committed
861 862
           else do
             checkInputForLayout (stmt++"\n"++str) getStmt
vivian's avatar
vivian committed
863 864
     where goToEnd = do
             eof <- Lexer.nextIsEOF
dterei's avatar
dterei committed
865
             if eof