UI.hs 175 KB
Newer Older
1 2 3 4 5 6 7 8
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
9
{-# LANGUAGE ScopedTypeVariables #-}
10 11
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
wz1000's avatar
wz1000 committed
12
{-# LANGUAGE TypeFamilies #-}
13

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

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

30 31
#include "HsVersions.h"

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

39
-- The GHC interface
40
import GHC.Runtime.Interpreter
41
import GHC.Runtime.Interpreter.Types
42 43
import GHCi.RemoteTypes
import GHCi.BreakArray
Sylvain Henry's avatar
Sylvain Henry committed
44
import GHC.Driver.Session as DynFlags
45
import GHC.Utils.Error hiding (traceCmd)
Sylvain Henry's avatar
Sylvain Henry committed
46 47
import GHC.Driver.Finder as Finder
import GHC.Driver.Monad ( 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
             GetDocsFailure(..),
52
             getModuleGraph, handleSourceError, ms_mod )
Sylvain Henry's avatar
Sylvain Henry committed
53
import GHC.Driver.Main (hscParseDeclsWithLocation, hscParseStmtWithLocation)
54 55
import GHC.Hs.ImpExp
import GHC.Hs
Sylvain Henry's avatar
Sylvain Henry committed
56
import GHC.Driver.Types ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,
57
                  setInteractivePrintName, hsc_dflags, msObjFilePath, runInteractiveHsc,
58
                  hsc_dynLinker, hsc_interp, emptyModBreaks )
59
import GHC.Unit.Module
Sylvain Henry's avatar
Sylvain Henry committed
60
import GHC.Types.Name
Sylvain Henry's avatar
Sylvain Henry committed
61
import GHC.Unit.State   ( unitIsTrusted, unsafeLookupUnit, unsafeLookupUnitId,
62
                          listVisibleModuleNames, pprFlag, preloadUnits )
63
import GHC.Iface.Syntax ( showToHeader )
Sylvain Henry's avatar
Sylvain Henry committed
64
import GHC.Core.Ppr.TyThing
Sylvain Henry's avatar
Sylvain Henry committed
65
import GHC.Builtin.Names
Simon Peyton Jones's avatar
Simon Peyton Jones committed
66
import GHC.Builtin.Types( stringTyCon_RDR )
Sylvain Henry's avatar
Sylvain Henry committed
67 68
import GHC.Types.Name.Reader as RdrName ( getGRE_NameQualifier_maybes, getRdrName )
import GHC.Types.SrcLoc as SrcLoc
Sylvain Henry's avatar
Sylvain Henry committed
69
import qualified GHC.Parser.Lexer as Lexer
dterei's avatar
dterei committed
70

71
import GHC.Data.StringBuffer
72
import GHC.Utils.Outputable hiding ( printForUser )
73

74
import GHC.Runtime.Loader ( initializePlugins )
75

76
-- Other random utilities
Sylvain Henry's avatar
Sylvain Henry committed
77
import GHC.Types.Basic hiding ( isTopLevel )
78
import GHC.Settings.Config
79 80 81
import GHC.Data.Graph.Directed
import GHC.Utils.Encoding
import GHC.Data.FastString
82
import GHC.Runtime.Linker
83
import GHC.Data.Maybe ( orElse, expectJust )
Sylvain Henry's avatar
Sylvain Henry committed
84
import GHC.Types.Name.Set
85
import GHC.Utils.Panic hiding ( showException, try )
86
import GHC.Utils.Misc
87
import qualified GHC.LanguageExtensions as LangExt
88
import GHC.Data.Bag (unitBag)
sof's avatar
sof committed
89

dterei's avatar
dterei committed
90
-- Haskell Libraries
91
import System.Console.Haskeline as Haskeline
92

dterei's avatar
dterei committed
93
import Control.Applicative hiding (empty)
94 95
import Control.DeepSeq (deepseq)
import Control.Monad as Monad
96
import Control.Monad.Catch as MC
97
import Control.Monad.IO.Class
98
import Control.Monad.Trans.Class
99
import Control.Monad.Trans.Except
100

dterei's avatar
dterei committed
101
import Data.Array
Simon Marlow's avatar
Simon Marlow committed
102
import qualified Data.ByteString.Char8 as BS
dterei's avatar
dterei committed
103
import Data.Char
Ian Lynagh's avatar
Ian Lynagh committed
104
import Data.Function
105
import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )
106 107
import Data.List ( elemIndices, find, group, intercalate, intersperse,
                   isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) )
108
import qualified Data.Set as S
109
import Data.Maybe
110
import Data.Map (Map)
111
import qualified Data.Map as M
112
import qualified Data.IntMap.Strict as IntMap
113 114 115
import Data.Time.LocalTime ( getZonedTime )
import Data.Time.Format ( formatTime, defaultTimeLocale )
import Data.Version ( showVersion )
116
import Prelude hiding ((<>))
dterei's avatar
dterei committed
117

