UI.hs 145 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
45
import ErrUtils
46
import GhcMonad ( modifySession )
dterei's avatar
dterei committed
47 48 49
import qualified GHC
import GHC ( LoadHowMuch(..), Target(..),  TargetId(..), InteractiveImport(..),
             TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,
50
             getModuleGraph, handleSourceError )
51
import HsImpExp
52
import HsSyn
53
import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,
54
                  setInteractivePrintName, hsc_dflags, msObjFilePath )
dterei's avatar
dterei committed
55
import Module
56
import Name
57
import Packages ( trusted, getPackageDetails, listVisibleModuleNames, pprFlag )
dterei's avatar
dterei committed
58
import PprTyThing
59 60
import PrelNames
import RdrName ( RdrName, getGRE_NameQualifier_maybes, getRdrName )
61
import SrcLoc
dterei's avatar
dterei committed
62 63 64 65
import qualified Lexer

import StringBuffer
import Outputable hiding ( printForUser, printForUserPartWay, bold )
66 67

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

dterei's avatar
dterei committed
80
-- Haskell Libraries
81
import System.Console.Haskeline as Haskeline
82

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

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

103
import Exception hiding (catch)
104
import Foreign
105
import GHC.Stack hiding (SrcLoc(..))
dterei's avatar
dterei committed
106 107

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

niksaz's avatar
niksaz committed
120 121
import Unsafe.Coerce

dterei's avatar
dterei committed
122 123 124 125 126 127
#ifndef mingw32_HOST_OS
import System.Posix hiding ( getEnv )
#else
import qualified System.Win32
#endif

dterei's avatar
dterei committed
128 129
import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
import GHC.IO.Handle ( hFlushAll )
dterei's avatar
dterei committed
130
import GHC.TopHandler ( topHandler )
131

132 133
-----------------------------------------------------------------------------

134 135 136
data GhciSettings = GhciSettings {
        availableCommands :: [Command],
        shortHelpText     :: String,
137
        fullHelpText      :: String,
niksaz's avatar
niksaz committed
138 139
        defPrompt         :: PromptFunction,
        defPromptCont     :: PromptFunction
140 141 142 143 144 145 146
    }

defaultGhciSettings :: GhciSettings
defaultGhciSettings =
    GhciSettings {
        availableCommands = ghciCommands,
        shortHelpText     = defShortHelpText,
147
        defPrompt         = default_prompt,
niksaz's avatar
niksaz committed
148
        defPromptCont     = default_prompt_cont,
149
        fullHelpText      = defFullHelpText
150 151
    }

152 153 154
ghciWelcomeMsg :: String
ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
                 ": http://www.haskell.org/ghc/  :? for help"
155

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

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

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

246
flagWordBreakChars :: String
247 248 249
flagWordBreakChars = " \t\n"


250 251 252 253 254
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
255

256
keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
Ian Lynagh's avatar
Ian Lynagh committed
257 258
keepGoingPaths a str
 = do case toArgs str of
Ian Lynagh's avatar
Ian Lynagh committed
259
          Left err -> liftIO $ hPutStrLn stderr err
Ian Lynagh's avatar
Ian Lynagh committed
260 261
          Right args -> a args
      return False
sof's avatar
sof committed
262

263 264
defShortHelpText :: String
defShortHelpText = "use :? for help.\n"
265

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

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

Simon Marlow's avatar
Simon Marlow committed
375
findEditor :: IO String
Simon Marlow's avatar
Simon Marlow committed
376
findEditor = do
dterei's avatar
dterei committed
377
  getEnv "EDITOR"
378
    `catchIO` \_ -> do
379
#if mingw32_HOST_OS
Ian Lynagh's avatar
Ian Lynagh committed
380 381
        win <- System.Win32.getWindowsDirectory
        return (win </> "notepad.exe")
Simon Marlow's avatar
Simon Marlow committed
382
#else
Ian Lynagh's avatar
Ian Lynagh committed
383
        return ""
Simon Marlow's avatar
Simon Marlow committed
384 385
#endif

niksaz's avatar
niksaz committed
386
default_progname, default_stop :: String
Boris Lykah's avatar
Boris Lykah committed
387 388 389
default_progname = "<interactive>"
default_stop = ""

niksaz's avatar
niksaz committed
390 391 392 393
default_prompt, default_prompt_cont :: PromptFunction
default_prompt = generatePromptFunctionFromString "%s> "
default_prompt_cont = generatePromptFunctionFromString "%s| "

Simon Marlow's avatar
Simon Marlow committed
394 395 396
default_args :: [String]
default_args = []

397
interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]
398
              -> Ghc ()
399
interactiveUI config srcs maybe_exprs = do
400 401 402 403 404 405 406 407
   -- 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.
