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

Ian Lynagh's avatar
Ian Lynagh committed
4
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
5 6 7 8
-----------------------------------------------------------------------------
--
-- GHC Interactive User Interface
--
9
-- (c) The GHC Team 2005-2006
10 11
--
-----------------------------------------------------------------------------
12

13
module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
14

15 16
#include "HsVersions.h"

mnislaih's avatar
mnislaih committed
17 18
import qualified GhciMonad
import GhciMonad hiding (runStmt)
19
import GhciTags
20
import Debugger
21

22
-- The GHC interface
mnislaih's avatar
mnislaih committed
23
import qualified GHC hiding (resume, runStmt)
24
import GHC              ( LoadHowMuch(..), Target(..),  TargetId(..),
25 26
                          TyThing(..), Phase,
                          BreakIndex, Resume, SingleStep,
27
                          Ghc, handleSourceError )
28
import PprTyThing
29
import DynFlags
30

31
import Packages
32
-- import PackageConfig
33
import UniqFM
34

35
import HscTypes ( handleFlagWarnings )
36
import HsImpExp
37
import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
38
import RdrName (RdrName)
39
import Outputable       hiding (printForUser, printForUserPartWay)
40
import Module           -- for ModuleEnv
41
import Name
42
import SrcLoc
43 44

-- Other random utilities
45
import CmdLineParser
46
import Digraph
mnislaih's avatar
mnislaih committed
47 48
import BasicTypes hiding (isTopLevel)
import Panic      hiding (showException)
49
import Config
50 51 52
import StaticFlags
import Linker
import Util
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
53
import NameSet
54
import Maybes		( orElse, expectJust )
55
import FastString
56
import Encoding
57 58
import Foreign.C

59
#ifndef mingw32_HOST_OS
60
import System.Posix hiding (getEnv)
sof's avatar
sof committed
61
#else
62
import qualified System.Win32
sof's avatar
sof committed
63 64
#endif

65 66 67
import System.Console.Haskeline as Haskeline
import qualified System.Console.Haskeline.Encoding as Encoding
import Control.Monad.Trans
68 69 70

--import SystemExts

71 72
import Exception hiding (catch, block, unblock)

73
-- import Control.Concurrent
74

75
import System.FilePath
Simon Marlow's avatar
Simon Marlow committed
76
import qualified Data.ByteString.Char8 as BS
77
import Data.List
78
import Data.Maybe
79 80
import System.Cmd
import System.Environment
81
import System.Exit	( exitWith, ExitCode(..) )
82
import System.Directory
ross's avatar
ross committed
83 84
import System.IO
import System.IO.Error as IO
85
import Data.Char
86
import Data.Array
87
import Control.Monad as Monad
Simon Marlow's avatar
Simon Marlow committed
88
import Text.Printf
89
import Foreign
90
import GHC.Exts		( unsafeCoerce# )
91 92 93

#if __GLASGOW_HASKELL__ >= 611
import GHC.IO.Exception	( IOErrorType(InvalidArgument) )
94
import GHC.IO.Handle    ( hFlushAll )
95
#else
Simon Marlow's avatar
Simon Marlow committed
96
import GHC.IOBase	( IOErrorType(InvalidArgument) )
97 98
#endif

Ian Lynagh's avatar
Ian Lynagh committed
99
import GHC.TopHandler
100

101
import Data.IORef	( IORef, readIORef, writeIORef )
102

103 104
-----------------------------------------------------------------------------

105 106 107
ghciWelcomeMsg :: String
ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
                 ": http://www.haskell.org/ghc/  :? for help"
108

Simon Marlow's avatar
Simon Marlow committed
109
cmdName :: Command -> String
110
cmdName (n,_,_) = n
111

Simon Marlow's avatar
Simon Marlow committed
112
GLOBAL_VAR(macros_ref, [], [Command])
Simon Marlow's avatar
Simon Marlow committed
113 114

builtin_commands :: [Command]
115
builtin_commands = [
116 117 118 119 120 121 122 123 124 125 126 127
  -- 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),
128 129
  ("ctags",     keepGoing createCTagsWithLineNumbersCmd, completeFilename),
  ("ctags!",    keepGoing createCTagsWithRegExesCmd, completeFilename),
130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158
  ("def",       keepGoing (defineMacro False),  completeExpression),
  ("def!",      keepGoing (defineMacro True),   completeExpression),
  ("delete",    keepGoing deleteCmd,            noCompletion),
  ("edit",      keepGoing editFile,             completeFilename),
  ("etags",     keepGoing createETagsFileCmd,   completeFilename),
  ("force",     keepGoing forceCmd,             completeExpression),
  ("forward",   keepGoing forwardCmd,           noCompletion),
  ("help",      keepGoing help,                 noCompletion),
  ("history",   keepGoing historyCmd,           noCompletion),
  ("info",      keepGoing' info,                completeIdentifier),
  ("kind",      keepGoing' kindOfType,          completeIdentifier),
  ("load",      keepGoingPaths loadModule_,     completeHomeModuleOrFile),
  ("list",      keepGoing' listCmd,             noCompletion),
  ("module",    keepGoing setContext,           completeModule),
  ("main",      keepGoing runMain,              completeFilename),
  ("print",     keepGoing printCmd,             completeExpression),
  ("quit",      quit,                           noCompletion),
  ("reload",    keepGoing' reloadModule,        noCompletion),
  ("run",       keepGoing runRun,               completeFilename),
  ("set",       keepGoing setCmd,               completeSetOptions),
  ("show",      keepGoing showCmd,              completeShowOptions),
  ("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 162 163 164 165 166 167 168 169

-- We initialize readline (in the interactiveUI function) to use 
-- 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.
-- 
-- 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
189
          Left err -> Encoding.encode err >>= liftIO . BS.hPutStrLn stderr
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 198 199
helpText =
 " Commands available from the prompt:\n" ++
 "\n" ++
200
 "   <statement>                 evaluate/run <statement>\n" ++
201
 "   :                           repeat last command\n" ++
202
 "   :{\\n ..lines.. \\n:}\\n       multiline command\n" ++
Simon Marlow's avatar
Simon Marlow committed
203
 "   :add [*]<module> ...        add module(s) to the current target set\n" ++
204 205
 "   :browse[!] [[*]<mod>]       display the names defined by module <mod>\n" ++
 "                               (!: more details; *: all top-level names)\n" ++
206
 "   :cd <dir>                   change directory to <dir>\n" ++
207
 "   :cmd <expr>                 run the commands returned by <expr>::IO String\n" ++
208 209
 "   :ctags[!] [<file>]          create tags file for Vi (default: \"tags\")\n" ++
 "                               (!: use regex instead of line number)\n" ++
210
 "   :def <cmd> <expr>           define a command :<cmd>\n" ++
Simon Marlow's avatar
Simon Marlow committed
211 212
 "   :edit <file>                edit file\n" ++
 "   :edit                       edit last module\n" ++
Simon Marlow's avatar
Simon Marlow committed
213
 "   :etags [<file>]             create tags file for Emacs (default: \"TAGS\")\n" ++
214 215
 "   :help, :?                   display this list of commands\n" ++
 "   :info [<name> ...]          display information about the given names\n" ++
Simon Marlow's avatar
Simon Marlow committed
216
 "   :kind <type>                show the kind of <type>\n" ++
Simon Marlow's avatar
Simon Marlow committed
217
 "   :load [*]<module> ...       load module(s) and their dependents\n" ++
218
 "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
219
 "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
Simon Marlow's avatar
Simon Marlow committed
220
 "   :quit                       exit GHCi\n" ++
221
 "   :reload                     reload the current module set\n" ++
Ian Lynagh's avatar
Ian Lynagh committed
222
 "   :run function [<arguments> ...] run the function with the given arguments\n" ++
223 224 225 226 227 228 229 230 231 232 233 234 235 236 237
 "   :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" ++
238
 "   :history [<n>]              after :trace, show the execution history\n" ++
239 240 241
 "   :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" ++
242
 "   :print [<name> ...]         prints a value without forcing its computation\n" ++
Simon Marlow's avatar
Simon Marlow committed
243
 "   :sprint [<name> ...]        simplifed version of :print\n" ++
244 245
 "   :step                       single-step after stopping at a breakpoint\n"++
 "   :step <expr>                single-step into <expr>\n"++
246
 "   :steplocal                  single-step within the current top-level binding\n"++
247
 "   :stepmodule                 single-step restricted to the current module\n"++
248
 "   :trace                      trace after stopping at a breakpoint\n"++
249
 "   :trace <expr>               evaluate <expr> with tracing on (see :history)\n"++
250 251 252

 "\n" ++
 " -- Commands for changing settings:\n" ++
253 254 255 256
 "\n" ++
 "   :set <option> ...           set options\n" ++
 "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
 "   :set prog <progname>        set the value returned by System.getProgName\n" ++
Simon Marlow's avatar
Simon Marlow committed
257
 "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
Ian Lynagh's avatar
Ian Lynagh committed
258
 "   :set editor <cmd>           set the command used for :edit\n" ++
259
 "   :set stop [<n>] <cmd>       set the command to run when a breakpoint is hit\n" ++
260 261
 "   :unset <option> ...         unset options\n" ++
 "\n" ++
262
 "  Options for ':set' and ':unset':\n" ++
263 264 265 266 267
 "\n" ++
 "    +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" ++
mnislaih's avatar
mnislaih committed
268
 "                         (eg. -v2, -fglasgow-exts, etc.)\n" ++
269 270
 "                    for GHCi-specific flags, see User's Guide,\n"++
 "                    Flag reference, Interactive-mode options\n" ++
271 272 273 274 275 276 277
 "\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" ++
 "   :show modules               show the currently loaded modules\n" ++
278 279
 "   :show packages              show the currently active package flags\n" ++
 "   :show languages             show the currently active language flags\n" ++
280 281
 "   :show <setting>             show value of <setting>, which is one of\n" ++
 "                                  [args, prog, prompt, editor, stop]\n" ++
282
 "\n" 
283

Simon Marlow's avatar
Simon Marlow committed
284
findEditor :: IO String
Simon Marlow's avatar
Simon Marlow committed
285 286 287
findEditor = do
  getEnv "EDITOR" 
    `IO.catch` \_ -> do
288
#if mingw32_HOST_OS
Ian Lynagh's avatar
Ian Lynagh committed
289 290
        win <- System.Win32.getWindowsDirectory
        return (win </> "notepad.exe")
Simon Marlow's avatar
Simon Marlow committed
291
#else
Ian Lynagh's avatar
Ian Lynagh committed
292
        return ""
Simon Marlow's avatar
Simon Marlow committed
293 294
#endif

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

297 298
interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String]
              -> Ghc ()
299
interactiveUI srcs maybe_exprs = do
300 301 302
   -- 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
303 304
   i <- liftIO $ isProfiled
   when (i /= 0) $ 
305 306
     ghcError (InstallationError "GHCi cannot be used when compiled with -prof")

307 308 309 310 311 312 313 314
   -- 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.
315 316 317
   _ <- liftIO $ newStablePtr stdin
   _ <- liftIO $ newStablePtr stdout
   _ <- liftIO $ newStablePtr stderr
318

Ian Lynagh's avatar
Ian Lynagh committed
319
    -- Initialise buffering for the *interpreted* I/O system
320
   initInterpBuffering
321

322
   liftIO $ when (isNothing maybe_exprs) $ do
Ian Lynagh's avatar
Ian Lynagh committed
323 324 325 326 327 328 329 330 331 332
        -- 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
333 334 335 336 337 338
#if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611
        -- 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
339

340
   -- initial context is just the Prelude
341
   prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing
342
   GHC.setContext [] [(prel_mod, Nothing)]
343

344
   default_editor <- liftIO $ findEditor
Simon Marlow's avatar
Simon Marlow committed
345

Ian Lynagh's avatar
Ian Lynagh committed
346
   startGHCi (runGHCi srcs maybe_exprs)
Ian Lynagh's avatar
Ian Lynagh committed
347 348
        GHCiState{ progname = "<interactive>",
                   args = [],
Simon Marlow's avatar
Simon Marlow committed
349
                   prompt = "%s> ",
Simon Marlow's avatar
Simon Marlow committed
350
                   stop = "",
Ian Lynagh's avatar
Ian Lynagh committed
351
                   editor = default_editor,
352
--                   session = session,
Ian Lynagh's avatar
Ian Lynagh committed
353
                   options = [],
mnislaih's avatar
mnislaih committed
354
                   prelude = prel_mod,
355 356
                   break_ctr = 0,
                   breaks = [],
357
                   tickarrays = emptyModuleEnv,
358
                   last_command = Nothing,
Simon Marlow's avatar
Simon Marlow committed
359
                   cmdqueue = [],
mnislaih's avatar
mnislaih committed
360
                   remembered_ctx = [],
361
                   ghc_e = isJust maybe_exprs
mnislaih's avatar
mnislaih committed
362
                 }
rrt's avatar
rrt committed
363

364 365
   return ()

366 367 368 369 370 371 372
withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
withGhcAppData right left = do
   either_dir <- IO.try (getAppUserDataDirectory "ghc")
   case either_dir of
      Right dir -> right dir
      _ -> left

Ian Lynagh's avatar
Ian Lynagh committed
373 374
runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
runGHCi paths maybe_exprs = do
375 376
  let 
   read_dot_files = not opt_IgnoreDotGhci
377

378 379
   current_dir = return (Just ".ghci")

380 381 382
   app_user_dir = io $ withGhcAppData 
                    (\dir -> return (Just (dir </> "ghci.conf")))
                    (return Nothing)
383 384 385 386 387 388 389

   home_dir = do
    either_dir <- io $ IO.try (getEnv "HOME")
    case either_dir of
      Right home -> return (Just (home </> ".ghci"))
      _ -> return Nothing

390 391 392 393
   canonicalizePath' :: FilePath -> IO (Maybe FilePath)
   canonicalizePath' fp = liftM Just (canonicalizePath fp)
                `catchIO` \_ -> return Nothing

394 395 396 397 398 399
   sourceConfigFile :: FilePath -> GHCi ()
   sourceConfigFile file = do
     exists <- io $ doesFileExist file
     when exists $ do
       dir_ok  <- io $ checkPerms (getDirectory file)
       file_ok <- io $ checkPerms file
400
       when (dir_ok && file_ok) $ do
401 402 403
         either_hdl <- io $ IO.try (openFile file ReadMode)
         case either_hdl of
           Left _e   -> return ()
404 405 406 407 408
           -- NOTE: this assumes that runInputT won't affect the terminal;
           -- can we assume this will always be the case?
           -- This would be a good place for runFileInputT.
           Right hdl -> runInputTWithPrefs defaultPrefs defaultSettings $ do
                            runCommands $ fileLoop hdl
409 410
     where
      getDirectory f = case takeDirectory f of "" -> "."; d -> d
Ian Lynagh's avatar
Ian Lynagh committed
411

412
  when (read_dot_files) $ do
413 414 415
    mcfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
    mcfgs <- io $ mapM canonicalizePath' (catMaybes mcfgs0)
    mapM_ sourceConfigFile $ nub $ catMaybes mcfgs
416 417
        -- nub, because we don't want to read .ghci twice if the
        -- CWD is $HOME.
418

419
  -- Perform a :load for files given on the GHCi command line
420 421 422
  -- 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
423
     ok <- ghciHandle (\e -> do showException e; return Failed) $
424 425 426 427 428
                -- TODO: this is a hack.
                runInputTWithPrefs defaultPrefs defaultSettings $ do
                    let (filePaths, phases) = unzip paths
                    filePaths' <- mapM (Encoding.decode . BS.pack) filePaths
                    loadModule (zip filePaths' phases)
Ian Lynagh's avatar
Ian Lynagh committed
429
     when (isJust maybe_exprs && failed ok) $
Ian Lynagh's avatar
Ian Lynagh committed
430
        io (exitWith (ExitFailure 1))
431

432 433
  -- if verbosity is greater than 0, or we are connected to a
  -- terminal, display the prompt in the interactive loop.
434
  is_tty <- io (hIsTerminalDevice stdin)
435
  dflags <- getDynFlags
436 437
  let show_prompt = verbosity dflags > 0 || is_tty

Ian Lynagh's avatar
Ian Lynagh committed
438
  case maybe_exprs of
Ian Lynagh's avatar
Ian Lynagh committed
439
        Nothing ->
sof's avatar
sof committed
440
          do
Ian Lynagh's avatar
Ian Lynagh committed
441
            -- enter the interactive loop
442
            runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
Ian Lynagh's avatar
Ian Lynagh committed
443
        Just exprs -> do
Ian Lynagh's avatar
Ian Lynagh committed
444
            -- just evaluate the expression we were given
Ian Lynagh's avatar
Ian Lynagh committed
445
            enqueueCommands exprs
Ian Lynagh's avatar
Ian Lynagh committed
446
            let handle e = do st <- getGHCiState
447 448
                              -- flush the interpreter's stdout/stderr on exit (#3890)
                              flushInterpBuffers
Ian Lynagh's avatar
Ian Lynagh committed
449 450 451 452
                                   -- Jump through some hoops to get the
                                   -- current progname in the exception text:
                                   -- <progname>: <exception>
                              io $ withProgName (progname st)
453 454
                                   -- this used to be topHandlerFastExit, see #2228
                                 $ topHandler e
455 456
            runInputTWithPrefs defaultPrefs defaultSettings $ do
                runCommands' handle (return Nothing)
457 458

  -- and finally, exit
459
  io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
460

461 462 463 464 465 466
runGHCiInput :: InputT GHCi a -> GHCi a
runGHCiInput f = do
    histFile <- io $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
                        (return Nothing)
    let settings = setComplete ghciCompleteWord
                    $ defaultSettings {historyFile = histFile}
467
    runInputT settings f
468

469 470 471
nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
nextInputLine show_prompt is_tty
  | is_tty = do
472
    prompt <- if show_prompt then lift mkPrompt else return ""
473 474 475 476
    getInputLine prompt
  | otherwise = do
    when show_prompt $ lift mkPrompt >>= liftIO . putStr
    fileLoop stdin
477

478
-- NOTE: We only read .ghci files if they are owned by the current user,
479 480 481
-- and aren't world writable.  Otherwise, we could be accidentally 
-- running code planted by a malicious third party.

rrt's avatar
rrt committed
482 483 484 485
-- 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.
486 487

checkPerms :: String -> IO Bool
488
#ifdef mingw32_HOST_OS
Simon Marlow's avatar
Simon Marlow committed
489
checkPerms _ =
490
  return True
sof's avatar
sof committed
491
#else
Simon Marlow's avatar
Simon Marlow committed
492
checkPerms name =
493
  handleIO (\_ -> return False) $ do
494 495 496 497 498 499 500 501 502 503 504 505 506 507
     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 =  fileMode st
   	if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
   	   || (otherWriteMode == (mode `intersectFileModes` otherWriteMode)) 
   	   then do
   	       putStrLn $ "*** WARNING: " ++ name ++ 
   			  " is writable by someone else, IGNORING!"
   	       return False
   	  else return True
sof's avatar
sof committed
508
#endif
509

510 511
fileLoop :: MonadIO m => Handle -> InputT m (Maybe String)
fileLoop hdl = do
512
   l <- liftIO $ IO.try $ hGetLine hdl
513
   case l of
514 515
        Left e | isEOFError e              -> return Nothing
               | InvalidArgument <- etype  -> return Nothing
516
               | otherwise                 -> liftIO $ ioError e
517 518 519 520 521
                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.
522
        Right l -> return (Just l)
523

Simon Marlow's avatar
Simon Marlow committed
524
mkPrompt :: GHCi String
525
mkPrompt = do
526 527
  (toplevs,exports) <- GHC.getContext
  resumes <- GHC.getResumeContext
Simon Marlow's avatar
Simon Marlow committed
528
  -- st <- getGHCiState
529 530 531 532

  context_bit <-
        case resumes of
            [] -> return empty
Simon Marlow's avatar
Simon Marlow committed
533
            r:_ -> do
534 535 536 537 538
                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)
539
                        span <- GHC.getHistorySpan hist
540 541 542
                        return (brackets (ppr (negate ix) <> char ':' 
                                          <+> ppr span) <> space)
  let
Simon Marlow's avatar
Simon Marlow committed
543
        dots | _:rs <- resumes, not (null rs) = text "... "
544 545 546
             | otherwise = empty

        modules_bit = 
Simon Marlow's avatar
Simon Marlow committed
547 548 549 550 551
       -- ToDo: maybe...
       --  let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
       --  hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
       --  hsep (map (\m -> char '!'  <> ppr (GHC.moduleName m)) bexports) <+>
             hsep (map (\m -> char '*'  <> ppr (GHC.moduleName m)) toplevs) <+>
552
             hsep (map (ppr . GHC.moduleName) (nub (map fst exports)))
553

554 555 556 557 558 559 560 561 562
        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
   --
  st <- getGHCiState
  return (showSDoc (f (prompt st)))
563

564

565 566 567 568 569 570 571 572
queryQueue :: GHCi (Maybe String)
queryQueue = do
  st <- getGHCiState
  case cmdqueue st of
    []   -> return Nothing
    c:cs -> do setGHCiState st{ cmdqueue = cs }
               return (Just c)

573
runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
574 575
runCommands = runCommands' handler

576
runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
577
             -> InputT GHCi (Maybe String) -> InputT GHCi ()
578
runCommands' eh getCmd = do
579 580 581 582 583 584 585 586
    b <- ghandle (\e -> case fromException e of
                          Just UserInterrupt -> return False
                          _ -> case fromException e of
                                 Just ghc_e ->
                                   do liftIO (print (ghc_e :: GhcException))
                                      return True
                                 _other ->
                                   liftIO (Exception.throwIO e))
587 588 589 590 591 592 593
            (runOneCommand eh getCmd)
    if b then return () else runCommands' eh getCmd

runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
            -> InputT GHCi Bool
runOneCommand eh getCmd = do
  mb_cmd <- noSpace (lift queryQueue)
594
  mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
595 596 597
  case mb_cmd of
    Nothing -> return True
    Just c  -> ghciHandle (lift . eh) $
598 599
             handleSourceError printErrorAndKeepGoing
               (doCommand c)
600
  where
601 602
    printErrorAndKeepGoing err = do
        GHC.printExceptionAndWarnings err
603
        return False
604

605 606 607 608 609 610
    noSpace q = q >>= maybe (return Nothing)
                            (\c->case removeSpaces c of 
                                   ""   -> noSpace q
                                   ":{" -> multiLineCmd q
                                   c    -> return (Just c) )
    multiLineCmd q = do
611
      st <- lift getGHCiState
612
      let p = prompt st
613
      lift $ setGHCiState st{ prompt = "%s| " }
614
      mb_cmd <- collectCommand q ""
615
      lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p }
616 617 618 619 620 621 622 623 624 625
      return mb_cmd
    -- we can't use removeSpaces for the sublines here, so 
    -- multiline commands are somewhat more brittle against
    -- fileformat errors (such as \r in dos input on unix), 
    -- we get rid of any extra spaces for the ":}" test; 
    -- we also avoid silent failure if ":}" is not found;
    -- and since there is no (?) valid occurrence of \r (as 
    -- opposed to its String representation, "\r") inside a
    -- ghci command, we replace any such with ' ' (argh:-(
    collectCommand q c = q >>= 
626
      maybe (liftIO (ioError collectError))
627 628
            (\l->if removeSpaces l == ":}" 
                 then return (Just $ removeSpaces c) 
629
                 else collectCommand q (c ++ "\n" ++ map normSpace l))
630 631 632 633 634
      where normSpace '\r' = ' '
            normSpace   c  = c
    -- QUESTION: is userError the one to use here?
    collectError = userError "unterminated multiline command :{ .. :}"
    doCommand (':' : cmd) = specialCommand cmd
635
    doCommand stmt        = do _ <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion
636
                               return False
637 638 639 640 641 642

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

643

644 645
runStmt :: String -> SingleStep -> GHCi Bool
runStmt stmt step
646 647 648 649
 | null (filter (not.isSpace) stmt)
 = return False
 | "import " `isPrefixOf` stmt
 = do newContextCmd (Import stmt); return False
650
 | otherwise
651 652 653 654 655 656 657
 = do
#if __GLASGOW_HASKELL__ >= 611
      -- In the new IO library, read handles buffer data even if the Handle
      -- 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).
658
      _ <- liftIO $ IO.try $ hFlushAll stdin
659 660
#endif
      result <- GhciMonad.runStmt stmt step
661
      afterRunStmt (const True) result
662

663
--afterRunStmt :: GHC.RunResult -> GHCi Bool
Simon Marlow's avatar
Simon Marlow committed
664
                                 -- False <=> the statement failed to compile
Simon Marlow's avatar
Simon Marlow committed
665
afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
666
afterRunStmt _ (GHC.RunException e) = throw e
667
afterRunStmt step_here run_result = do
668
  resumes <- GHC.getResumeContext
Simon Marlow's avatar
Simon Marlow committed
669 670 671
  case run_result of
     GHC.RunOk names -> do
        show_types <- isOptionSet ShowType
672
        when show_types $ printTypeOfNames names
673 674
     GHC.RunBreak _ names mb_info
         | isNothing  mb_info ||
675
           step_here (GHC.resumeSpan $ head resumes) -> do
676 677 678 679 680
               mb_id_loc <- toBreakIdAndLocation mb_info
               let breakCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
               if (null breakCmd)
                 then printStoppedAtBreakInfo (head resumes) names
                 else enqueueCommands [breakCmd]
681 682 683 684
               -- run the command set with ":set stop <cmd>"
               st <- getGHCiState
               enqueueCommands [stop st]
               return ()
685
         | otherwise -> resume step_here GHC.SingleStep >>=
686
                        afterRunStmt step_here >> return ()
Simon Marlow's avatar
Simon Marlow committed
687 688
     _ -> return ()

689 690 691
  flushInterpBuffers
  io installSignalHandlers
  b <- isOptionSet RevertCAFs
692
  when b revertCAFs
693

Simon Marlow's avatar
Simon Marlow committed
694
  return (case run_result of GHC.RunOk _ -> True; _ -> False)
695

696 697 698 699
toBreakIdAndLocation ::
  Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
toBreakIdAndLocation Nothing = return Nothing
toBreakIdAndLocation (Just info) = do
700 701 702
  let mod = GHC.breakInfo_module info
      nm  = GHC.breakInfo_number info
  st <- getGHCiState
703 704 705 706 707 708 709 710 711 712 713 714 715
  return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
                                  breakModule loc == mod,
                                  breakTick loc == nm ]

printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
printStoppedAtBreakInfo resume names = do
  printForUser $ ptext (sLit "Stopped at") <+>
    ppr (GHC.resumeSpan resume)
  --  printTypeOfNames session names
  let namesSorted = sortBy compareNames names
  tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
  docs <- pprTypeAndContents [id | AnId id <- tythings]
  printForUserPartWay docs
716

717 718 719
printTypeOfNames :: [Name] -> GHCi ()
printTypeOfNames names
 = mapM_ (printTypeOfName ) $ sortBy compareNames names
720 721 722

compareNames :: Name -> Name -> Ordering
n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
723 724
    where compareWith n = (getOccString n, getSrcSpan n)

725 726 727
printTypeOfName :: Name -> GHCi ()
printTypeOfName n
   = do maybe_tything <- GHC.lookupName n
728 729 730
        case maybe_tything of
            Nothing    -> return ()
            Just thing -> printTyThing thing
731

732

733
data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
734

735 736
specialCommand :: String -> InputT GHCi Bool
specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
737 738
specialCommand str = do
  let (cmd,rest) = break isSpace str
739
  maybe_cmd <- lift $ lookupCommand cmd
Simon Marlow's avatar
Simon Marlow committed
740
  case maybe_cmd of
741
    GotCommand (_,f,_) -> f (dropWhile isSpace rest)
742
    BadCommand ->
743
      do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
744 745 746
                           ++ shortHelpText)
         return False
    NoLastCommand ->
747
      do liftIO $ hPutStr stdout ("there is no last command to perform\n"
748 749 750 751 752 753 754 755 756
                           ++ shortHelpText)
         return False

lookupCommand :: String -> GHCi (MaybeCommand)
lookupCommand "" = do
  st <- getGHCiState
  case last_command st of
      Just c -> return $ GotCommand c
      Nothing -> return NoLastCommand
Simon Marlow's avatar
Simon Marlow committed
757
lookupCommand str = do
758 759 760 761 762 763 764 765
  mc <- io $ lookupCommand' str
  st <- getGHCiState
  setGHCiState st{ last_command = mc }
  return $ case mc of
           Just c -> GotCommand c
           Nothing -> BadCommand

lookupCommand' :: String -> IO (Maybe Command)
766 767
lookupCommand' ":" = return Nothing
lookupCommand' str' = do
Simon Marlow's avatar
Simon Marlow committed
768
  macros <- readIORef macros_ref
769 770 771
  let{ (str, cmds) = case str' of
      ':' : rest -> (rest, builtin_commands)
      _ -> (str', macros ++ builtin_commands) }
Simon Marlow's avatar
Simon Marlow committed
772
  -- look for exact match first, then the first prefix match
773 774
  return $ case [ c | c <- cmds, str == cmdName c ] of
           c:_ -> Just c
775
           [] -> case [ c | c@(s,_,_) <- cmds, str `isPrefixOf` s ] of
776 777
                 [] -> Nothing
                 c:_ -> Just c
778 779 780

getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
getCurrentBreakSpan = do
781
  resumes <- GHC.getResumeContext
782 783
  case resumes of
    [] -> return Nothing
Simon Marlow's avatar
Simon Marlow committed
784
    (r:_) -> do
785 786 787 788 789
        let ix = GHC.resumeHistoryIx r
        if ix == 0
           then return (Just (GHC.resumeSpan r))
           else do
                let hist = GHC.resumeHistory r !! (ix-1)
790
                span <- GHC.getHistorySpan hist
791 792
                return (Just span)

793 794
getCurrentBreakModule :: GHCi (Maybe Module)
getCurrentBreakModule = do
795
  resumes <- GHC.getResumeContext
796 797
  case resumes of
    [] -> return Nothing
Simon Marlow's avatar
Simon Marlow committed
798
    (r:_) -> do
799 800
        let ix = GHC.resumeHistoryIx r
        if ix == 0
mnislaih's avatar
mnislaih committed
801
           then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
802 803 804 805
           else do
                let hist = GHC.resumeHistory r !! (ix-1)
                return $ Just $ GHC.getHistoryModule  hist

806 807 808
-----------------------------------------------------------------------------
-- Commands

809 810
noArgs :: GHCi () -> String -> GHCi ()
noArgs m "" = m
Simon Marlow's avatar
Simon Marlow committed
811
noArgs _ _  = io $ putStrLn "This command takes no arguments"
812

813 814 815
help :: String -> GHCi ()
help _ = io (putStr helpText)

816
info :: String -> InputT GHCi ()
</