118
import GHC.Utils.Exception as Exception hiding (catch, mask, handle)
119
import Foreign hiding (void)
120
import GHC.Stack hiding (SrcLoc(..))
dterei's avatar
dterei committed
121 122

import System.Directory
123
import System.Environment
dterei's avatar
dterei committed
124
import System.Exit ( exitWith, ExitCode(..) )
dterei's avatar
dterei committed
125
import System.FilePath
126
import System.Info
127
import System.IO
128
import System.IO.Error
dterei's avatar
dterei committed
129
import System.IO.Unsafe ( unsafePerformIO )
130
import System.Process
Simon Marlow's avatar
Simon Marlow committed
131
import Text.Printf
132
import Text.Read ( readMaybe )
Geraldus's avatar
Geraldus committed
133
import Text.Read.Lex (isSymbolChar)
134

135 136
import Unsafe.Coerce

Ben Gamari's avatar
Ben Gamari committed
137
#if !defined(mingw32_HOST_OS)
dterei's avatar
dterei committed
138 139 140 141 142
import System.Posix hiding ( getEnv )
#else
import qualified System.Win32
#endif

dterei's avatar
dterei committed
143 144
import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
import GHC.IO.Handle ( hFlushAll )
dterei's avatar
dterei committed
145
import GHC.TopHandler ( topHandler )
146

147 148
import GHCi.Leak

149 150
-----------------------------------------------------------------------------

151 152 153
data GhciSettings = GhciSettings {
        availableCommands :: [Command],
        shortHelpText     :: String,
154
        fullHelpText      :: String,
155 156
        defPrompt         :: PromptFunction,
        defPromptCont     :: PromptFunction
157 158 159 160 161 162 163
    }

defaultGhciSettings :: GhciSettings
defaultGhciSettings =
    GhciSettings {
        availableCommands = ghciCommands,
        shortHelpText     = defShortHelpText,
164
        defPrompt         = default_prompt,
165
        defPromptCont     = default_prompt_cont,
166
        fullHelpText      = defFullHelpText
167 168
    }

169 170
ghciWelcomeMsg :: String
ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
171
                 ": https://www.haskell.org/ghc/  :? for help"
172