408 409 410
   _ <- liftIO $ newStablePtr stdin
   _ <- liftIO $ newStablePtr stdout
   _ <- liftIO $ newStablePtr stderr
411

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

415
   -- The initial set of DynFlags used for interactive evaluation is the same
416 417
   -- as the global DynFlags, plus -XExtendedDefaultRules and
   -- -XNoMonomorphismRestriction.
418
   dflags <- getDynFlags
419 420
   let dflags' = (`xopt_set` LangExt.ExtendedDefaultRules)
               . (`xopt_unset` LangExt.MonomorphismRestriction)
421 422
               $ dflags
   GHC.setInteractiveDynFlags dflags'
423

424 425 426 427 428
   lastErrLocationsRef <- liftIO $ newIORef []
   progDynFlags <- GHC.getProgramDynFlags
   _ <- GHC.setProgramDynFlags $
      progDynFlags { log_action = ghciLogAction lastErrLocationsRef }

429
   when (isNothing maybe_exprs) $ do
Ian Lynagh's avatar
Ian Lynagh committed
430 431 432
        -- Only for GHCi (not runghc and ghc -e):

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

448
   default_editor <- liftIO $ findEditor
449
   eval_wrapper <- mkEvalWrapper default_progname default_args
Ian Lynagh's avatar
Ian Lynagh committed
450
   startGHCi (runGHCi srcs maybe_exprs)
451
        GHCiState{ progname           = default_progname,
452
                   args               = default_args,
453
                   evalWrapper        = eval_wrapper,
niksaz's avatar
niksaz committed
454 455
                   prompt             = default_prompt,
                   prompt_cont        = default_prompt_cont,
456 457 458
                   stop               = default_stop,
                   editor             = default_editor,
                   options            = [],
459 460 461 462
                   -- 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,
463 464 465 466
                   break_ctr          = 0,
                   breaks             = [],
                   tickarrays         = emptyModuleEnv,
                   ghci_commands      = availableCommands config,
Ben Gamari's avatar
Ben Gamari committed
467
                   ghci_macros        = [],
468 469 470 471 472 473 474
                   last_command       = Nothing,
                   cmdqueue           = [],
                   remembered_ctx     = [],
                   transient_ctx      = [],
                   ghc_e              = isJust maybe_exprs,
                   short_help         = shortHelpText config,
                   long_help          = fullHelpText config,
475
                   lastErrorLocations = lastErrLocationsRef,
476
                   mod_infos          = M.empty,
477 478
                   flushStdHandles    = flush,
                   noBuffering        = nobuffering
mnislaih's avatar
mnislaih committed
479
                 }
480

481 482
   return ()

483 484 485 486 487 488
resetLastErrorLocations :: GHCi ()
resetLastErrorLocations = do
    st <- getGHCiState
    liftIO $ writeIORef (lastErrorLocations st) []

ghciLogAction :: IORef [(FastString, Int)] ->  LogAction
489 490
ghciLogAction lastErrLocations dflags flag severity srcSpan style msg = do
    defaultLogAction dflags flag severity srcSpan style msg
491 492 493 494 495 496 497
    case severity of
        SevError -> case srcSpan of
            RealSrcSpan rsp -> modifyIORef lastErrLocations
                (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])
            _ -> return ()
        _ -> return ()

498 499
withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
withGhcAppData right left = do
500
    either_dir <- tryIO (getAppUserDataDirectory "ghc")
501 502 503 504 505
    case either_dir of
        Right dir ->
            do createDirectoryIfMissing False dir `catchIO` \_ -> return ()
               right dir
        _ -> left
506

Ian Lynagh's avatar
Ian Lynagh committed
507 508
runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
runGHCi paths maybe_exprs = do
509
  dflags <- getDynFlags
510
  let
511
   ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags
512

513 514
   current_dir = return (Just ".ghci")

Ian Lynagh's avatar
Ian Lynagh committed
515
   app_user_dir = liftIO $ withGhcAppData
516 517
                    (\dir -> return (Just (dir </> "ghci.conf")))
                    (return Nothing)
518 519

   home_dir = do
520
    either_dir <- liftIO $ tryIO (getEnv "HOME")
521 522 523 524
    case either_dir of
      Right home -> return (Just (home </> ".ghci"))
      _ -> return Nothing

525 526 527 528
   canonicalizePath' :: FilePath -> IO (Maybe FilePath)
   canonicalizePath' fp = liftM Just (canonicalizePath fp)
                `catchIO` \_ -> return Nothing

529 530
   sourceConfigFile :: FilePath -> GHCi ()
   sourceConfigFile file = do
Ian Lynagh's avatar
Ian Lynagh committed
531
     exists <- liftIO $ doesFileExist file
532
     when exists $ do
533 534 535 536 537 538 539 540 541 542
       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 ())
543 544 545 546 547
                -- 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)
548

549 550
  --

551
  setGHCContextFromGHCiState
Ian Lynagh's avatar
Ian Lynagh committed
552

553 554
  dot_cfgs <- if ignore_dot_ghci then return [] else do
    dot_files <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]
555
    liftIO $ filterM checkFileAndDirPerms dot_files
556 557
  mdot_cfgs <- liftIO $ mapM canonicalizePath' dot_cfgs

558 559 560 561
  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)
562
  mapM_ sourceConfigFile $ nub $ (catMaybes mdot_cfgs) ++ arg_cfgs
563
    -- nub, because we don't want to read .ghci twice if the CWD is $HOME.
564

565
  -- Perform a :load for files given on the GHCi command line
566 567 568
  -- 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
569
     ok <- ghciHandle (\e -> do showException e; return Failed) $
570
                -- TODO: this is a hack.
571 572
                runInputTWithPrefs defaultPrefs defaultSettings $
                    loadModule paths
Ian Lynagh's avatar
Ian Lynagh committed
573
     when (isJust maybe_exprs && failed ok) $
Ian Lynagh's avatar
Ian Lynagh committed
574
        liftIO (exitWith (ExitFailure 1))
575

576 577
  installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)

578 579
  -- 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
580
  is_tty <- liftIO (hIsTerminalDevice stdin)
581 582
  let show_prompt = verbosity dflags > 0 || is_tty

583
  -- reset line number
584
  modifyGHCiState $ \st -> st{line_number=0}
585

Ian Lynagh's avatar
Ian Lynagh committed
586
  case maybe_exprs of
Ian Lynagh's avatar
Ian Lynagh committed
587
        Nothing ->
sof's avatar
sof committed
588
          do
Ian Lynagh's avatar
Ian Lynagh committed
589
            -- enter the interactive loop
590
            runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
Ian Lynagh's avatar
Ian Lynagh committed
591
        Just exprs -> do
Ian Lynagh's avatar
Ian Lynagh committed
592
            -- just evaluate the expression we were given
Ian Lynagh's avatar
Ian Lynagh committed
593
            enqueueCommands exprs
dterei's avatar
dterei committed
594 595 596 597 598 599 600 601
            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
602
                                   -- this used to be topHandlerFastExit, see #2228
603
            runInputTWithPrefs defaultPrefs defaultSettings $ do
604
                -- make `ghc -e` exit nonzero on invalid input, see Trac #7962
605 606 607 608
                _ <- runCommands' hdle
                     (Just $ hdle (toException $ ExitFailure 1) >> return ())
                     (return Nothing)
                return ()
609 610

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

613 614
runGHCiInput :: InputT GHCi a -> GHCi a
runGHCiInput f = do
Ian Lynagh's avatar
Ian Lynagh committed
615
    dflags <- getDynFlags
616 617 618 619 620 621 622 623 624 625
    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
626 627 628
    runInputT
        (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})
        f
629

630
-- | How to get the next input line from the user
631 632 633
nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
nextInputLine show_prompt is_tty
  | is_tty = do
dterei's avatar
dterei committed
634 635
    prmpt <- if show_prompt then lift mkPrompt else return ""
    r <- getInputLine prmpt
636 637
    incrementLineNo
    return r
638 639 640
  | otherwise = do
    when show_prompt $ lift mkPrompt >>= liftIO . putStr
    fileLoop stdin
641

642
-- NOTE: We only read .ghci files if they are owned by the current user,
643 644 645
-- 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.
646

rrt's avatar
rrt committed
647 648 649 650
-- 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.
651

652 653
checkFileAndDirPerms :: FilePath -> IO Bool
checkFileAndDirPerms file = do
654
  file_ok <- checkPerms file
thomie's avatar
thomie committed
655 656 657 658
  -- 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.
659
  if file_ok then checkPerms (getDirectory file) else return False
660 661 662 663 664 665
  where
  getDirectory f = case takeDirectory f of
    "" -> "."
    d -> d

checkPerms :: FilePath -> IO Bool
666
#ifdef mingw32_HOST_OS
dterei's avatar
dterei committed
667
checkPerms _ = return True
sof's avatar
sof committed
668
#else
669
checkPerms file =
670
  handleIO (\_ -> return False) $ do
671
    st <- getFileStatus file
dterei's avatar
dterei committed
672
    me <- getRealUserID
673 674 675 676 677
    let mode = System.Posix.fileMode st
        ok = (fileOwner st == me || fileOwner st == 0) &&
             groupWriteMode /= mode `intersectFileModes` groupWriteMode &&
             otherWriteMode /= mode `intersectFileModes` otherWriteMode
    unless ok $
678
      -- #8248: Improving warning to include a possible fix.
