UI.hs 149 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

12 13 14
{-# OPTIONS -fno-cse #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly

15 16 17 18
-----------------------------------------------------------------------------
--
-- GHC Interactive User Interface
--
19
-- (c) The GHC Team 2005-2006
20 21
--
-----------------------------------------------------------------------------
22

23
module GHCi.UI (
24 25 26 27 28 29
        interactiveUI,
        GhciSettings(..),
        defaultGhciSettings,
        ghciCommands,
        ghciWelcomeMsg
    ) where
30

31 32
#include "HsVersions.h"

dterei's avatar
dterei committed
33
-- GHCi
34 35 36 37
import qualified GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls )
import GHCi.UI.Monad hiding ( args, runStmt, runDecls )
import GHCi.UI.Tags
import GHCi.UI.Info
38
import Debugger
39

40
-- The GHC interface
41
import GHCi
42 43
import GHCi.RemoteTypes
import GHCi.BreakArray
dterei's avatar
dterei committed
44
import DynFlags
Douglas Wilson's avatar
Douglas Wilson committed
45
import ErrUtils hiding (traceCmd)
46
import Finder
47
import GhcMonad ( modifySession )
dterei's avatar
dterei committed
48 49 50
import qualified GHC
import GHC ( LoadHowMuch(..), Target(..),  TargetId(..), InteractiveImport(..),
             TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,
51
             getModuleGraph, handleSourceError )
52
import HsImpExp
53
import HsSyn
54
import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,
55
                  setInteractivePrintName, hsc_dflags, msObjFilePath )
dterei's avatar
dterei committed
56
import Module
57
import Name
58 59
import Packages ( trusted, getPackageDetails, getInstalledPackageDetails,
                  listVisibleModuleNames, pprFlag )
60
import IfaceSyn ( showToHeader )
dterei's avatar
dterei committed
61
import PprTyThing
62
import PrelNames
63
import RdrName ( getGRE_NameQualifier_maybes, getRdrName )
64
import SrcLoc
dterei's avatar
dterei committed
65 66 67
import qualified Lexer

import StringBuffer
Rufflewind's avatar
Rufflewind committed
68
import Outputable hiding ( printForUser, printForUserPartWay )
69 70

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

dterei's avatar
dterei committed
83
-- Haskell Libraries
84
import System.Console.Haskeline as Haskeline
85

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

dterei's avatar
dterei committed
93
import Data.Array
Simon Marlow's avatar
Simon Marlow committed
94
import qualified Data.ByteString.Char8 as BS
dterei's avatar
dterei committed
95
import Data.Char
Ian Lynagh's avatar
Ian Lynagh committed
96
import Data.Function
97
import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )
dterei's avatar
dterei committed
98 99
import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,
                   partition, sort, sortBy )
100
import qualified Data.Set as S
101
import Data.Maybe
102
import qualified Data.Map as M
niksaz's avatar
niksaz committed
103 104 105
import Data.Time.LocalTime ( getZonedTime )
import Data.Time.Format ( formatTime, defaultTimeLocale )
import Data.Version ( showVersion )
106
import Prelude hiding ((<>))
dterei's avatar
dterei committed
107

108
import Exception hiding (catch)
109
import Foreign hiding (void)
110
import GHC.Stack hiding (SrcLoc(..))
dterei's avatar
dterei committed
111 112

import System.Directory
113
import System.Environment
dterei's avatar
dterei committed
114
import System.Exit ( exitWith, ExitCode(..) )
dterei's avatar
dterei committed
115
import System.FilePath
niksaz's avatar
niksaz committed
116
import System.Info
ross's avatar
ross committed
117
import System.IO
118
import System.IO.Error
dterei's avatar
dterei committed
119
import System.IO.Unsafe ( unsafePerformIO )
120
import System.Process
Simon Marlow's avatar
Simon Marlow committed
121
import Text.Printf
122
import Text.Read ( readMaybe )
Geraldus's avatar
Geraldus committed
123
import Text.Read.Lex (isSymbolChar)
124