173
ghciCommands :: [Command]
174
ghciCommands = map mkCmd [
175 176 177 178
  -- Hugs users are accustomed to :e, so make sure it doesn't overlap
  ("?",         keepGoing help,                 noCompletion),
  ("add",       keepGoingPaths addModule,       completeFilename),
  ("abandon",   keepGoing abandonCmd,           noCompletion),
179
  ("break",     keepGoing breakCmd,             completeBreakpoint),
180 181 182 183 184 185 186
  ("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),
187 188
  ("ctags",     keepGoing createCTagsWithLineNumbersCmd, completeFilename),
  ("ctags!",    keepGoing createCTagsWithRegExesCmd, completeFilename),
189 190 191
  ("def",       keepGoing (defineMacro False),  completeExpression),
  ("def!",      keepGoing (defineMacro True),   completeExpression),
  ("delete",    keepGoing deleteCmd,            noCompletion),
192
  ("disable",   keepGoing disableCmd,           noCompletion),
193
  ("doc",       keepGoing' docCmd,              completeIdentifier),
194
  ("edit",      keepGoing' editFile,            completeFilename),
195
  ("enable",    keepGoing enableCmd,            noCompletion),
196 197 198 199 200
  ("etags",     keepGoing createETagsFileCmd,   completeFilename),
  ("force",     keepGoing forceCmd,             completeExpression),
  ("forward",   keepGoing forwardCmd,           noCompletion),
  ("help",      keepGoing help,                 noCompletion),
  ("history",   keepGoing historyCmd,           noCompletion),
201 202
  ("info",      keepGoing' (info False),        completeIdentifier),
  ("info!",     keepGoing' (info True),         completeIdentifier),
203
  ("issafe",    keepGoing' isSafeCmd,           completeModule),
204 205
  ("kind",      keepGoing' (kindOfType False),  completeIdentifier),
  ("kind!",     keepGoing' (kindOfType True),   completeIdentifier),
206 207
  ("load",      keepGoingPaths loadModule_,     completeHomeModuleOrFile),
  ("load!",     keepGoingPaths loadModuleDefer, completeHomeModuleOrFile),
208
  ("list",      keepGoing' listCmd,             noCompletion),
209
  ("module",    keepGoing moduleCmd,            completeSetModule),
210 211 212
  ("main",      keepGoing runMain,              completeFilename),
  ("print",     keepGoing printCmd,             completeExpression),
  ("quit",      quit,                           noCompletion),
213 214
  ("reload",    keepGoing' reloadModule,        noCompletion),
  ("reload!",   keepGoing' reloadModuleDefer,   noCompletion),
215
  ("run",       keepGoing runRun,               completeFilename),
vivian's avatar
vivian committed
216
  ("script",    keepGoing' scriptCmd,           completeFilename),
217
  ("set",       keepGoing setCmd,               completeSetOptions),
218
  ("seti",      keepGoing setiCmd,              completeSeti),
219
  ("show",      keepGoing showCmd,              completeShowOptions),
220
  ("showi",     keepGoing showiCmd,             completeShowiOptions),
221 222 223 224 225 226
  ("sprint",    keepGoing sprintCmd,            completeExpression),
  ("step",      keepGoing stepCmd,              completeIdentifier),
  ("steplocal", keepGoing stepLocalCmd,         completeIdentifier),
  ("stepmodule",keepGoing stepModuleCmd,        completeIdentifier),
  ("type",      keepGoing' typeOfExpr,          completeExpression),
  ("trace",     keepGoing traceCmd,             completeExpression),
227
  ("unadd",     keepGoingPaths unAddModule,     completeFilename),
228
  ("undef",     keepGoing undefineMacro,        completeMacro),
229
  ("unset",     keepGoing unsetOptions,         completeSetOptions),
xldenis's avatar
xldenis committed
230 231
  ("where",     keepGoing whereCmd,             noCompletion),
  ("instances", keepGoing' instancesCmd,        completeExpression)
232
  ] ++ map mkCmdHidden [ -- hidden commands
233 234 235 236 237
  ("all-types", keepGoing' allTypesCmd),
  ("complete",  keepGoing completeCmd),
  ("loc-at",    keepGoing' locAtCmd),
  ("type-at",   keepGoing' typeAtCmd),
  ("uses",      keepGoing' usesCmd)
238
  ]
239 240 241 242 243 244 245 246 247 248 249 250
 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
                              }
251

dterei's avatar
dterei committed
252
-- We initialize readline (in the interactiveUI function) to use
253 254 255 256
-- 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
257
--
258 259
-- NOTE: in order for us to override the default correctly, any custom entry
-- must be a SUBSET of word_break_chars.
260
word_break_chars :: String
Geraldus's avatar
Geraldus committed
261 262 263 264 265 266
word_break_chars = spaces ++ specials ++ symbols

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

268
flagWordBreakChars :: String
269 270 271
flagWordBreakChars = " \t\n"


272 273 274 275 276
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
277

278
keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
Ian Lynagh's avatar
Ian Lynagh committed
279 280
keepGoingPaths a str
 = do case toArgs str of
Ian Lynagh's avatar
Ian Lynagh committed
281
          Left err -> liftIO $ hPutStrLn stderr err
Ian Lynagh's avatar
Ian Lynagh committed
282 283
          Right args -> a args
      return False
sof's avatar
sof committed
284

285 286
defShortHelpText :: String
defShortHelpText = "use :? for help.\n"
287

288 289
defFullHelpText :: String
defFullHelpText =
dterei's avatar
dterei committed
290 291 292 293 294 295 296 297 298 299
  " 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" ++
300
  "   :complete <dom> [<rng>] <s> list completions for partial input string\n" ++
301
  "   :ctags[!] [<file>]          create tags file <file> for Vi (default: \"tags\")\n" ++
dterei's avatar
dterei committed
302
  "                               (!: use regex instead of line number)\n" ++
303
  "   :def[!] <cmd> <expr>        define command :<cmd> (later defined command has\n" ++
304
  "                               precedence, ::<cmd> is always a builtin command)\n" ++
305
  "                               (!: redefine an existing command name)\n" ++
306
  "   :doc <name>                 display docs for the given name (experimental)\n" ++
dterei's avatar
dterei committed
307 308
  "   :edit <file>                edit file\n" ++
  "   :edit                       edit last module\n" ++
309
  "   :etags [<file>]             create tags file <file> for Emacs (default: \"TAGS\")\n" ++
dterei's avatar
dterei committed
310
  "   :help, :?                   display this list of commands\n" ++
311 312
  "   :info[!] [<name> ...]       display information about the given names\n" ++
  "                               (!: do not filter instances)\n" ++
313
  "   :instances <type>           display the class instances available for <type>\n" ++
dterei's avatar
dterei committed
314
  "   :issafe [<mod>]             display safe haskell information of module <mod>\n" ++
315 316
  "   :kind[!] <type>             show the kind of <type>\n" ++
  "                               (!: also print the normalised type)\n" ++
317 318
  "   :load[!] [*]<module> ...    load module(s) and their dependents\n" ++
  "                               (!: defer type errors)\n" ++
dterei's avatar
dterei committed
319 320 321
  "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
  "   :quit                       exit GHCi\n" ++
322 323
  "   :reload[!]                  reload the current module set\n" ++
  "                               (!: defer type errors)\n" ++
dterei's avatar
dterei committed
324
  "   :run function [<arguments> ...] run the function with the given arguments\n" ++
325
  "   :script <file>              run the script <file>\n" ++
dterei's avatar
dterei committed
326
  "   :type <expr>                show the type of <expr>\n" ++
327 328
  "   :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" ++
329
  "   :unadd <module> ...         remove module(s) from the current target set\n" ++
dterei's avatar
dterei committed
330
  "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
331
  "   ::<cmd>                     run the builtin command\n" ++
dterei's avatar
dterei committed
332 333 334 335 336
  "   :!<command>                 run the shell command <command>\n" ++
  "\n" ++
  " -- Commands for debugging:\n" ++
  "\n" ++
  "   :abandon                    at a breakpoint, abandon current computation\n" ++
337
  "   :back [<n>]                 go back in the history N steps (after :trace)\n" ++
dterei's avatar
dterei committed
338 339 340
  "   :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" ++
341
  "   :delete <number> ...        delete the specified breakpoints\n" ++
dterei's avatar
dterei committed
342
  "   :delete *                   delete all breakpoints\n" ++
343 344 345 346
  "   :disable <number> ...       disable the specified breakpoints\n" ++
  "   :disable *                  disable all breakpoints\n" ++
  "   :enable <number> ...        enable the specified breakpoints\n" ++
  "   :enable *                   enable all breakpoints\n" ++
dterei's avatar
dterei committed
347
  "   :force <expr>               print <expr>, forcing unevaluated parts\n" ++
348
  "   :forward [<n>]              go forward in the history N step s(after :back)\n" ++
dterei's avatar
dterei committed
349 350
  "   :history [<n>]              after :trace, show the execution history\n" ++
  "   :list                       show the source code around current breakpoint\n" ++
351
  "   :list <identifier>          show the source code for <identifier>\n" ++
dterei's avatar
dterei committed
352
  "   :list [<module>] <line>     show the source code around line number <line>\n" ++
Austin Seipp's avatar
Austin Seipp committed
353 354
  "   :print [<name> ...]         show a value without forcing its computation\n" ++
  "   :sprint [<name> ...]        simplified version of :print\n" ++
dterei's avatar
dterei committed
355 356 357 358 359 360
  "   :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
361

dterei's avatar
dterei committed
362 363 364 365
  "\n" ++
  " -- Commands for changing settings:\n" ++
  "\n" ++
  "   :set <option> ...           set options\n" ++
366
  "   :seti <option> ...          set options for interactive evaluation only\n" ++
367 368 369
  "   :set local-config { source | ignore }\n" ++
  "                               set whether to source .ghci in current dir\n" ++
  "                               (loading untrusted config is a security issue)\n" ++
dterei's avatar
dterei committed
370 371 372
  "   :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" ++
373 374
  "   :set prompt-cont <prompt>   set the continuation prompt used in GHCi\n" ++
  "   :set prompt-function <expr> set the function to handle the prompt\n" ++
375 376
  "   :set prompt-cont-function <expr>\n" ++
  "                               set the function to handle the continuation prompt\n" ++
dterei's avatar
dterei committed
377 378 379 380 381 382
  "   :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
383
  "    +m            allow multiline commands\n" ++
dterei's avatar
dterei committed
384 385 386
  "    +r            revert top-level expressions after each evaluation\n" ++
  "    +s            print timing/memory stats after each evaluation\n" ++
  "    +t            print type after evaluation\n" ++
387
  "    +c            collect type/location info after loading modules\n" ++
dterei's avatar
dterei committed
388
  "    -<flags>      most GHC command line flags can also be set here\n" ++
389
  "                         (eg. -v2, -XFlexibleInstances, etc.)\n" ++
dterei's avatar
dterei committed
390 391 392 393 394 395 396 397
  "                    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" ++
398
  "   :show imports               show the current imports\n" ++
399
  "   :show linker                show current linker state\n" ++
dterei's avatar
dterei committed
400 401
  "   :show modules               show the currently loaded modules\n" ++
  "   :show packages              show the currently active package flags\n" ++
402
  "   :show paths                 show the currently active search paths\n" ++
403
  "   :show language              show the currently active language flags\n" ++
404
  "   :show targets               show the current set of targets\n" ++
dterei's avatar
dterei committed
405
  "   :show <setting>             show value of <setting>, which is one of\n" ++
406
  "                                  [args, prog, editor, stop]\n" ++
407
  "   :showi language             show language flags for interactive evaluation\n" ++
408 409 410 411
  "\n" ++
  " The User's Guide has more information. An online copy can be found here:\n" ++
  "\n" ++
  "   https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/ghci.html\n" ++
dterei's avatar
dterei committed
412
  "\n"
413

Simon Marlow's avatar
Simon Marlow committed
414
findEditor :: IO String
Simon Marlow's avatar
Simon Marlow committed
415
findEditor = do
dterei's avatar
dterei committed
416
  getEnv "EDITOR"
417
    `catchIO` \_ -> do
Ben Gamari's avatar
Ben Gamari committed
418
#if defined(mingw32_HOST_OS)
Ian Lynagh's avatar
Ian Lynagh committed
419 420
        win <- System.Win32.getWindowsDirectory
        return (win </> "notepad.exe")
Simon Marlow's avatar
Simon Marlow committed
421
#else
Ian Lynagh's avatar
Ian Lynagh committed
422
        return ""
Simon Marlow's avatar
Simon Marlow committed
423 424
#endif

425
default_progname, default_stop :: String
boris's avatar
boris committed
426 427 428
default_progname = "<interactive>"
default_stop = ""

429 430 431 432
default_prompt, default_prompt_cont :: PromptFunction
default_prompt = generatePromptFunctionFromString "%s> "
default_prompt_cont = generatePromptFunctionFromString "%s| "

Simon Marlow's avatar
Simon Marlow committed
433 434 435
default_args :: [String]
default_args = []

436
interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]
437
              -> Ghc ()
438
interactiveUI config srcs maybe_exprs = do
439 440 441 442 443 444 445 446
   -- 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.
447 448 449
   _ <- liftIO $ newStablePtr stdin
   _ <- liftIO $ newStablePtr stdout
   _ <- liftIO $ newStablePtr stderr
450

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

454
   -- The initial set of DynFlags used for interactive evaluation is the same
455 456
   -- as the global DynFlags, plus -XExtendedDefaultRules and
   -- -XNoMonomorphismRestriction.
457
   -- See note [Changing language extensions for interactive evaluation] #10857
458
   dflags <- getDynFlags
459 460 461 462
   let dflags' = (xopt_set_unlessExplSpec
                      LangExt.ExtendedDefaultRules xopt_set)
               . (xopt_set_unlessExplSpec
                      LangExt.MonomorphismRestriction xopt_unset)
463 464
               $ dflags
   GHC.setInteractiveDynFlags dflags'
465

466 467 468
   lastErrLocationsRef <- liftIO $ newIORef []
   progDynFlags <- GHC.getProgramDynFlags
   _ <- GHC.setProgramDynFlags $
469 470 471 472
      -- Ensure we don't override the user's log action lest we break
      -- -ddump-json (#14078)
      progDynFlags { log_action = ghciLogAction (log_action progDynFlags)
                                                lastErrLocationsRef }
473

474
   when (isNothing maybe_exprs) $ do
Ian Lynagh's avatar
Ian Lynagh committed
475 476 477
        -- Only for GHCi (not runghc and ghc -e):

        -- Turn buffering off for the compiled program's stdout/stderr
478
        turnOffBuffering_ nobuffering
Ian Lynagh's avatar
Ian Lynagh committed
479
        -- Turn buffering off for GHCi's stdout
480 481
        liftIO $ hFlush stdout
        liftIO $ hSetBuffering stdout NoBuffering
Ian Lynagh's avatar
Ian Lynagh committed
482 483
        -- We don't want the cmd line to buffer any input that might be
        -- intended for the program, so unbuffer stdin.
484 485
        liftIO $ hSetBuffering stdin NoBuffering
        liftIO $ hSetBuffering stderr NoBuffering
486
#if defined(mingw32_HOST_OS)
487 488 489
        -- 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.
490
        liftIO $ hSetEncoding stdin utf8
491
#endif
Ian Lynagh's avatar
Ian Lynagh committed
492

493
   default_editor <- liftIO $ findEditor
494
   eval_wrapper <- mkEvalWrapper default_progname default_args
495
   let prelude_import = simpleImportDecl preludeModuleName
Ian Lynagh's avatar
Ian Lynagh committed
496
   startGHCi (runGHCi srcs maybe_exprs)
497
        GHCiState{ progname           = default_progname,
498
                   args               = default_args,
499
                   evalWrapper        = eval_wrapper,
Zejun Wu's avatar
Zejun Wu committed
500 501
                   prompt             = defPrompt config,
                   prompt_cont        = defPromptCont config,
502 503 504
                   stop               = default_stop,
                   editor             = default_editor,
                   options            = [],
505
                   localConfig        = SourceLocalConfig,
506 507 508 509
                   -- 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,
510
                   break_ctr          = 0,
511
                   breaks             = IntMap.empty,
512 513
                   tickarrays         = emptyModuleEnv,
                   ghci_commands      = availableCommands config,
Ben Gamari's avatar
Ben Gamari committed
514
                   ghci_macros        = [],
515
                   last_command       = Nothing,
Zejun Wu's avatar
Zejun Wu committed
516
                   cmd_wrapper        = (cmdSuccess =<<),
517 518 519
                   cmdqueue           = [],
                   remembered_ctx     = [],
                   transient_ctx      = [],
520 521
                   extra_imports      = [],
                   prelude_imports    = [prelude_import],
522 523 524
                   ghc_e              = isJust maybe_exprs,
                   short_help         = shortHelpText config,
                   long_help          = fullHelpText config,
525
                   lastErrorLocations = lastErrLocationsRef,
526
                   mod_infos          = M.empty,
527 528
                   flushStdHandles    = flush,
                   noBuffering        = nobuffering
mnislaih's avatar
mnislaih committed
529
                 }
530

531 532
   return ()

533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558
{-
Note [Changing language extensions for interactive evaluation]
--------------------------------------------------------------
GHCi maintains two sets of options:

- The "loading options" apply when loading modules
- The "interactive options" apply when evaluating expressions and commands
    typed at the GHCi prompt.

The loading options are mostly created in ghc/Main.hs:main' from the command
line flags. In the function ghc/GHCi/UI.hs:interactiveUI the loading options
are copied to the interactive options.

These interactive options (but not the loading options!) are supplemented
unconditionally by setting ExtendedDefaultRules ON and
MonomorphismRestriction OFF. The unconditional setting of these options
eventually overwrite settings already specified at the command line.

Therefore instead of unconditionally setting ExtendedDefaultRules and
NoMonomorphismRestriction for the interactive options, we use the function
'xopt_set_unlessExplSpec' to first check whether the extension has already
specified at the command line.

The ghci config file has not yet been processed.
-}

559
resetLastErrorLocations :: GhciMonad m => m ()
560 561 562 563
resetLastErrorLocations = do
    st <- getGHCiState
    liftIO $ writeIORef (lastErrorLocations st) []

564 565
ghciLogAction :: LogAction -> IORef [(FastString, Int)] ->  LogAction
ghciLogAction old_log_action lastErrLocations
566 567
              dflags flag severity srcSpan msg = do
    old_log_action dflags flag severity srcSpan msg
568 569
    case severity of
        SevError -> case srcSpan of
570
            RealSrcSpan rsp _ -> modifyIORef lastErrLocations
571 572 573 574
                (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])
            _ -> return ()
        _ -> return ()

575 576
withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
withGhcAppData right left = do
577
    either_dir <- tryIO (getAppUserDataDirectory "ghc")
578 579 580 581 582
    case either_dir of
        Right dir ->
            do createDirectoryIfMissing False dir `catchIO` \_ -> return ()
               right dir
        _ -> left
583

Ian Lynagh's avatar
Ian Lynagh committed
584 585
runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
runGHCi paths maybe_exprs = do
586
  dflags <- getDynFlags
587
  let
588
   ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags
589

Ian Lynagh's avatar
Ian Lynagh committed
590
   app_user_dir = liftIO $ withGhcAppData
591 592
                    (\dir -> return (Just (dir </> "ghci.conf")))
                    (return Nothing)
593 594

   home_dir = do
595
    either_dir <- liftIO $ tryIO (getEnv "HOME")
596 597 598 599
    case either_dir of
      Right home -> return (Just (home </> ".ghci"))
      _ -> return Nothing

600 601 602 603
   canonicalizePath' :: FilePath -> IO (Maybe FilePath)
   canonicalizePath' fp = liftM Just (canonicalizePath fp)
                `catchIO` \_ -> return Nothing

604 605
   sourceConfigFile :: FilePath -> GHCi ()
   sourceConfigFile file = do
Ian Lynagh's avatar
Ian Lynagh committed
606
     exists <- liftIO $ doesFileExist file
607
     when exists $ do
608 609 610 611 612 613 614 615 616 617
       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 ())
618 619 620 621 622
                -- 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)
623

624 625
  --

626
  setGHCContextFromGHCiState
Ian Lynagh's avatar
Ian Lynagh committed
627

628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655
  processedCfgs <- if ignore_dot_ghci
    then pure []
    else do
      userCfgs <- do
        paths <- catMaybes <$> sequence [ app_user_dir, home_dir ]
        checkedPaths <- liftIO $ filterM checkFileAndDirPerms paths
        liftIO . fmap (nub . catMaybes) $ mapM canonicalizePath' checkedPaths

      localCfg <- do
        let path = ".ghci"
        ok <- liftIO $ checkFileAndDirPerms path
        if ok then liftIO $ canonicalizePath' path else pure Nothing

      mapM_ sourceConfigFile userCfgs
        -- Process the global and user .ghci
        -- (but not $CWD/.ghci or CLI args, yet)

      behaviour <- localConfig <$> getGHCiState

      processedLocalCfg <- case localCfg of
        Just path | path `notElem` userCfgs ->
          -- don't read .ghci twice if CWD is $HOME
          case behaviour of
            SourceLocalConfig -> localCfg <$ sourceConfigFile path
            IgnoreLocalConfig -> pure Nothing
        _ -> pure Nothing

      pure $ maybe id (:) processedLocalCfg userCfgs
656

657 658 659 660
  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)
661 662 663 664 665

  mapM_ sourceConfigFile $ nub arg_cfgs \\ processedCfgs
    -- Dedup, and remove any configs we already processed.
    -- Importantly, if $PWD/.ghci was ignored due to configuration,
    -- explicitly specifying it does cause it to be processed.
666

667
  -- Perform a :load for files given on the GHCi command line
668 669 670
  -- 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
671
     ok <- ghciHandle (\e -> do showException e; return Failed) $
672
                -- TODO: this is a hack.
673 674
                runInputTWithPrefs defaultPrefs defaultSettings $
                    loadModule paths
Ian Lynagh's avatar
Ian Lynagh committed
675
     when (isJust maybe_exprs && failed ok) $
Ian Lynagh's avatar
Ian Lynagh committed
676
        liftIO (exitWith (ExitFailure 1))
677

678 679
  installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)

680 681
  -- 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
682
  is_tty <- liftIO (hIsTerminalDevice stdin)
683 684
  let show_prompt = verbosity dflags > 0 || is_tty

685
  -- reset line number
686
  modifyGHCiState $ \st -> st{line_number=0}
687

Ian Lynagh's avatar
Ian Lynagh committed
688
  case maybe_exprs of
Ian Lynagh's avatar
Ian Lynagh committed
689
        Nothing ->
sof's avatar
sof committed
690
          do
Ian Lynagh's avatar
Ian Lynagh committed
691
            -- enter the interactive loop
692
            runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
Ian Lynagh's avatar
Ian Lynagh committed
693
        Just exprs -> do
Ian Lynagh's avatar
Ian Lynagh committed
694
            -- just evaluate the expression we were given
Ian Lynagh's avatar
Ian Lynagh committed
695
            enqueueCommands exprs
dterei's avatar
dterei committed
696 697 698 699 700 701 702 703
            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
704
                                   -- this used to be topHandlerFastExit, see #2228
705
            runInputTWithPrefs defaultPrefs defaultSettings $ do
706
                -- make `ghc -e` exit nonzero on invalid input, see #7962
707 708 709 710
                _ <- runCommands' hdle
                     (Just $ hdle (toException $ ExitFailure 1) >> return ())
                     (return Nothing)
                return ()
711 712

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

715 716
runGHCiInput :: InputT GHCi a -> GHCi a
runGHCiInput f = do
Ian Lynagh's avatar
Ian Lynagh committed
717
    dflags <- getDynFlags
718 719 720 721 722 723 724 725 726 727
    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
728 729 730
    runInputT
        (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})
        f
731

732
-- | How to get the next input line from the user
733 734 735
nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
nextInputLine show_prompt is_tty
  | is_tty = do
dterei's avatar
dterei committed
736 737
    prmpt <- if show_prompt then lift mkPrompt else return ""
    r <- getInputLine prmpt
738 739
    incrementLineNo
    return r
740 741 742
  | otherwise = do
    when show_prompt $ lift mkPrompt >>= liftIO . putStr
    fileLoop stdin
743

744
-- NOTE: We only read .ghci files if they are owned by the current user,
745 746 747
-- 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.
748

rrt's avatar
rrt committed
749 750 751 752
-- 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.
753

754 755
checkFileAndDirPerms :: FilePath -> IO Bool
checkFileAndDirPerms file = do
756
  file_ok <- checkPerms file
thomie's avatar
thomie committed
757 758 759 760
  -- 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.
761
  if file_ok then checkPerms (getDirectory file) else return False
762 763 764 765 766 767
  where
  getDirectory f = case takeDirectory f of
    "" -> "."
    d -> d

checkPerms :: FilePath -> IO Bool
Ben Gamari's avatar
Ben Gamari committed
768
#if defined(mingw32_HOST_OS)
dterei's avatar
dterei committed
769
checkPerms _ = return True
sof's avatar
sof committed
770
#else
771
checkPerms file =
772
  handleIO (\_ -> return False) $ do
773
    st <- getFileStatus file
dterei's avatar
dterei committed
774
    me <- getRealUserID
775 776 777 778 779
    let mode = System.Posix.fileMode st
        ok = (fileOwner st == me || fileOwner st == 0) &&
             groupWriteMode /= mode `intersectFileModes` groupWriteMode &&
             otherWriteMode /= mode `intersectFileModes` otherWriteMode
    unless ok $
780
      -- #8248: Improving warning to include a possible fix.
781
      putStrLn $ "*** WARNING: " ++ file ++
782
                 " is writable by someone else, IGNORING!" ++
783
                 "\nSuggested fix: execute 'chmod go-w " ++ file ++ "'"
784
    return ok
sof's avatar
sof committed
785
#endif
786

787
incrementLineNo :: GhciMonad m => m ()
788 789 790
incrementLineNo = modifyGHCiState incLineNo
  where
    incLineNo st = st { line_number = line_number st + 1 }
vivian's avatar
vivian committed
791

792
fileLoop :: GhciMonad m => Handle -> m (Maybe String)
793
fileLoop hdl = do
794
   l <- liftIO $ tryIO $ hGetLine hdl
795
   case l of
796
        Left e | isEOFError e              -> return Nothing
797 798 799 800 801
               | -- 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
802
               | InvalidArgument <- etype  -> return Nothing
803
               | otherwise                 -> liftIO $ ioError e
804 805 806 807 808
                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
809
        Right l' -> do
810
           incrementLineNo
dterei's avatar
dterei committed
811
           return (Just l')
812

813 814 815 816 817 818
formatCurrentTime :: String -> IO String
formatCurrentTime format =
  getZonedTime >>= return . (formatTime defaultTimeLocale format)

getUserName :: IO String
getUserName = do
Ben Gamari's avatar
Ben Gamari committed
819
#if defined(mingw32_HOST_OS)
820 821 822 823 824 825 826 827
  getEnv "USERNAME"
    `catchIO` \e -> do
      putStrLn $ show e
      return ""
#else
  getLoginName
#endif

828
getInfoForPrompt :: GhciMonad m => m (SDoc, [String], Int)
829
getInfoForPrompt = do
830
  st <- getGHCiState
831
  imports <- GHC.getContext
832
  resumes <- GHC.getResumeContext
833 834 835 836

  context_bit <-
        case resumes of
            [] -> return empty
Simon Marlow's avatar
Simon Marlow committed
837
            r:_ -> do
838 839 840 841 842
                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
843 844 845
                        pan <- GHC.getHistorySpan hist
                        return (brackets (ppr (negate ix) <> char ':'
                                          <+> ppr pan) <> space)
846

847
  let
Simon Marlow's avatar
Simon Marlow committed
848
        dots | _:rs <- resumes, not (null rs) = text "... "
849 850
             | otherwise = empty

851 852
        rev_imports = reverse imports -- rightmost are the most recent

853
        myIdeclName d | Just m <- ideclAs d = unLoc m
854
                      | otherwise           = unLoc (ideclName d)
855

856 857 858 859 860 861
        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)
862

863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884
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
Nolan committed
885 886 887
generatePromptFunctionFromString promptS modules_names line =
        processString promptS
  where
888 889 890 891
        processString :: String -> GHCi SDoc
        processString ('%':'s':xs) =
            liftM2 (<>) (return modules_list) (processString xs)
            where
Nolan's avatar
Nolan committed
892
              modules_list = hsep $ map text modules_names
893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955
        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) =
            liftM ((text $ showVersion compilerVersion) <>) (processString xs)
        processString ('%':'c':'a':'l':'l':xs) = do
            respond <- liftIO $ do
                (code, out, err) <-
                    readProcessWithExitCode
                    (head list_words) (tail list_words) ""
                    `catchIO` \e -> return (ExitFailure 1, "", show e)
                case code of
                    ExitSuccess -> return out
                    _ -> do
                        hPutStrLn stderr err
                        return ""
            liftM ((text respond) <>) (processString afterClosed)
            where
              (cmd, afterClosed) = parseCallEscape xs
              list_words = words cmd
        processString ('%':'%':xs) =
            liftM ((char '%') <>) (processString xs)
        processString (x:xs) =
            liftM (char x <>) (processString xs)
        processString "" =
            return empty

mkPrompt :: GHCi String
mkPrompt = do
  st <- getGHCiState
956
  dflags <- getDynFlags
957
  (context, modules_names, line) <- getInfoForPrompt
958

959 960 961 962
  prompt_string <- (prompt st) modules_names line
  let prompt_doc = context <> prompt_string

  return (showSDoc dflags prompt_doc)
963

964
queryQueue :: GhciMonad m => m (Maybe String)
965 966 967 968 969 970 971
queryQueue = do
  st <- getGHCiState
  case cmdqueue st of
    []   -> return Nothing
    c:cs -> do setGHCiState st{ cmdqueue = cs }
               return (Just c)

972
-- Reconfigurable pretty-printing Ticket #5461
973
installInteractivePrint :: GHC.GhcMonad m => Maybe String -> Bool -> m ()
974 975 976
installInteractivePrint Nothing _  = return ()
installInteractivePrint (Just ipFun) exprmode = do
  ok <- trySuccess $ do
977 978 979 980
                names <- GHC.parseName ipFun
                let name = case names of
                             name':_ -> name'
                             [] -> panic "installInteractivePrint"
981
                modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name
982
                                      in he{hsc_IC = new_ic})
983 984 985 986
                return Succeeded

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

987
-- | The main read-eval-print loop
988
runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
989
runCommands gCmd = runCommands' handler Nothing gCmd >> return ()
990

dterei's avatar
dterei committed
991
runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler