InteractiveUI.hs 118 KB
Newer Older
1 2 3
{-# OPTIONS -fno-cse #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly

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

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

20 21
#include "HsVersions.h"

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

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

import StringBuffer
import UniqFM ( eltsUFM )
import Outputable hiding ( printForUser, printForUserPartWay, bold )
49 50

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

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

dterei's avatar
dterei committed
65 66
import Control.Applicative hiding (empty)
import Control.Monad as Monad
67 68
import Control.Monad.Trans.Class
import Control.Monad.IO.Class
69

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

79
import Exception hiding (catch)
dterei's avatar
dterei committed
80 81 82 83 84

import Foreign.C
import Foreign.Safe

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

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

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

106

107 108
-----------------------------------------------------------------------------

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

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

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

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

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

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

190

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

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


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

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

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

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

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

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

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

337
default_progname, default_prompt, default_prompt2, default_stop :: String
boris's avatar
boris committed
338 339
default_progname = "<interactive>"
default_prompt = "%s> "
340
default_prompt2 = "%s| "
boris's avatar
boris committed
341 342
default_stop = ""

Simon Marlow's avatar
Simon Marlow committed
343 344 345
default_args :: [String]
default_args = []

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

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

Ian Lynagh's avatar
Ian Lynagh committed
368
    -- Initialise buffering for the *interpreted* I/O system
369
   initInterpBuffering
370

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

380
   liftIO $ when (isNothing maybe_exprs) $ do
Ian Lynagh's avatar
Ian Lynagh committed
381 382 383 384 385 386 387 388 389 390
        -- 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
391
        hSetBuffering stderr NoBuffering
392
#if defined(mingw32_HOST_OS)
393 394 395 396 397
        -- 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
398

399
   default_editor <- liftIO $ findEditor
Simon Marlow's avatar
Simon Marlow committed
400

Ian Lynagh's avatar
Ian Lynagh committed
401
   startGHCi (runGHCi srcs maybe_exprs)
dterei's avatar
dterei committed
402 403
        GHCiState{ progname       = default_progname,
                   GhciMonad.args = default_args,
404
                   prompt         = defPrompt config,
405
                   prompt2        = defPrompt2 config,
dterei's avatar
dterei committed
406 407 408 409 410 411 412
                   stop           = default_stop,
                   editor         = default_editor,
                   options        = [],
                   line_number    = 1,
                   break_ctr      = 0,
                   breaks         = [],
                   tickarrays     = emptyModuleEnv,
413
                   ghci_commands  = availableCommands config,
dterei's avatar
dterei committed
414 415
                   last_command   = Nothing,
                   cmdqueue       = [],
mnislaih's avatar
mnislaih committed
416
                   remembered_ctx = [],
dterei's avatar
dterei committed
417
                   transient_ctx  = [],
418 419 420
                   ghc_e          = isJust maybe_exprs,
                   short_help     = shortHelpText config,
                   long_help      = fullHelpText config
mnislaih's avatar
mnislaih committed
421
                 }
rrt's avatar
rrt committed
422

423 424
   return ()

425 426
withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
withGhcAppData right left = do
427
    either_dir <- tryIO (getAppUserDataDirectory "ghc")
428 429 430 431 432
    case either_dir of
        Right dir ->
            do createDirectoryIfMissing False dir `catchIO` \_ -> return ()
               right dir
        _ -> left
433

Ian Lynagh's avatar
Ian Lynagh committed
434 435
runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
runGHCi paths maybe_exprs = do
436
  dflags <- getDynFlags
437
  let
ian@well-typed.com's avatar
ian@well-typed.com committed
438
   read_dot_files = not (gopt Opt_IgnoreDotGhci dflags)
439

440 441
   current_dir = return (Just ".ghci")

Ian Lynagh's avatar
Ian Lynagh committed
442
   app_user_dir = liftIO $ withGhcAppData
443 444
                    (\dir -> return (Just (dir </> "ghci.conf")))
                    (return Nothing)
445 446

   home_dir = do
447
    either_dir <- liftIO $ tryIO (getEnv "HOME")
448 449 450 451
    case either_dir of
      Right home -> return (Just (home </> ".ghci"))
      _ -> return Nothing

452 453 454 455
   canonicalizePath' :: FilePath -> IO (Maybe FilePath)
   canonicalizePath' fp = liftM Just (canonicalizePath fp)
                `catchIO` \_ -> return Nothing

456 457
   sourceConfigFile :: FilePath -> GHCi ()
   sourceConfigFile file = do
Ian Lynagh's avatar
Ian Lynagh committed
458
     exists <- liftIO $ doesFileExist file
459
     when exists $ do
Ian Lynagh's avatar
Ian Lynagh committed
460 461
       dir_ok  <- liftIO $ checkPerms (getDirectory file)
       file_ok <- liftIO $ checkPerms file
462
       when (dir_ok && file_ok) $ do
463
         either_hdl <- liftIO $ tryIO (openFile file ReadMode)
464 465
         case either_hdl of
           Left _e   -> return ()
466 467 468
           -- 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.
469 470
           Right hdl ->
               do runInputTWithPrefs defaultPrefs defaultSettings $
471
                            runCommands $ fileLoop hdl
472
                  liftIO (hClose hdl `catchIO` \_ -> return ())
473 474
     where
      getDirectory f = case takeDirectory f of "" -> "."; d -> d
475 476
  --

477
  setGHCContextFromGHCiState
Ian Lynagh's avatar
Ian Lynagh committed
478

479
  when (read_dot_files) $ do
480
    mcfgs0 <- sequence $ [ current_dir, app_user_dir, home_dir ] ++ map (return . Just ) (ghciScripts dflags)
Ian Lynagh's avatar
Ian Lynagh committed
481
    mcfgs <- liftIO $ mapM canonicalizePath' (catMaybes mcfgs0)
482
    mapM_ sourceConfigFile $ nub $ catMaybes mcfgs
483 484
        -- nub, because we don't want to read .ghci twice if the
        -- CWD is $HOME.
485

486
  -- Perform a :load for files given on the GHCi command line
487 488 489
  -- 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
490
     ok <- ghciHandle (\e -> do showException e; return Failed) $
491
                -- TODO: this is a hack.
492 493
                runInputTWithPrefs defaultPrefs defaultSettings $
                    loadModule paths
Ian Lynagh's avatar
Ian Lynagh committed
494
     when (isJust maybe_exprs && failed ok) $
Ian Lynagh's avatar
Ian Lynagh committed
495
        liftIO (exitWith (ExitFailure 1))
496

497 498
  installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)

