InteractiveUI.hs 112 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
module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
13

14 15
#include "HsVersions.h"

dterei's avatar
dterei committed
16 17 18
-- GHCi
import qualified GhciMonad ( args, runStmt )
import GhciMonad hiding ( args, runStmt )
19
import GhciTags
20
import Debugger
21

22
-- The GHC interface
dterei's avatar
dterei committed
23
import DynFlags
dterei's avatar
dterei committed
24 25 26 27
import qualified GHC
import GHC ( LoadHowMuch(..), Target(..),  TargetId(..), InteractiveImport(..),
             TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,
             handleSourceError )
28
import HsImpExp
dterei's avatar
dterei committed
29
import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, dep_pkgs )
dterei's avatar
dterei committed
30
import Module
31
import Name
dterei's avatar
dterei committed
32 33 34
import Packages ( trusted, getPackageDetails, exposed, exposedModules, pkgIdMap )
import PprTyThing
import RdrName ( getGRE_NameQualifier_maybes )
35
import SrcLoc
dterei's avatar
dterei committed
36 37 38 39 40
import qualified Lexer

import StringBuffer
import UniqFM ( eltsUFM )
import Outputable hiding ( printForUser, printForUserPartWay, bold )
41 42

-- Other random utilities
dterei's avatar
dterei committed
43
import BasicTypes hiding ( isTopLevel )
44
import Config
dterei's avatar
dterei committed
45 46 47
import Digraph
import Encoding
import FastString
48
import Linker
dterei's avatar
dterei committed
49
import Maybes ( orElse, expectJust )
dterei's avatar
dterei committed
50 51 52
import NameSet
import Panic hiding ( showException )
import StaticFlags
53
import Util
sof's avatar
sof committed
54

dterei's avatar
dterei committed
55
-- Haskell Libraries
56
import System.Console.Haskeline as Haskeline
57

dterei's avatar
dterei committed
58 59
import Control.Applicative hiding (empty)
import Control.Monad as Monad
60 61
import Control.Monad.Trans.Class
import Control.Monad.IO.Class
62

dterei's avatar
dterei committed
63
import Data.Array
Simon Marlow's avatar
Simon Marlow committed
64
import qualified Data.ByteString.Char8 as BS
dterei's avatar
dterei committed
65 66 67 68
import Data.Char
import Data.IORef ( IORef, readIORef, writeIORef )
import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,
                   partition, sort, sortBy )
69
import Data.Maybe
dterei's avatar
dterei committed
70

71
import Exception hiding (catch)
dterei's avatar
dterei committed
72 73 74 75

import Foreign.C
import Foreign.Safe

76
import System.Cmd
dterei's avatar
dterei committed
77
import System.Directory
78
import System.Environment
dterei's avatar
dterei committed
79
import System.Exit ( exitWith, ExitCode(..) )
dterei's avatar
dterei committed
80
import System.FilePath
ross's avatar
ross committed
81
import System.IO
82
import System.IO.Error
dterei's avatar
dterei committed
83
import System.IO.Unsafe ( unsafePerformIO )
Simon Marlow's avatar
Simon Marlow committed
84
import Text.Printf
85

dterei's avatar
dterei committed
86 87 88 89 90 91 92
#ifndef mingw32_HOST_OS
import System.Posix hiding ( getEnv )
#else
import qualified System.Win32
#endif