niksaz's avatar
niksaz committed
125 126
import Unsafe.Coerce

Ben Gamari's avatar
Ben Gamari committed
127
#if !defined(mingw32_HOST_OS)
dterei's avatar
dterei committed
128 129 130 131 132
import System.Posix hiding ( getEnv )
#else
import qualified System.Win32
#endif

dterei's avatar
dterei committed
133 134
import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
import GHC.IO.Handle ( hFlushAll )
dterei's avatar
dterei committed
135
import GHC.TopHandler ( topHandler )
136

137 138
-----------------------------------------------------------------------------

139 140 141
data GhciSettings = GhciSettings {
        availableCommands :: [Command],
        shortHelpText     :: String,
142
        fullHelpText      :: String,
niksaz's avatar
niksaz committed
143 144
        defPrompt         :: PromptFunction,
        defPromptCont     :: PromptFunction
145 146 147 148 149 150 151
    }

defaultGhciSettings :: GhciSettings
defaultGhciSettings =
    GhciSettings {
        availableCommands = ghciCommands,
        shortHelpText     = defShortHelpText,
152
        defPrompt         = default_prompt,
niksaz's avatar
niksaz committed
153
        defPromptCont     = default_prompt_cont,
154
        fullHelpText      = defFullHelpText
155 156
    }

157 158 159
ghciWelcomeMsg :: String
ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
                 ": http://www.haskell.org/ghc/  :? for help"
160

161
ghciCommands :: [Command]
162
ghciCommands = map mkCmd [
163 164 165 166 167 168 169 170 171 172 173 174
  -- 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),
175 176
  ("ctags",     keepGoing createCTagsWithLineNumbersCmd, completeFilename),
  ("ctags!",    keepGoing createCTagsWithRegExesCmd, completeFilename),
177 178 179
  ("def",       keepGoing (defineMacro False),  completeExpression),
  ("def!",      keepGoing (defineMacro True),   completeExpression),
  ("delete",    keepGoing deleteCmd,            noCompletion),