499 500
  -- 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
501
  is_tty <- liftIO (hIsTerminalDevice stdin)
502 503
  let show_prompt = verbosity dflags > 0 || is_tty

504 505 506
  -- reset line number
  getGHCiState >>= \st -> setGHCiState st{line_number=1}

Ian Lynagh's avatar
Ian Lynagh committed
507
  case maybe_exprs of
Ian Lynagh's avatar
Ian Lynagh committed
508
        Nothing ->
sof's avatar
sof committed
509
          do
Ian Lynagh's avatar
Ian Lynagh committed
510
            -- enter the interactive loop
511
            runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
Ian Lynagh's avatar
Ian Lynagh committed
512
        Just exprs -> do
Ian Lynagh's avatar
Ian Lynagh committed
513
            -- just evaluate the expression we were given
Ian Lynagh's avatar
Ian Lynagh committed
514
            enqueueCommands exprs
dterei's avatar
dterei committed
515 516 517 518 519 520 521 522
            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
523
                                   -- this used to be topHandlerFastExit, see #2228
524
            runInputTWithPrefs defaultPrefs defaultSettings $ do
dterei's avatar
dterei committed
525
                runCommands' hdle (return Nothing)
526 527

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

530 531
runGHCiInput :: InputT GHCi a -> GHCi a
runGHCiInput f = do
Ian Lynagh's avatar
Ian Lynagh committed
532
    dflags <- getDynFlags