import GHC.Exts ( unsafeCoerce# )
dterei's avatar
dterei committed
93 94
import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
import GHC.IO.Handle ( hFlushAll )
dterei's avatar
dterei committed
95
import GHC.TopHandler ( topHandler )
96

97

98 99
-----------------------------------------------------------------------------

100 101 102
ghciWelcomeMsg :: String
ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
                 ": http://www.haskell.org/ghc/  :? for help"
103

Simon Marlow's avatar
Simon Marlow committed
104
cmdName :: Command -> String
105
cmdName (n,_,_) = n
106

Simon Marlow's avatar
Simon Marlow committed
107
GLOBAL_VAR(macros_ref, [], [Command])
Simon Marlow's avatar
Simon Marlow committed
108 109

builtin_commands :: [Command]
110
builtin_commands = [
111 112 113 114 115 116 117 118 119 120 121 122
  -- 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),
123 124
  ("ctags",     keepGoing createCTagsWithLineNumbersCmd, completeFilename),
  ("ctags!",    keepGoing createCTagsWithRegExesCmd, completeFilename),
125 126 127
  ("def",       keepGoing (defineMacro False),  completeExpression),
  ("def!",      keepGoing (defineMacro True),   completeExpression),
  ("delete",    keepGoing deleteCmd,            noCompletion),
128
  ("edit",      keepGoing' editFile,            completeFilename),
129 130 131 132 133 134
  ("etags",     keepGoing createETagsFileCmd,   completeFilename),
  ("force",     keepGoing forceCmd,             completeExpression),
  ("forward",   keepGoing forwardCmd,           noCompletion),
  ("help",      keepGoing help,                 noCompletion),
  ("history",   keepGoing historyCmd,           noCompletion),
  ("info",      keepGoing' info,                completeIdentifier),
135
  ("issafe",    keepGoing' isSafeCmd,           completeModule),
136 137
  ("kind",      keepGoing' (kindOfType False),  completeIdentifier),
  ("kind!",     keepGoing' (kindOfType True),   completeIdentifier),
138 139
  ("load",      keepGoingPaths loadModule_,     completeHomeModuleOrFile),
  ("list",      keepGoing' listCmd,             noCompletion),
140
  ("module",    keepGoing moduleCmd,            completeSetModule),
141 142 143 144 145
  ("main",      keepGoing runMain,              completeFilename),
  ("print",     keepGoing printCmd,             completeExpression),
  ("quit",      quit,                           noCompletion),
  ("reload",    keepGoing' reloadModule,        noCompletion),
  ("run",       keepGoing runRun,               completeFilename),
vivian's avatar
vivian committed
146
  ("script",    keepGoing' scriptCmd,           completeFilename),
147
  ("set",       keepGoing setCmd,               completeSetOptions),
148
  ("seti",      keepGoing setiCmd,              completeSeti),
149
  ("show",      keepGoing showCmd,              completeShowOptions),
150
  ("showi",     keepGoing showiCmd,             completeShowiOptions),
151 152 153 154 155 156 157 158
  ("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)
159 160
  ]

161

dterei's avatar
dterei committed
162
-- We initialize readline (in the interactiveUI function) to use
163 164 165 166
-- 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
167
--
168 169
-- NOTE: in order for us to override the default correctly, any custom entry
-- must be a SUBSET of word_break_chars.
170
word_break_chars :: String
171 172 173 174
word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
                       specials = "(),;[]`{}"
                       spaces = " \t\n"
                   in spaces ++ specials ++ symbols
175

176
flagWordBreakChars :: String
177 178 179
flagWordBreakChars = " \t\n"


180 181 182 183 184
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
185

186
keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
Ian Lynagh's avatar
Ian Lynagh committed
187 188
keepGoingPaths a str
 = do case toArgs str of
Ian Lynagh's avatar
Ian Lynagh committed
189
          Left err -> liftIO $ hPutStrLn stderr err
Ian Lynagh's avatar
Ian Lynagh committed
190 191
          Right args -> a args
      return False
sof's avatar
sof committed
192

Simon Marlow's avatar
Simon Marlow committed
193
shortHelpText :: String
194 195
shortHelpText = "use :? for help.\n"

Simon Marlow's avatar
Simon Marlow committed
196
helpText :: String
197
helpText =
dterei's avatar
dterei committed
198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223
  " 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" ++
  "   :ctags[!] [<file>]          create tags file for Vi (default: \"tags\")\n" ++
  "                               (!: use regex instead of line number)\n" ++
  "   :def <cmd> <expr>           define a command :<cmd>\n" ++
  "   :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" ++
  "   :info [<name> ...]          display information about the given names\n" ++
  "   :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" ++
224
  "   :script <filename>          run the script <filename>\n" ++
dterei's avatar
dterei committed
225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251
  "   :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
252

dterei's avatar
dterei committed
253 254 255 256
  "\n" ++
  " -- Commands for changing settings:\n" ++
  "\n" ++
  "   :set <option> ...           set options\n" ++
257
  "   :seti <option> ...          set options for interactive evaluation only\n" ++
dterei's avatar
dterei committed
258 259 260 261 262 263 264 265 266
  "   :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" ++
  "   :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
267
  "    +m            allow multiline commands\n" ++
dterei's avatar
dterei committed
268 269 270 271 272 273 274 275 276 277 278 279 280
  "    +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" ++
281
  "   :show imports               show the current imports\n" ++
dterei's avatar
dterei committed
282 283
  "   :show modules               show the currently loaded modules\n" ++
  "   :show packages              show the currently active package flags\n" ++
284
  "   :show language              show the currently active language flags\n" ++
dterei's avatar
dterei committed
285 286
  "   :show <setting>             show value of <setting>, which is one of\n" ++
  "                                  [args, prog, prompt, editor, stop]\n" ++
287
  "   :showi language             show language flags for interactive evaluation\n" ++
dterei's avatar
dterei committed
288
  "\n"
289

Simon Marlow's avatar
Simon Marlow committed
290
findEditor :: IO String
Simon Marlow's avatar
Simon Marlow committed
291
findEditor = do
dterei's avatar
dterei committed
292
  getEnv "EDITOR"
293
    `catchIO` \_ -> do
294
#if mingw32_HOST_OS
Ian Lynagh's avatar
Ian Lynagh committed
295 296
        win <- System.Win32.getWindowsDirectory
        return (win </> "notepad.exe")
Simon Marlow's avatar
Simon Marlow committed
297
#else
Ian Lynagh's avatar
Ian Lynagh committed
298
        return ""
Simon Marlow's avatar
Simon Marlow committed
299 300
#endif

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

Simon Marlow's avatar
Simon Marlow committed
303
default_progname, default_prompt, default_stop :: String
Boris Lykah's avatar
Boris Lykah committed
304 305 306 307
default_progname = "<interactive>"
default_prompt = "%s> "
default_stop = ""

Simon Marlow's avatar
Simon Marlow committed
308 309 310
default_args :: [String]
default_args = []

311 312
interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String]
              -> Ghc ()
313
interactiveUI srcs maybe_exprs = do
314 315 316
   -- 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
317
   i <- liftIO $ isProfiled
dterei's avatar
dterei committed
318
   when (i /= 0) $
319 320
     ghcError (InstallationError "GHCi cannot be used when compiled with -prof")

321 322 323 324 325 326 327 328
   -- 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.
329 330 331
   _ <- liftIO $ newStablePtr stdin
   _ <- liftIO $ newStablePtr stdout
   _ <- liftIO $ newStablePtr stderr
332

Ian Lynagh's avatar
Ian Lynagh committed
333
    -- Initialise buffering for the *interpreted* I/O system
334
   initInterpBuffering
335

336 337 338 339 340
   -- The initial set of DynFlags used for interactive evaluation is the same
   -- as the global DynFlags, plus -XExtendedDefaultRules
   dflags <- getDynFlags
   GHC.setInteractiveDynFlags (xopt_set dflags Opt_ExtendedDefaultRules)

341
   liftIO $ when (isNothing maybe_exprs) $ do
Ian Lynagh's avatar
Ian Lynagh committed
342 343 344 345 346 347 348 349 350 351
        -- 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
352
#if defined(mingw32_HOST_OS)
353 354 355 356 357
        -- 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
358

359
   default_editor <- liftIO $ findEditor
Simon Marlow's avatar
Simon Marlow committed
360

Ian Lynagh's avatar
Ian Lynagh committed
361
   startGHCi (runGHCi srcs maybe_exprs)
dterei's avatar
dterei committed
362 363 364 365 366 367 368 369 370 371 372 373
        GHCiState{ progname       = default_progname,
                   GhciMonad.args = default_args,
                   prompt         = default_prompt,
                   stop           = default_stop,
                   editor         = default_editor,
                   options        = [],
                   line_number    = 1,
                   break_ctr      = 0,
                   breaks         = [],
                   tickarrays     = emptyModuleEnv,
                   last_command   = Nothing,
                   cmdqueue       = [],
mnislaih's avatar
mnislaih committed
374
                   remembered_ctx = [],
dterei's avatar
dterei committed
375 376
                   transient_ctx  = [],
                   ghc_e          = isJust maybe_exprs
mnislaih's avatar
mnislaih committed
377
                 }
rrt's avatar
rrt committed
378

379 380
   return ()

381 382
withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
withGhcAppData right left = do
383
    either_dir <- tryIO (getAppUserDataDirectory "ghc")
384 385 386 387 388
    case either_dir of
        Right dir ->
            do createDirectoryIfMissing False dir `catchIO` \_ -> return ()
               right dir
        _ -> left
389

Ian Lynagh's avatar
Ian Lynagh committed
390 391
runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
runGHCi paths maybe_exprs = do
392
  let
393
   read_dot_files = not opt_IgnoreDotGhci
394

395 396
   current_dir = return (Just ".ghci")

Ian Lynagh's avatar
Ian Lynagh committed
397
   app_user_dir = liftIO $ withGhcAppData
398 399
                    (\dir -> return (Just (dir </> "ghci.conf")))
                    (return Nothing)
400 401

   home_dir = do
402
    either_dir <- liftIO $ tryIO (getEnv "HOME")
403 404 405 406
    case either_dir of
      Right home -> return (Just (home </> ".ghci"))
      _ -> return Nothing

407 408 409 410
   canonicalizePath' :: FilePath -> IO (Maybe FilePath)
   canonicalizePath' fp = liftM Just (canonicalizePath fp)
                `catchIO` \_ -> return Nothing

411 412
   sourceConfigFile :: FilePath -> GHCi ()
   sourceConfigFile file = do
Ian Lynagh's avatar
Ian Lynagh committed
413
     exists <- liftIO $ doesFileExist file
414
     when exists $ do
Ian Lynagh's avatar
Ian Lynagh committed
415 416
       dir_ok  <- liftIO $ checkPerms (getDirectory file)
       file_ok <- liftIO $ checkPerms file
417
       when (dir_ok && file_ok) $ do
418
         either_hdl <- liftIO $ tryIO (openFile file ReadMode)
419 420
         case either_hdl of
           Left _e   -> return ()
421 422 423
           -- 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.
424 425
           Right hdl ->
               do runInputTWithPrefs defaultPrefs defaultSettings $
426
                            runCommands $ fileLoop hdl
427
                  liftIO (hClose hdl `catchIO` \_ -> return ())
428 429
     where
      getDirectory f = case takeDirectory f of "" -> "."; d -> d
430 431
  --

432
  setGHCContextFromGHCiState
Ian Lynagh's avatar
Ian Lynagh committed
433

434
  dflags <- getDynFlags
435
  when (read_dot_files) $ do
436
    mcfgs0 <- sequence $ [ current_dir, app_user_dir, home_dir ] ++ map (return . Just ) (ghciScripts dflags)
Ian Lynagh's avatar
Ian Lynagh committed
437
    mcfgs <- liftIO $ mapM canonicalizePath' (catMaybes mcfgs0)
438
    mapM_ sourceConfigFile $ nub $ catMaybes mcfgs
439 440
        -- nub, because we don't want to read .ghci twice if the
        -- CWD is $HOME.
441

442
  -- Perform a :load for files given on the GHCi command line
443 444 445
  -- 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
446
     ok <- ghciHandle (\e -> do showException e; return Failed) $
447
                -- TODO: this is a hack.
448 449
                runInputTWithPrefs defaultPrefs defaultSettings $
                    loadModule paths
Ian Lynagh's avatar
Ian Lynagh committed
450
     when (isJust maybe_exprs && failed ok) $
Ian Lynagh's avatar
Ian Lynagh committed
451
        liftIO (exitWith (ExitFailure 1))
452

453 454
  -- 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
455
  is_tty <- liftIO (hIsTerminalDevice stdin)
456 457
  let show_prompt = verbosity dflags > 0 || is_tty

458 459 460
  -- reset line number
  getGHCiState >>= \st -> setGHCiState st{line_number=1}

Ian Lynagh's avatar
Ian Lynagh committed
461
  case maybe_exprs of
Ian Lynagh's avatar
Ian Lynagh committed
462
        Nothing ->
sof's avatar
sof committed
463
          do
Ian Lynagh's avatar
Ian Lynagh committed
464
            -- enter the interactive loop
465
            runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
Ian Lynagh's avatar
Ian Lynagh committed
466
        Just exprs -> do
Ian Lynagh's avatar
Ian Lynagh committed
467
            -- just evaluate the expression we were given
Ian Lynagh's avatar
Ian Lynagh committed
468
            enqueueCommands exprs
dterei's avatar
dterei committed
469 470 471 472 473 474 475 476
            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
477
                                   -- this used to be topHandlerFastExit, see #2228
478
            runInputTWithPrefs defaultPrefs defaultSettings $ do
dterei's avatar
dterei committed
479
                runCommands' hdle (return Nothing)
480 481

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

484 485
runGHCiInput :: InputT GHCi a -> GHCi a
runGHCiInput f = do
Ian Lynagh's avatar
Ian Lynagh committed
486 487 488 489 490
    dflags <- getDynFlags
    histFile <- if dopt Opt_GhciHistory dflags
                then liftIO $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
                                             (return Nothing)
                else return Nothing
dterei's avatar
dterei committed
491 492 493
    runInputT
        (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})
        f
494

495
-- | How to get the next input line from the user
496 497 498
nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
nextInputLine show_prompt is_tty
  | is_tty = do
dterei's avatar
dterei committed
499 500
    prmpt <- if show_prompt then lift mkPrompt else return ""
    r <- getInputLine prmpt
501 502
    incrementLineNo
    return r
503 504 505
  | otherwise = do
    when show_prompt $ lift mkPrompt >>= liftIO . putStr
    fileLoop stdin
506

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

rrt's avatar
rrt committed
511 512 513 514
-- 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.
515 516

checkPerms :: String -> IO Bool
517
#ifdef mingw32_HOST_OS
dterei's avatar
dterei committed
518
checkPerms _ = return True
sof's avatar
sof committed
519
#else
Simon Marlow's avatar
Simon Marlow committed
520
checkPerms name =
521
  handleIO (\_ -> return False) $ do
dterei's avatar
dterei committed
522 523 524 525 526 527 528 529
    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
530
            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
dterei's avatar
dterei committed
531
            then do
dterei's avatar
dterei committed
532
                putStrLn $ "*** WARNING: " ++ name ++
dterei's avatar
dterei committed
533 534 535
                           " is writable by someone else, IGNORING!"
                return False
            else return True
sof's avatar
sof committed
536
#endif
537

538 539
incrementLineNo :: InputT GHCi ()
incrementLineNo = do
vivian's avatar
vivian committed
540 541 542 543 544
   st <- lift $ getGHCiState
   let ln = 1+(line_number st)
   lift $ setGHCiState st{line_number=ln}

fileLoop :: Handle -> InputT GHCi (Maybe String)
545
fileLoop hdl = do
546
   l <- liftIO $ tryIO $ hGetLine hdl
547
   case l of
548 549
        Left e | isEOFError e              -> return Nothing
               | InvalidArgument <- etype  -> return Nothing
550
               | otherwise                 -> liftIO $ ioError e
551 552 553 554 555
                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
556
        Right l' -> do
557
           incrementLineNo
dterei's avatar
dterei committed
558
           return (Just l')
559

Simon Marlow's avatar
Simon Marlow committed
560
mkPrompt :: GHCi String
561
mkPrompt = do
562
  imports <- GHC.getContext
563
  resumes <- GHC.getResumeContext
564 565 566 567

  context_bit <-
        case resumes of
            [] -> return empty
Simon Marlow's avatar
Simon Marlow committed
568
            r:_ -> do
569 570 571 572 573
                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
574 575 576
                        pan <- GHC.getHistorySpan hist
                        return (brackets (ppr (negate ix) <> char ':'
                                          <+> ppr pan) <> space)
577
  let
Simon Marlow's avatar
Simon Marlow committed
578
        dots | _:rs <- resumes, not (null rs) = text "... "
579 580
             | otherwise = empty

581 582
        rev_imports = reverse imports -- rightmost are the most recent
        modules_bit =
583
             hsep [ char '*' <> ppr m | IIModule m <- rev_imports ] <+>
584 585 586 587 588
             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)
589

590 591 592 593 594 595
        deflt_prompt = dots <> context_bit <> modules_bit

        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
596

597 598
  st <- getGHCiState
  return (showSDoc (f (prompt st)))
599

600

601 602 603 604 605 606 607 608
queryQueue :: GHCi (Maybe String)
queryQueue = do
  st <- getGHCiState
  case cmdqueue st of
    []   -> return Nothing
    c:cs -> do setGHCiState st{ cmdqueue = cs }
               return (Just c)

609
-- | The main read-eval-print loop
610
runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
611 612
runCommands = runCommands' handler

dterei's avatar
dterei committed
613
runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler
614
             -> InputT GHCi (Maybe String) -> InputT GHCi ()
dterei's avatar
dterei committed
615
runCommands' eh gCmd = do
616
    b <- ghandle (\e -> case fromException e of
vivian's avatar
vivian committed
617
                          Just UserInterrupt -> return $ Just False
618
                          _ -> case fromException e of
dterei's avatar
dterei committed
619 620
                                 Just ghce ->
                                   do liftIO (print (ghce :: GhcException))
vivian's avatar
vivian committed
621
                                      return Nothing
622 623
                                 _other ->
                                   liftIO (Exception.throwIO e))
dterei's avatar
dterei committed
624
            (runOneCommand eh gCmd)
vivian's avatar
vivian committed
625 626
    case b of
      Nothing -> return ()
dterei's avatar
dterei committed
627
      Just _  -> runCommands' eh gCmd
628

629
-- | Evaluate a single line of user input (either :<command> or Haskell code)
630
runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
vivian's avatar
vivian committed
631
            -> InputT GHCi (Maybe Bool)
dterei's avatar
dterei committed
632
runOneCommand eh gCmd = do
633 634
  -- run a previously queued command if there is one, otherwise get new
  -- input from user
dterei's avatar
dterei committed
635 636 637
  mb_cmd0 <- noSpace (lift queryQueue)
  mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0
  case mb_cmd1 of
vivian's avatar
vivian committed
638 639
    Nothing -> return Nothing
    Just c  -> ghciHandle (\e -> lift $ eh e >>= return . Just) $
640 641
             handleSourceError printErrorAndKeepGoing
               (doCommand c)
vivian's avatar
vivian committed
642 643
               -- source error's are handled by runStmt
               -- is the handler necessary here?
644
  where
645
    printErrorAndKeepGoing err = do
646
        GHC.printException err
vivian's avatar
vivian committed
647
        return $ Just True
648

649
    noSpace q = q >>= maybe (return Nothing)
dterei's avatar
dterei committed
650 651 652
                            (\c -> case removeSpaces c of
                                     ""   -> noSpace q
                                     ":{" -> multiLineCmd q
653
                                     c'   -> return (Just c') )
654
    multiLineCmd q = do
655
      st <- lift getGHCiState
656
      let p = prompt st
657
      lift $ setGHCiState st{ prompt = "%s| " }
658
      mb_cmd <- collectCommand q ""
dterei's avatar
dterei committed
659
      lift $ getGHCiState >>= \st' -> setGHCiState st'{ prompt = p }
660
      return mb_cmd
dterei's avatar
dterei committed
661
    -- we can't use removeSpaces for the sublines here, so
662
    -- multiline commands are somewhat more brittle against
dterei's avatar
dterei committed
663 664
    -- fileformat errors (such as \r in dos input on unix),
    -- we get rid of any extra spaces for the ":}" test;
665
    -- we also avoid silent failure if ":}" is not found;
dterei's avatar
dterei committed
666
    -- and since there is no (?) valid occurrence of \r (as
667 668
    -- opposed to its String representation, "\r") inside a
    -- ghci command, we replace any such with ' ' (argh:-(
dterei's avatar
dterei committed
669
    collectCommand q c = q >>=
670
      maybe (liftIO (ioError collectError))
dterei's avatar
dterei committed
671 672
            (\l->if removeSpaces l == ":}"
                 then return (Just $ removeSpaces c)
673
                 else collectCommand q (c ++ "\n" ++ map normSpace l))
674
      where normSpace '\r' = ' '
dterei's avatar
dterei committed
675
            normSpace   x  = x
dterei's avatar
dterei committed
676
    -- SDM (2007-11-07): is userError the one to use here?
677
    collectError = userError "unterminated multiline command :{ .. :}"
678 679 680 681 682

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

    -- command
vivian's avatar
vivian committed
683 684 685 686 687
    doCommand (':' : cmd) = do
      result <- specialCommand cmd
      case result of
        True -> return Nothing
        _    -> return $ Just True
688 689 690

    -- haskell
    doCommand stmt = do
vivian's avatar
vivian committed
691 692
      ml <- lift $ isOptionSet Multiline
      if ml
dterei's avatar
dterei committed
693 694
        then do
          mb_stmt <- checkInputForLayout stmt gCmd
vivian's avatar
vivian committed
695 696 697 698 699 700 701 702 703 704 705
          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
706
checkInputForLayout :: String -> InputT GHCi (Maybe String)
vivian's avatar
vivian committed
707
                    -> InputT GHCi (Maybe String)
vivian's avatar
vivian committed
708
checkInputForLayout stmt getStmt = do
vivian's avatar
vivian committed
709 710
   dflags' <- lift $ getDynFlags
   let dflags = xopt_set dflags' Opt_AlternativeLayoutRule
dterei's avatar
dterei committed
711 712 713 714
   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
715 716 717
   case Lexer.unP goToEnd pstate of
     (Lexer.POk _ False) -> return $ Just stmt
     _other              -> do
dterei's avatar
dterei committed
718 719 720
       st1 <- lift getGHCiState
       let p = prompt st1
       lift $ setGHCiState st1{ prompt = "%s| " }
vivian's avatar
vivian committed
721 722 723
       mb_stmt <- ghciHandle (\ex -> case fromException ex of
                            Just UserInterrupt -> return Nothing
                            _ -> case fromException ex of
dterei's avatar
dterei committed
724 725
                                 Just ghce ->
                                   do liftIO (print (ghce :: GhcException))
vivian's avatar
vivian committed
726
                                      return Nothing
dterei's avatar
dterei committed
727
                                 _other -> liftIO (Exception.throwIO ex))
vivian's avatar
vivian committed
728
                     getStmt
dterei's avatar
dterei committed
729
       lift $ getGHCiState >>= \st' -> setGHCiState st'{ prompt = p }
vivian's avatar
vivian committed
730 731 732 733 734 735
       -- 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
736 737
           else do
             checkInputForLayout (stmt++"\n"++str) getStmt
vivian's avatar
vivian committed
738 739
     where goToEnd = do
             eof <- Lexer.nextIsEOF
dterei's avatar
dterei committed
740
             if eof
vivian's avatar
vivian committed
741 742
               then Lexer.activeContext
               else Lexer.lexer return >> goToEnd
743 744 745 746 747 748

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

749 750 751
-- | If we one of these strings prefixes a command, then we treat it as a decl
-- rather than a stmt.
declPrefixes :: [String]
752 753
declPrefixes = ["class ","data ","newtype ","type ","instance ", "deriving ",
                "foreign "]
754

755
-- | Entry point to execute some haskell code from user
756 757
runStmt :: String -> SingleStep -> GHCi Bool
runStmt stmt step
758
 -- empty
759 760
 | null (filter (not.isSpace) stmt)
 = return False
761 762

 -- import
763
 | "import " `isPrefixOf` stmt
764
 = do addImportToContext stmt; return False
765 766

 -- data, class, newtype...
767 768 769 770
 | any (flip isPrefixOf stmt) declPrefixes
 = do _ <- liftIO $ tryIO $ hFlushAll stdin
      result <- GhciMonad.runDecls stmt
      afterRunStmt (const True) (GHC.RunOk result)
771

772
 | otherwise
773
 = do -- In the new IO library, read handles buffer data even if the Handle
774 775 776 777
      -- is set to NoBuffering.  This causes problems for GHCi where there
      -- are really two stdin Handles.  So we flush any bufferred data in
      -- GHCi's stdin Handle here (only relevant if stdin is attached to
      -- a file, otherwise the read buffer can't be flushed).
778
      _ <- liftIO $ tryIO $ hFlushAll stdin
779 780 781 782
      m_result <- GhciMonad.runStmt stmt step
      case m_result of
        Nothing     -> return False
        Just result -> afterRunStmt (const True) result
783

784
-- | Clean up the GHCi environment after a statement has run
Simon Marlow's avatar
Simon Marlow committed
785
afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
786
afterRunStmt _ (GHC.RunException e) = throw e
787
afterRunStmt step_here run_result = do
788
  resumes <- GHC.getResumeContext
Simon Marlow's avatar
Simon Marlow committed
789 790 791
  case run_result of
     GHC.RunOk names -> do
        show_types <- isOptionSet ShowType
792
        when show_types $ printTypeOfNames names
793 794
     GHC.RunBreak _ names mb_info
         | isNothing  mb_info ||
795
           step_here (GHC.resumeSpan $ head resumes) -> do
796
               mb_id_loc <- toBreakIdAndLocation mb_info
dterei's avatar
dterei committed
797 798
               let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
               if (null bCmd)
799
                 then printStoppedAtBreakInfo (head resumes) names
dterei's avatar
dterei committed
800
                 else enqueueCommands [bCmd]
801 802 803 804
               -- run the command set with ":set stop <cmd>"
               st <- getGHCiState
               enqueueCommands [stop st]
               return ()
805
         | otherwise -> resume step_here GHC.SingleStep >>=
806
                        afterRunStmt step_here >> return ()
Simon Marlow's avatar
Simon Marlow committed