180
  ("edit",      keepGoing' editFile,            completeFilename),
181 182 183 184 185
  ("etags",     keepGoing createETagsFileCmd,   completeFilename),
  ("force",     keepGoing forceCmd,             completeExpression),
  ("forward",   keepGoing forwardCmd,           noCompletion),
  ("help",      keepGoing help,                 noCompletion),
  ("history",   keepGoing historyCmd,           noCompletion),
186 187
  ("info",      keepGoing' (info False),        completeIdentifier),
  ("info!",     keepGoing' (info True),         completeIdentifier),
188
  ("issafe",    keepGoing' isSafeCmd,           completeModule),
189 190
  ("kind",      keepGoing' (kindOfType False),  completeIdentifier),
  ("kind!",     keepGoing' (kindOfType True),   completeIdentifier),
191 192
  ("load",      keepGoingPaths loadModule_,     completeHomeModuleOrFile),
  ("load!",     keepGoingPaths loadModuleDefer, completeHomeModuleOrFile),
193
  ("list",      keepGoing' listCmd,             noCompletion),
194
  ("module",    keepGoing moduleCmd,            completeSetModule),
195 196 197
  ("main",      keepGoing runMain,              completeFilename),
  ("print",     keepGoing printCmd,             completeExpression),
  ("quit",      quit,                           noCompletion),
198 199
  ("reload",    keepGoing' reloadModule,        noCompletion),
  ("reload!",   keepGoing' reloadModuleDefer,   noCompletion),
200
  ("run",       keepGoing runRun,               completeFilename),
vivian's avatar
vivian committed
201
  ("script",    keepGoing' scriptCmd,           completeFilename),
202
  ("set",       keepGoing setCmd,               completeSetOptions),
203
  ("seti",      keepGoing setiCmd,              completeSeti),
204
  ("show",      keepGoing showCmd,              completeShowOptions),
205
  ("showi",     keepGoing showiCmd,             completeShowiOptions),
206 207 208 209 210 211
  ("sprint",    keepGoing sprintCmd,            completeExpression),
  ("step",      keepGoing stepCmd,              completeIdentifier),
  ("steplocal", keepGoing stepLocalCmd,         completeIdentifier),
  ("stepmodule",keepGoing stepModuleCmd,        completeIdentifier),
  ("type",      keepGoing' typeOfExpr,          completeExpression),
  ("trace",     keepGoing traceCmd,             completeExpression),
212
  ("unadd",     keepGoingPaths unAddModule,     completeFilename),
213
  ("undef",     keepGoing undefineMacro,        completeMacro),
214 215
  ("unset",     keepGoing unsetOptions,         completeSetOptions),
  ("where",     keepGoing whereCmd,             noCompletion)
216
  ] ++ map mkCmdHidden [ -- hidden commands
217 218 219 220 221
  ("all-types", keepGoing' allTypesCmd),
  ("complete",  keepGoing completeCmd),
  ("loc-at",    keepGoing' locAtCmd),
  ("type-at",   keepGoing' typeAtCmd),
  ("uses",      keepGoing' usesCmd)
222
  ]
223 224 225 226 227 228 229 230 231 232 233 234
 where
  mkCmd (n,a,c) = Command { cmdName = n
                          , cmdAction = a
                          , cmdHidden = False
                          , cmdCompletionFunc = c
                          }

  mkCmdHidden (n,a) = Command { cmdName = n
                              , cmdAction = a
                              , cmdHidden = True
                              , cmdCompletionFunc = noCompletion
                              }
235

dterei's avatar
dterei committed
236
-- We initialize readline (in the interactiveUI function) to use
237 238 239 240
-- 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
241
--
242 243
-- NOTE: in order for us to override the default correctly, any custom entry
-- must be a SUBSET of word_break_chars.
244
word_break_chars :: String
Geraldus's avatar
Geraldus committed
245 246 247 248 249 250
word_break_chars = spaces ++ specials ++ symbols

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

252
flagWordBreakChars :: String
253 254 255
flagWordBreakChars = " \t\n"


256 257 258 259 260
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
261

262
keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
Ian Lynagh's avatar
Ian Lynagh committed
263 264
keepGoingPaths a str
 = do case toArgs str of
Ian Lynagh's avatar
Ian Lynagh committed
265
          Left err -> liftIO $ hPutStrLn stderr err
Ian Lynagh's avatar
Ian Lynagh committed
266 267
          Right args -> a args
      return False
sof's avatar
sof committed
268

269 270
defShortHelpText :: String
defShortHelpText = "use :? for help.\n"
271

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

dterei's avatar
dterei committed
338 339 340 341
  "\n" ++
  " -- Commands for changing settings:\n" ++
  "\n" ++
  "   :set <option> ...           set options\n" ++
342
  "   :seti <option> ...          set options for interactive evaluation only\n" ++
dterei's avatar
dterei committed
343 344 345
  "   :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" ++
niksaz's avatar
niksaz committed
346 347 348 349
  "   :set prompt-cont <prompt>   set the continuation prompt used in GHCi\n" ++
  "   :set prompt-function <expr> set the function to handle the prompt\n" ++
  "   :set prompt-cont-function <expr>" ++
                     "set the function to handle the continuation prompt\n" ++
dterei's avatar
dterei committed
350 351 352 353 354 355
  "   :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
356
  "    +m            allow multiline commands\n" ++
dterei's avatar
dterei committed
357 358 359
  "    +r            revert top-level expressions after each evaluation\n" ++
  "    +s            print timing/memory stats after each evaluation\n" ++
  "    +t            print type after evaluation\n" ++
360
  "    +c            collect type/location info after loading modules\n" ++
dterei's avatar
dterei committed
361
  "    -<flags>      most GHC command line flags can also be set here\n" ++
362
  "                         (eg. -v2, -XFlexibleInstances, etc.)\n" ++
dterei's avatar
dterei committed
363 364 365 366 367 368 369 370
  "                    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" ++
371
  "   :show imports               show the current imports\n" ++
372
  "   :show linker                show current linker state\n" ++
dterei's avatar
dterei committed
373 374
  "   :show modules               show the currently loaded modules\n" ++
  "   :show packages              show the currently active package flags\n" ++
375
  "   :show paths                 show the currently active search paths\n" ++
376
  "   :show language              show the currently active language flags\n" ++
377
  "   :show targets               show the current set of targets\n" ++
dterei's avatar
dterei committed
378
  "   :show <setting>             show value of <setting>, which is one of\n" ++
niksaz's avatar
niksaz committed
379
  "                                  [args, prog, editor, stop]\n" ++
380
  "   :showi language             show language flags for interactive evaluation\n" ++
dterei's avatar
dterei committed
381
  "\n"
382

Simon Marlow's avatar
Simon Marlow committed
383
findEditor :: IO String
Simon Marlow's avatar
Simon Marlow committed
384
findEditor = do
dterei's avatar
dterei committed
385
  getEnv "EDITOR"
386
    `catchIO` \_ -> do
Ben Gamari's avatar
Ben Gamari committed
387
#if defined(mingw32_HOST_OS)
Ian Lynagh's avatar
Ian Lynagh committed
388 389
        win <- System.Win32.getWindowsDirectory
        return (win </> "notepad.exe")
Simon Marlow's avatar
Simon Marlow committed
390
#else
Ian Lynagh's avatar
Ian Lynagh committed
391
        return ""
Simon Marlow's avatar
Simon Marlow committed
392 393
#endif

niksaz's avatar
niksaz committed
394
default_progname, default_stop :: String
Boris Lykah's avatar
Boris Lykah committed
395 396 397
default_progname = "<interactive>"
default_stop = ""

niksaz's avatar
niksaz committed
398 399 400 401
default_prompt, default_prompt_cont :: PromptFunction
default_prompt = generatePromptFunctionFromString "%s> "
default_prompt_cont = generatePromptFunctionFromString "%s| "

Simon Marlow's avatar
Simon Marlow committed
402 403 404
default_args :: [String]
default_args = []

405
interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]
406
              -> Ghc ()
407
interactiveUI config srcs maybe_exprs = do
408 409 410 411 412 413 414 415
   -- 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.
416 417 418
   _ <- liftIO $ newStablePtr stdin
   _ <- liftIO $ newStablePtr stdout
   _ <- liftIO $ newStablePtr stderr
419

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

423
   -- The initial set of DynFlags used for interactive evaluation is the same
424 425
   -- as the global DynFlags, plus -XExtendedDefaultRules and
   -- -XNoMonomorphismRestriction.
426
   dflags <- getDynFlags
427 428
   let dflags' = (`xopt_set` LangExt.ExtendedDefaultRules)
               . (`xopt_unset` LangExt.MonomorphismRestriction)
429 430
               $ dflags
   GHC.setInteractiveDynFlags dflags'
431

432 433 434 435 436
   lastErrLocationsRef <- liftIO $ newIORef []
   progDynFlags <- GHC.getProgramDynFlags
   _ <- GHC.setProgramDynFlags $
      progDynFlags { log_action = ghciLogAction lastErrLocationsRef }

437
   when (isNothing maybe_exprs) $ do
Ian Lynagh's avatar
Ian Lynagh committed
438 439 440
        -- Only for GHCi (not runghc and ghc -e):

        -- Turn buffering off for the compiled program's stdout/stderr
441
        turnOffBuffering_ nobuffering
Ian Lynagh's avatar
Ian Lynagh committed
442
        -- Turn buffering off for GHCi's stdout
443 444
        liftIO $ hFlush stdout
        liftIO $ hSetBuffering stdout NoBuffering
Ian Lynagh's avatar
Ian Lynagh committed
445 446
        -- We don't want the cmd line to buffer any input that might be
        -- intended for the program, so unbuffer stdin.
447 448
        liftIO $ hSetBuffering stdin NoBuffering
        liftIO $ hSetBuffering stderr NoBuffering
449
#if defined(mingw32_HOST_OS)
450 451 452
        -- 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.
453
        liftIO $ hSetEncoding stdin utf8
454
#endif
Ian Lynagh's avatar
Ian Lynagh committed
455

456
   default_editor <- liftIO $ findEditor
457
   eval_wrapper <- mkEvalWrapper default_progname default_args
458
   let prelude_import = simpleImportDecl preludeModuleName
Ian Lynagh's avatar
Ian Lynagh committed
459
   startGHCi (runGHCi srcs maybe_exprs)
460
        GHCiState{ progname           = default_progname,
461
                   args               = default_args,
462
                   evalWrapper        = eval_wrapper,
niksaz's avatar
niksaz committed
463 464
                   prompt             = default_prompt,
                   prompt_cont        = default_prompt_cont,
465 466 467
                   stop               = default_stop,
                   editor             = default_editor,
                   options            = [],
468 469 470 471
                   -- We initialize line number as 0, not 1, because we use
                   -- current line number while reporting errors which is
                   -- incremented after reading a line.
                   line_number        = 0,
472 473 474 475
                   break_ctr          = 0,
                   breaks             = [],
                   tickarrays         = emptyModuleEnv,
                   ghci_commands      = availableCommands config,
Ben Gamari's avatar
Ben Gamari committed
476
                   ghci_macros        = [],
477 478 479 480
                   last_command       = Nothing,
                   cmdqueue           = [],
                   remembered_ctx     = [],
                   transient_ctx      = [],
481 482
                   extra_imports      = [],
                   prelude_imports    = [prelude_import],
483 484 485
                   ghc_e              = isJust maybe_exprs,
                   short_help         = shortHelpText config,
                   long_help          = fullHelpText config,
486
                   lastErrorLocations = lastErrLocationsRef,
487
                   mod_infos          = M.empty,
488 489
                   flushStdHandles    = flush,
                   noBuffering        = nobuffering
mnislaih's avatar
mnislaih committed
490
                 }
491

492 493
   return ()

494 495 496 497 498 499
resetLastErrorLocations :: GHCi ()
resetLastErrorLocations = do
    st <- getGHCiState
    liftIO $ writeIORef (lastErrorLocations st) []

ghciLogAction :: IORef [(FastString, Int)] ->  LogAction
500 501
ghciLogAction lastErrLocations dflags flag severity srcSpan style msg = do
    defaultLogAction dflags flag severity srcSpan style msg
502 503 504 505 506 507 508
    case severity of
        SevError -> case srcSpan of
            RealSrcSpan rsp -> modifyIORef lastErrLocations
                (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])
            _ -> return ()
        _ -> return ()

509 510
withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
withGhcAppData right left = do
511
    either_dir <- tryIO (getAppUserDataDirectory "ghc")
512 513 514 515 516
    case either_dir of
        Right dir ->
            do createDirectoryIfMissing False dir `catchIO` \_ -> return ()
               right dir
        _ -> left
517

Ian Lynagh's avatar
Ian Lynagh committed
518 519
runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
runGHCi paths maybe_exprs = do
520
  dflags <- getDynFlags
521
  let
522
   ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags
523

524 525
   current_dir = return (Just ".ghci")

Ian Lynagh's avatar
Ian Lynagh committed
526
   app_user_dir = liftIO $ withGhcAppData
527 528
                    (\dir -> return (Just (dir </> "ghci.conf")))
                    (return Nothing)
529 530

   home_dir = do
531
    either_dir <- liftIO $ tryIO (getEnv "HOME")
532 533 534 535
    case either_dir of
      Right home -> return (Just (home </> ".ghci"))
      _ -> return Nothing

536 537 538 539
   canonicalizePath' :: FilePath -> IO (Maybe FilePath)
   canonicalizePath' fp = liftM Just (canonicalizePath fp)
                `catchIO` \_ -> return Nothing

540 541
   sourceConfigFile :: FilePath -> GHCi ()
   sourceConfigFile file = do
Ian Lynagh's avatar
Ian Lynagh committed
542
     exists <- liftIO $ doesFileExist file
543
     when exists $ do
544 545 546 547 548 549 550 551 552 553
       either_hdl <- liftIO $ tryIO (openFile file ReadMode)
       case either_hdl of
         Left _e   -> return ()
         -- NOTE: this assumes that runInputT won't affect the terminal;
         -- can we assume this will always be the case?
         -- This would be a good place for runFileInputT.
         Right hdl ->
             do runInputTWithPrefs defaultPrefs defaultSettings $
                          runCommands $ fileLoop hdl
                liftIO (hClose hdl `catchIO` \_ -> return ())
554 555 556 557 558
                -- Don't print a message if this is really ghc -e (#11478).
                -- Also, let the user silence the message with -v0
                -- (the default verbosity in GHCi is 1).
                when (isNothing maybe_exprs && verbosity dflags > 0) $
                  liftIO $ putStrLn ("Loaded GHCi configuration from " ++ file)
559

560 561
  --

562
  setGHCContextFromGHCiState
Ian Lynagh's avatar
Ian Lynagh committed
563

564 565
  dot_cfgs <- if ignore_dot_ghci then return [] else do
    dot_files <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]
566
    liftIO $ filterM checkFileAndDirPerms dot_files
567 568
  mdot_cfgs <- liftIO $ mapM canonicalizePath' dot_cfgs

569 570 571 572
  let arg_cfgs = reverse $ ghciScripts dflags
    -- -ghci-script are collected in reverse order
    -- We don't require that a script explicitly added by -ghci-script
    -- is owned by the current user. (#6017)
573
  mapM_ sourceConfigFile $ nub $ (catMaybes mdot_cfgs) ++ arg_cfgs
574
    -- nub, because we don't want to read .ghci twice if the CWD is $HOME.
575

576
  -- Perform a :load for files given on the GHCi command line
577 578 579
  -- 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
580
     ok <- ghciHandle (\e -> do showException e; return Failed) $
581
                -- TODO: this is a hack.
582 583
                runInputTWithPrefs defaultPrefs defaultSettings $
                    loadModule paths
Ian Lynagh's avatar
Ian Lynagh committed
584
     when (isJust maybe_exprs && failed ok) $
Ian Lynagh's avatar
Ian Lynagh committed
585
        liftIO (exitWith (ExitFailure 1))
586

587 588
  installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)

589 590
  -- 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
591
  is_tty <- liftIO (hIsTerminalDevice stdin)
592 593
  let show_prompt = verbosity dflags > 0 || is_tty

594
  -- reset line number
595
  modifyGHCiState $ \st -> st{line_number=0}
596

Ian Lynagh's avatar
Ian Lynagh committed
597
  case maybe_exprs of
Ian Lynagh's avatar
Ian Lynagh committed
598
        Nothing ->
sof's avatar
sof committed
599
          do
Ian Lynagh's avatar
Ian Lynagh committed
600
            -- enter the interactive loop
601
            runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
Ian Lynagh's avatar
Ian Lynagh committed
602
        Just exprs -> do
Ian Lynagh's avatar
Ian Lynagh committed
603
            -- just evaluate the expression we were given
Ian Lynagh's avatar
Ian Lynagh committed
604
            enqueueCommands exprs
dterei's avatar
dterei committed
605 606 607 608 609 610 611 612
            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
613
                                   -- this used to be topHandlerFastExit, see #2228
614
            runInputTWithPrefs defaultPrefs defaultSettings $ do
615
                -- make `ghc -e` exit nonzero on invalid input, see Trac #7962
616 617 618 619
                _ <- runCommands' hdle
                     (Just $ hdle (toException $ ExitFailure 1) >> return ())
                     (return Nothing)
                return ()
620 621

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

624 625
runGHCiInput :: InputT GHCi a -> GHCi a
runGHCiInput f = do
Ian Lynagh's avatar
Ian Lynagh committed
626
    dflags <- getDynFlags
627 628 629 630 631 632 633 634 635 636
    let ghciHistory = gopt Opt_GhciHistory dflags
    let localGhciHistory = gopt Opt_LocalGhciHistory dflags
    currentDirectory <- liftIO $ getCurrentDirectory

    histFile <- case (ghciHistory, localGhciHistory) of
      (True, True) -> return (Just (currentDirectory </> ".ghci_history"))
      (True, _) -> liftIO $ withGhcAppData
        (\dir -> return (Just (dir </> "ghci_history"))) (return Nothing)
      _ -> return Nothing

dterei's avatar
dterei committed
637 638 639
    runInputT
        (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})
        f
640

641
-- | How to get the next input line from the user
642 643 644
nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
nextInputLine show_prompt is_tty
  | is_tty = do
dterei's avatar
dterei committed
645 646
    prmpt <- if show_prompt then lift mkPrompt else return ""
    r <- getInputLine prmpt
647 648
    incrementLineNo
    return r
649 650 651
  | otherwise = do
    when show_prompt $ lift mkPrompt >>= liftIO . putStr
    fileLoop stdin
652

653
-- NOTE: We only read .ghci files if they are owned by the current user,
654 655 656
-- and aren't world writable (files owned by root are ok, see #9324).
-- Otherwise, we could be accidentally running code planted by
-- a malicious third party.
657

rrt's avatar
rrt committed
658 659 660 661
-- 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.
662

663 664
checkFileAndDirPerms :: FilePath -> IO Bool
checkFileAndDirPerms file = do
665
  file_ok <- checkPerms file
thomie's avatar
thomie committed
666 667 668 669
  -- Do not check dir perms when .ghci doesn't exist, otherwise GHCi will
  -- print some confusing and useless warnings in some cases (e.g. in
  -- travis). Note that we can't add a test for this, as all ghci tests should
  -- run with -ignore-dot-ghci, which means we never get here.
670
  if file_ok then checkPerms (getDirectory file) else return False
671 672 673 674 675 676
  where
  getDirectory f = case takeDirectory f of
    "" -> "."
    d -> d

checkPerms :: FilePath -> IO Bool
Ben Gamari's avatar
Ben Gamari committed
677
#if defined(mingw32_HOST_OS)
dterei's avatar
dterei committed
678
checkPerms _ = return True
sof's avatar
sof committed
679
#else
680
checkPerms file =
681
  handleIO (\_ -> return False) $ do
682
    st <- getFileStatus file
dterei's avatar
dterei committed
683
    me <- getRealUserID
684 685 686 687 688
    let mode = System.Posix.fileMode st
        ok = (fileOwner st == me || fileOwner st == 0) &&
             groupWriteMode /= mode `intersectFileModes` groupWriteMode &&
             otherWriteMode /= mode `intersectFileModes` otherWriteMode
    unless ok $
689
      -- #8248: Improving warning to include a possible fix.
690
      putStrLn $ "*** WARNING: " ++ file ++
691
                 " is writable by someone else, IGNORING!" ++
Ben Gamari's avatar
Ben Gamari committed
692
                 "\nSuggested fix: execute 'chmod go-w " ++ file ++ "'"
693
    return ok
sof's avatar
sof committed
694
#endif
695

696
incrementLineNo :: InputT GHCi ()
697 698 699
incrementLineNo = modifyGHCiState incLineNo
  where
    incLineNo st = st { line_number = line_number st + 1 }
vivian's avatar
vivian committed
700 701

fileLoop :: Handle -> InputT GHCi (Maybe String)
702
fileLoop hdl = do
703
   l <- liftIO $ tryIO $ hGetLine hdl
704
   case l of
705
        Left e | isEOFError e              -> return Nothing
706 707 708 709 710
               | -- 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
711
               | InvalidArgument <- etype  -> return Nothing
712
               | otherwise                 -> liftIO $ ioError e
713 714 715 716 717
                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
718
        Right l' -> do
719
           incrementLineNo
dterei's avatar
dterei committed
720
           return (Just l')
721

niksaz's avatar
niksaz committed
722 723 724 725 726 727
formatCurrentTime :: String -> IO String
formatCurrentTime format =
  getZonedTime >>= return . (formatTime defaultTimeLocale format)

getUserName :: IO String
getUserName = do
Ben Gamari's avatar
Ben Gamari committed
728
#if defined(mingw32_HOST_OS)
niksaz's avatar
niksaz committed
729 730 731 732 733 734 735 736 737 738
  getEnv "USERNAME"
    `catchIO` \e -> do
      putStrLn $ show e
      return ""
#else
  getLoginName
#endif

getInfoForPrompt :: GHCi (SDoc, [String], Int)
getInfoForPrompt = do
739
  st <- getGHCiState
740
  imports <- GHC.getContext
741
  resumes <- GHC.getResumeContext
742 743 744 745

  context_bit <-
        case resumes of
            [] -> return empty
Simon Marlow's avatar
Simon Marlow committed
746
            r:_ -> do
747 748 749 750 751
                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
752 753 754
                        pan <- GHC.getHistorySpan hist
                        return (brackets (ppr (negate ix) <> char ':'
                                          <+> ppr pan) <> space)
niksaz's avatar
niksaz committed
755

756
  let
Simon Marlow's avatar
Simon Marlow committed
757
        dots | _:rs <- resumes, not (null rs) = text "... "
758 759
             | otherwise = empty

760 761
        rev_imports = reverse imports -- rightmost are the most recent

762
        myIdeclName d | Just m <- ideclAs d = unLoc m
763
                      | otherwise           = unLoc (ideclName d)
764

niksaz's avatar
niksaz committed
765 766 767 768 769 770
        modules_names =
             ['*':(moduleNameString m) | IIModule m <- rev_imports] ++
             [moduleNameString (myIdeclName d) | IIDecl d <- rev_imports]
        line = 1 + line_number st

  return (dots <> context_bit, modules_names, line)
771

niksaz's avatar
niksaz committed
772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793
parseCallEscape :: String -> (String, String)
parseCallEscape s
  | not (all isSpace beforeOpen) = ("", "")
  | null sinceOpen               = ("", "")
  | null sinceClosed             = ("", "")
  | null cmd                     = ("", "")
  | otherwise                    = (cmd, tail sinceClosed)
  where
    (beforeOpen, sinceOpen) = span (/='(') s
    (cmd, sinceClosed) = span (/=')') (tail sinceOpen)

checkPromptStringForErrors :: String -> Maybe String
checkPromptStringForErrors ('%':'c':'a':'l':'l':xs) =
  case parseCallEscape xs of
    ("", "") -> Just ("Incorrect %call syntax. " ++
                      "Should be %call(a command and arguments).")
    (_, afterClosed) -> checkPromptStringForErrors afterClosed
checkPromptStringForErrors ('%':'%':xs) = checkPromptStringForErrors xs
checkPromptStringForErrors (_:xs) = checkPromptStringForErrors xs
checkPromptStringForErrors "" = Nothing

generatePromptFunctionFromString :: String -> PromptFunction
Nolan's avatar