ian@well-typed.com's avatar
ian@well-typed.com committed
533
    histFile <- if gopt Opt_GhciHistory dflags
Ian Lynagh's avatar
Ian Lynagh committed
534 535 536
                then liftIO $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
                                             (return Nothing)
                else return Nothing
dterei's avatar
dterei committed
537 538 539
    runInputT
        (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})
        f
540

541
-- | How to get the next input line from the user
542 543 544
nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
nextInputLine show_prompt is_tty
  | is_tty = do
dterei's avatar
dterei committed
545 546
    prmpt <- if show_prompt then lift mkPrompt else return ""
    r <- getInputLine prmpt
547 548
    incrementLineNo
    return r
549 550 551
  | otherwise = do
    when show_prompt $ lift mkPrompt >>= liftIO . putStr
    fileLoop stdin
552

553
-- NOTE: We only read .ghci files if they are owned by the current user,
dterei's avatar
dterei committed
554
-- and aren't world writable.  Otherwise, we could be accidentally
555 556
-- running code planted by a malicious third party.

rrt's avatar
rrt committed
557 558 559 560
-- 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.
561 562

checkPerms :: String -> IO Bool
563
#ifdef mingw32_HOST_OS
dterei's avatar
dterei committed
564
checkPerms _ = return True
sof's avatar
sof committed
565
#else
Simon Marlow's avatar
Simon Marlow committed
566
checkPerms name =
567
  handleIO (\_ -> return False) $ do
dterei's avatar
dterei committed
568 569 570 571 572 573 574 575
    st <- getFileStatus name
    me <- getRealUserID
    if fileOwner st /= me then do
        putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
        return False
     else do
        let mode = System.Posix.fileMode st
        if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
dterei's avatar
dterei committed
576
            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
dterei's avatar
dterei committed
577
            then do
dterei's avatar
dterei committed
578
                putStrLn $ "*** WARNING: " ++ name ++
dterei's avatar
dterei committed
579 580 581
                           " is writable by someone else, IGNORING!"
                return False
            else return True
sof's avatar
sof committed
582
#endif
583

584 585
incrementLineNo :: InputT GHCi ()
incrementLineNo = do
vivian's avatar
vivian committed
586 587 588 589 590
   st <- lift $ getGHCiState
   let ln = 1+(line_number st)
   lift $ setGHCiState st{line_number=ln}

fileLoop :: Handle -> InputT GHCi (Maybe String)
591
fileLoop hdl = do
592
   l <- liftIO $ tryIO $ hGetLine hdl
593
   case l of
594
        Left e | isEOFError e              -> return Nothing
595 596 597 598 599
               | -- 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
600
               | InvalidArgument <- etype  -> return Nothing
601
               | otherwise                 -> liftIO $ ioError e
602 603 604 605 606
                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
607
        Right l' -> do
608
           incrementLineNo
dterei's avatar
dterei committed
609
           return (Just l')
610

Simon Marlow's avatar
Simon Marlow committed
611
mkPrompt :: GHCi String
612
mkPrompt = do
613
  st <- getGHCiState
614
  imports <- GHC.getContext
615
  resumes <- GHC.getResumeContext
616 617 618 619

  context_bit <-
        case resumes of
            [] -> return empty
Simon Marlow's avatar
Simon Marlow committed
620
            r:_ -> do
621 622 623 624 625
                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
626 627 628
                        pan <- GHC.getHistorySpan hist
                        return (brackets (ppr (negate ix) <> char ':'
                                          <+> ppr pan) <> space)
629
  let
Simon Marlow's avatar
Simon Marlow committed
630
        dots | _:rs <- resumes, not (null rs) = text "... "
631 632
             | otherwise = empty

633 634
        rev_imports = reverse imports -- rightmost are the most recent
        modules_bit =
635
             hsep [ char '*' <> ppr m | IIModule m <- rev_imports ] <+>
636 637 638 639 640
             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)
641

642 643
        deflt_prompt = dots <> context_bit <> modules_bit

644
        f ('%':'l':xs) = ppr (1 + line_number st) <> f xs
645 646 647 648
        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
649

Ian Lynagh's avatar
Ian Lynagh committed
650 651
  dflags <- getDynFlags
  return (showSDoc dflags (f (prompt st)))
652

653

654 655 656 657 658 659 660 661
queryQueue :: GHCi (Maybe String)
queryQueue = do
  st <- getGHCiState
  case cmdqueue st of
    []   -> return Nothing
    c:cs -> do setGHCiState st{ cmdqueue = cs }
               return (Just c)

662 663 664 665 666 667
-- 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
668 669
                modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name 
                                      in he{hsc_IC = new_ic})
670 671 672 673
                return Succeeded

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

674
-- | The main read-eval-print loop
675
runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
676 677
runCommands = runCommands' handler

dterei's avatar
dterei committed
678
runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler
679
             -> InputT GHCi (Maybe String) -> InputT GHCi ()
dterei's avatar
dterei committed
680
runCommands' eh gCmd = do
681
    b <- ghandle (\e -> case fromException e of
vivian's avatar
vivian committed
682
                          Just UserInterrupt -> return $ Just False
683
                          _ -> case fromException e of
dterei's avatar
dterei committed
684 685
                                 Just ghce ->
                                   do liftIO (print (ghce :: GhcException))
vivian's avatar
vivian committed
686
                                      return Nothing
687 688
                                 _other ->
                                   liftIO (Exception.throwIO e))
dterei's avatar
dterei committed
689
            (runOneCommand eh gCmd)
vivian's avatar
vivian committed
690 691
    case b of
      Nothing -> return ()
dterei's avatar
dterei committed
692
      Just _  -> runCommands' eh gCmd
693

694
-- | Evaluate a single line of user input (either :<command> or Haskell code)
695
runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
vivian's avatar
vivian committed
696
            -> InputT GHCi (Maybe Bool)
dterei's avatar
dterei committed
697
runOneCommand eh gCmd = do
698 699
  -- run a previously queued command if there is one, otherwise get new
  -- input from user
dterei's avatar
dterei committed
700 701 702
  mb_cmd0 <- noSpace (lift queryQueue)
  mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0
  case mb_cmd1 of
vivian's avatar
vivian committed
703 704
    Nothing -> return Nothing
    Just c  -> ghciHandle (\e -> lift $ eh e >>= return . Just) $
705 706
             handleSourceError printErrorAndKeepGoing
               (doCommand c)
vivian's avatar
vivian committed
707 708
               -- source error's are handled by runStmt
               -- is the handler necessary here?
709
  where
710
    printErrorAndKeepGoing err = do
711
        GHC.printException err
vivian's avatar
vivian committed
712
        return $ Just True
713

714
    noSpace q = q >>= maybe (return Nothing)
dterei's avatar
dterei committed
715 716 717
                            (\c -> case removeSpaces c of
                                     ""   -> noSpace q
                                     ":{" -> multiLineCmd q
718
                                     c'   -> return (Just c') )
719
    multiLineCmd q = do
720
      st <- lift getGHCiState
721
      let p = prompt st
722
      lift $ setGHCiState st{ prompt = prompt2 st }
723
      mb_cmd <- collectCommand q ""
dterei's avatar
dterei committed
724
      lift $ getGHCiState >>= \st' -> setGHCiState st'{ prompt = p }
725
      return mb_cmd
dterei's avatar
dterei committed
726
    -- we can't use removeSpaces for the sublines here, so
727
    -- multiline commands are somewhat more brittle against
dterei's avatar
dterei committed
728 729
    -- fileformat errors (such as \r in dos input on unix),
    -- we get rid of any extra spaces for the ":}" test;
730
    -- we also avoid silent failure if ":}" is not found;
dterei's avatar
dterei committed
731
    -- and since there is no (?) valid occurrence of \r (as
732 733
    -- opposed to its String representation, "\r") inside a
    -- ghci command, we replace any such with ' ' (argh:-(
dterei's avatar
dterei committed
734
    collectCommand q c = q >>=
735
      maybe (liftIO (ioError collectError))
dterei's avatar
dterei committed
736 737
            (\l->if removeSpaces l == ":}"
                 then return (Just $ removeSpaces c)
738
                 else collectCommand q (c ++ "\n" ++ map normSpace l))
739
      where normSpace '\r' = ' '
dterei's avatar
dterei committed
740
            normSpace   x  = x
dterei's avatar
dterei committed
741
    -- SDM (2007-11-07): is userError the one to use here?
742
    collectError = userError "unterminated multiline command :{ .. :}"
743 744 745 746 747

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

    -- command
vivian's avatar
vivian committed
748 749 750 751 752
    doCommand (':' : cmd) = do
      result <- specialCommand cmd
      case result of
        True -> return Nothing
        _    -> return $ Just True
753 754 755

    -- haskell
    doCommand stmt = do
vivian's avatar
vivian committed
756 757
      ml <- lift $ isOptionSet Multiline
      if ml
dterei's avatar
dterei committed
758 759
        then do
          mb_stmt <- checkInputForLayout stmt gCmd
vivian's avatar
vivian committed
760 761 762 763 764 765 766 767 768 769 770
          case mb_stmt of
            Nothing      -> return $ Just True
            Just ml_stmt -> do
              result <- timeIt $ lift $ runStmt ml_stmt GHC.RunToCompletion
              return $ Just result
        else do
          result <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion
          return $ Just result

-- #4316
-- lex the input.  If there is an unclosed layout context, request input
vivian's avatar
vivian committed
771
checkInputForLayout :: String -> InputT GHCi (Maybe String)
vivian's avatar
vivian committed
772
                    -> InputT GHCi (Maybe String)
vivian's avatar
vivian committed
773
checkInputForLayout stmt getStmt = do
vivian's avatar
vivian committed
774 775
   dflags' <- lift $ getDynFlags
   let dflags = xopt_set dflags' Opt_AlternativeLayoutRule
dterei's avatar
dterei committed
776 777 778 779
   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
780 781 782
   case Lexer.unP goToEnd pstate of
     (Lexer.POk _ False) -> return $ Just stmt
     _other              -> do
dterei's avatar
dterei committed
783 784
       st1 <- lift getGHCiState
       let p = prompt st1
785
       lift $ setGHCiState st1{ prompt = prompt2 st1 }
vivian's avatar
vivian committed
786 787 788
       mb_stmt <- ghciHandle (\ex -> case fromException ex of
                            Just UserInterrupt -> return Nothing
                            _ -> case fromException ex of
dterei's avatar
dterei committed
789 790
                                 Just ghce ->
                                   do liftIO (print (ghce :: GhcException))
vivian's avatar
vivian committed
791
                                      return Nothing
dterei's avatar
dterei committed
792
                                 _other -> liftIO (Exception.throwIO ex))
vivian's avatar
vivian committed
793
                     getStmt
dterei's avatar
dterei committed
794
       lift $ getGHCiState >>= \st' -> setGHCiState st'{ prompt = p }
vivian's avatar
vivian committed
795 796 797 798 799 800
       -- 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
801 802
           else do
             checkInputForLayout (stmt++"\n"++str) getStmt
vivian's avatar
vivian committed
803 804
     where goToEnd = do
             eof <- Lexer.nextIsEOF
dterei's avatar
dterei committed
805
             if eof
vivian's avatar
vivian committed
806 807
               then Lexer.activeContext
               else Lexer.lexer return >> goToEnd
808 809 810 811 812 813

enqueueCommands :: [String] -> GHCi ()
enqueueCommands cmds = do
  st <- getGHCiState
  setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }

814 815 816
-- | If we one of these strings prefixes a command, then we treat it as a decl
-- rather than a stmt.
declPrefixes :: [String]
817
declPrefixes = ["class ","data ","newtype ","type ","instance ", "deriving ",
parcs's avatar
parcs committed
818
                "foreign ", "default ", "default("]
819

820
-- | Entry point to execute some haskell code from user
821 822
runStmt :: String -> SingleStep -> GHCi Bool
runStmt stmt step
823
 -- empty