679
      putStrLn $ "*** WARNING: " ++ file ++
680
                 " is writable by someone else, IGNORING!" ++
Ben Gamari's avatar
Ben Gamari committed
681
                 "\nSuggested fix: execute 'chmod go-w " ++ file ++ "'"
682
    return ok
sof's avatar
sof committed
683
#endif
684

685
incrementLineNo :: InputT GHCi ()
686 687 688
incrementLineNo = modifyGHCiState incLineNo
  where
    incLineNo st = st { line_number = line_number st + 1 }
vivian's avatar
vivian committed
689 690

fileLoop :: Handle -> InputT GHCi (Maybe String)
691
fileLoop hdl = do
692
   l <- liftIO $ tryIO $ hGetLine hdl
693
   case l of
694
        Left e | isEOFError e              -> return Nothing
695 696 697 698 699
               | -- 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
700
               | InvalidArgument <- etype  -> return Nothing
701
               | otherwise                 -> liftIO $ ioError e
702 703 704 705 706
                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
707
        Right l' -> do
708
           incrementLineNo
dterei's avatar
dterei committed
709
           return (Just l')
710

niksaz's avatar
niksaz committed
711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727
formatCurrentTime :: String -> IO String
formatCurrentTime format =
  getZonedTime >>= return . (formatTime defaultTimeLocale format)

getUserName :: IO String
getUserName = do
#ifdef mingw32_HOST_OS
  getEnv "USERNAME"
    `catchIO` \e -> do
      putStrLn $ show e
      return ""
#else
  getLoginName
#endif

getInfoForPrompt :: GHCi (SDoc, [String], Int)
getInfoForPrompt = do
728
  st <- getGHCiState
729
  imports <- GHC.getContext
730
  resumes <- GHC.getResumeContext
731 732 733 734

  context_bit <-
        case resumes of
            [] -> return empty
Simon Marlow's avatar
Simon Marlow committed
735
            r:_ -> do
736 737 738 739 740
                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
741 742 743
                        pan <- GHC.getHistorySpan hist
                        return (brackets (ppr (negate ix) <> char ':'
                                          <+> ppr pan) <> space)
niksaz's avatar
niksaz committed
744

745
  let
Simon Marlow's avatar
Simon Marlow committed
746
        dots | _:rs <- resumes, not (null rs) = text "... "
747 748
             | otherwise = empty

749 750 751 752
        rev_imports = reverse imports -- rightmost are the most recent

        myIdeclName d | Just m <- ideclAs d = m
                      | otherwise           = unLoc (ideclName d)
753

niksaz's avatar
niksaz committed
754 755 756 757 758 759
        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)
760

niksaz's avatar
niksaz committed
761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853
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
generatePromptFunctionFromString promptS = \_ _ -> do
    (context, modules_names, line) <- getInfoForPrompt

    let
        processString :: String -> GHCi SDoc
        processString ('%':'s':xs) =
            liftM2 (<>) (return modules_list) (processString xs)
            where
              modules_list = context <> modules_bit
              modules_bit = hsep $ map text modules_names
        processString ('%':'l':xs) =
            liftM2 (<>) (return $ ppr line) (processString xs)
        processString ('%':'d':xs) =
            liftM2 (<>) (liftM text formatted_time) (processString xs)
            where
              formatted_time = liftIO $ formatCurrentTime "%a %b %d"
        processString ('%':'t':xs) =
            liftM2 (<>) (liftM text formatted_time) (processString xs)
            where
              formatted_time = liftIO $ formatCurrentTime "%H:%M:%S"
        processString ('%':'T':xs) = do
            liftM2 (<>) (liftM text formatted_time) (processString xs)
            where
              formatted_time = liftIO $ formatCurrentTime "%I:%M:%S"
        processString ('%':'@':xs) = do
            liftM2 (<>) (liftM text formatted_time) (processString xs)
            where
              formatted_time = liftIO $ formatCurrentTime "%I:%M %P"
        processString ('%':'A':xs) = do
            liftM2 (<>) (liftM text formatted_time) (processString xs)
            where
              formatted_time = liftIO $ formatCurrentTime "%H:%M"
        processString ('%':'u':xs) =
            liftM2 (<>) (liftM text user_name) (processString xs)
            where
              user_name = liftIO $ getUserName
        processString ('%':'w':xs) =
            liftM2 (<>) (liftM text current_directory) (processString xs)
            where
              current_directory = liftIO $ getCurrentDirectory
        processString ('%':'o':xs) =
            liftM ((text os) <>) (processString xs)
        processString ('%':'a':xs) =
            liftM ((text arch) <>) (processString xs)
        processString ('%':'N':xs) =
            liftM ((text compilerName) <>) (processString xs)
        processString ('%':'V':xs) =