InteractiveUI.hs 82.4 KB
Newer Older
1
{-# OPTIONS -#include "Linker.h" #-}
2
3
4
5
-----------------------------------------------------------------------------
--
-- GHC Interactive User Interface
--
6
-- (c) The GHC Team 2005-2006
7
8
--
-----------------------------------------------------------------------------
9

10
module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
11

12
13
#include "HsVersions.h"

mnislaih's avatar
mnislaih committed
14
import GhciMonad
15
import GhciTags
16
import Debugger
17

18
19
-- The GHC interface
import qualified GHC
20
import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
Simon Marlow's avatar
Simon Marlow committed
21
                          Module, ModuleName, TyThing(..), Phase,
22
                          BreakIndex, SrcSpan, Resume, SingleStep )
23
import PprTyThing
24
import DynFlags
25

26
import Packages
27
#ifdef USE_READLINE
28
29
import PackageConfig
import UniqFM
30
31
#endif

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
32
import HscTypes		( implicitTyThings )
33
import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
34
import Outputable       hiding (printForUser, printForUserPartWay)
35
import Module           -- for ModuleEnv
36
import Name
37
import SrcLoc
38
39

-- Other random utilities
40
import Digraph
mnislaih's avatar
mnislaih committed
41
42
import BasicTypes hiding (isTopLevel)
import Panic      hiding (showException)
43
import Config
44
45
46
import StaticFlags
import Linker
import Util
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
47
48
import NameSet
import Maybes		( orElse )
49
import FastString
50
import Encoding
51

52
#ifndef mingw32_HOST_OS
53
import System.Posix hiding (getEnv)
sof's avatar
sof committed
54
55
#else
import GHC.ConsoleHandler ( flushConsole )
56
import qualified System.Win32
sof's avatar
sof committed
57
58
#endif

59
#ifdef USE_READLINE
60
import Control.Concurrent	( yield )	-- Used in readline loop
61
import System.Console.Readline as Readline
62
#endif
63
64
65
66

--import SystemExts

import Control.Exception as Exception
67
-- import Control.Concurrent
68

Simon Marlow's avatar
Simon Marlow committed
69
import qualified Data.ByteString.Char8 as BS
70
import Data.List
71
import Data.Maybe
72
73
import System.Cmd
import System.Environment
74
import System.Exit	( exitWith, ExitCode(..) )
75
import System.Directory
ross's avatar
ross committed
76
77
import System.IO
import System.IO.Error as IO
78
import Data.Char
mnislaih's avatar
mnislaih committed
79
import Data.Dynamic
80
import Data.Array
81
import Control.Monad as Monad
Simon Marlow's avatar
Simon Marlow committed
82
import Text.Printf
83
84
import Foreign
import Foreign.C        ( withCStringLen )
85
import GHC.Exts		( unsafeCoerce# )
Simon Marlow's avatar
Simon Marlow committed
86
import GHC.IOBase	( IOErrorType(InvalidArgument) )
87

88
import Data.IORef	( IORef, readIORef, writeIORef )
89

90
#ifdef USE_READLINE
91
import System.Posix.Internals ( setNonBlockingFD )
92
#endif
93

94
95
-----------------------------------------------------------------------------

96
97
98
ghciWelcomeMsg :: String
ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
                 ": http://www.haskell.org/ghc/  :? for help"
99

100
type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
Simon Marlow's avatar
Simon Marlow committed
101
102

cmdName :: Command -> String
103
cmdName (n,_,_,_) = n
104

Simon Marlow's avatar
Simon Marlow committed
105
106
macros_ref :: IORef [Command]
GLOBAL_VAR(macros_ref, [], [Command])
Simon Marlow's avatar
Simon Marlow committed
107
108

builtin_commands :: [Command]
109
builtin_commands = [
110
111
	-- Hugs users are accustomed to :e, so make sure it doesn't overlap
  ("?",		keepGoing help,			False, completeNone),
112
  ("add",	keepGoingPaths addModule,	False, completeFilename),
113
  ("abandon",   keepGoing abandonCmd,           False, completeNone),
Simon Marlow's avatar
Simon Marlow committed
114
  ("break",     keepGoing breakCmd,             False, completeIdentifier),
115
  ("back",      keepGoing backCmd,              False, completeNone),
116
117
  ("browse",    keepGoing (browseCmd False),	False, completeModule),
  ("browse!",   keepGoing (browseCmd True),	False, completeModule),
118
  ("cd",    	keepGoing changeDirectory,	False, completeFilename),
119
  ("check",	keepGoing checkModule,		False, completeHomeModule),
120
  ("continue",  keepGoing continueCmd,          False, completeNone),
Simon Marlow's avatar
Simon Marlow committed
121
  ("cmd",       keepGoing cmdCmd,               False, completeIdentifier),
122
  ("ctags",	keepGoing createCTagsFileCmd, 	False, completeFilename),
Simon Marlow's avatar
Simon Marlow committed
123
124
  ("def",	keepGoing (defineMacro False),  False, completeIdentifier),
  ("def!",	keepGoing (defineMacro True),   False, completeIdentifier),
Simon Marlow's avatar
Simon Marlow committed
125
  ("delete",    keepGoing deleteCmd,            False, completeNone),
Simon Marlow's avatar
Simon Marlow committed
126
127
  ("e", 	keepGoing editFile,		False, completeFilename),
  ("edit",	keepGoing editFile,		False, completeFilename),
128
  ("etags",	keepGoing createETagsFileCmd,	False, completeFilename),
129
  ("force",     keepGoing forceCmd,             False, completeIdentifier),
130
  ("forward",   keepGoing forwardCmd,           False, completeNone),
131
  ("help",	keepGoing help,			False, completeNone),
132
  ("history",   keepGoing historyCmd,           False, completeNone), 
133
  ("info",      keepGoing info,			False, completeIdentifier),
134
  ("kind",	keepGoing kindOfType,		False, completeIdentifier),
135
  ("load",	keepGoingPaths loadModule_,     False, completeHomeModuleOrFile),
Simon Marlow's avatar
Simon Marlow committed
136
  ("list",	keepGoing listCmd,              False, completeNone),
137
  ("module",	keepGoing setContext,		False, completeModule),
138
  ("main",	keepGoing runMain,		False, completeIdentifier),
139
  ("print",     keepGoing printCmd,             False, completeIdentifier),
140
  ("quit",	quit,				False, completeNone),
141
  ("reload", 	keepGoing reloadModule,  	False, completeNone),
142
143
  ("set",	keepGoing setCmd,		True,  completeSetOptions),
  ("show",	keepGoing showCmd,		False, completeNone),
144
  ("sprint",    keepGoing sprintCmd,            False, completeIdentifier),
145
  ("step",      keepGoing stepCmd,              False, completeIdentifier), 
146
147
  ("steplocal", keepGoing stepLocalCmd,         False, completeIdentifier), 
  ("stepmodule",keepGoing stepModuleCmd,        False, completeIdentifier), 
148
  ("type",	keepGoing typeOfExpr,		False, completeIdentifier),
149
  ("trace",     keepGoing traceCmd,             False, completeIdentifier), 
150
  ("undef",     keepGoing undefineMacro,	False, completeMacro),
151
  ("unset",	keepGoing unsetOptions,		True,  completeSetOptions)
152
153
  ]

154
155
156
keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
keepGoing a str = a str >> return False

sof's avatar
sof committed
157
158
159
keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
keepGoingPaths a str = a (toArgs str) >> return False

Simon Marlow's avatar
Simon Marlow committed
160
shortHelpText :: String
161
162
shortHelpText = "use :? for help.\n"

Simon Marlow's avatar
Simon Marlow committed
163
helpText :: String
164
165
166
helpText =
 " Commands available from the prompt:\n" ++
 "\n" ++
167
 "   <statement>                 evaluate/run <statement>\n" ++
168
 "   :{\\n ..lines.. \\n:}\\n       multiline command\n" ++
169
 "   :add <filename> ...         add module(s) to the current target set\n" ++
170
171
 "   :browse[!] [[*]<mod>]       display the names defined by module <mod>\n" ++
 "                               (!: more details; *: all top-level names)\n" ++
172
 "   :cd <dir>                   change directory to <dir>\n" ++
173
 "   :cmd <expr>                 run the commands returned by <expr>::IO String\n" ++
Simon Marlow's avatar
Simon Marlow committed
174
 "   :ctags [<file>]             create tags file for Vi (default: \"tags\")\n" ++
175
 "   :def <cmd> <expr>           define a command :<cmd>\n" ++
Simon Marlow's avatar
Simon Marlow committed
176
177
 "   :edit <file>                edit file\n" ++
 "   :edit                       edit last module\n" ++
Simon Marlow's avatar
Simon Marlow committed
178
 "   :etags [<file>]             create tags file for Emacs (default: \"TAGS\")\n" ++
179
180
 "   :help, :?                   display this list of commands\n" ++
 "   :info [<name> ...]          display information about the given names\n" ++
Simon Marlow's avatar
Simon Marlow committed
181
 "   :kind <type>                show the kind of <type>\n" ++
182
 "   :load <filename> ...        load module(s) and their dependents\n" ++
183
 "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
184
 "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
Simon Marlow's avatar
Simon Marlow committed
185
 "   :quit                       exit GHCi\n" ++
186
 "   :reload                     reload the current module set\n" ++
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
 "   :type <expr>                show the type of <expr>\n" ++
 "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
 "   :!<command>                 run the shell command <command>\n" ++
 "\n" ++
 " -- Commands for debugging:\n" ++
 "\n" ++
 "   :abandon                    at a breakpoint, abandon current computation\n" ++
 "   :back                       go back in the history (after :trace)\n" ++
 "   :break [<mod>] <l> [<col>]  set a breakpoint at the specified location\n" ++
 "   :break <name>               set a breakpoint on the specified function\n" ++
 "   :continue                   resume after a breakpoint\n" ++
 "   :delete <number>            delete the specified breakpoint\n" ++
 "   :delete *                   delete all breakpoints\n" ++
 "   :force <expr>               print <expr>, forcing unevaluated parts\n" ++
 "   :forward                    go forward in the history (after :back)\n" ++
 "   :history [<n>]              show the last <n> items in the history (after :trace)\n" ++
 "   :print [<name> ...]         prints a value without forcing its computation\n" ++
Simon Marlow's avatar
Simon Marlow committed
204
 "   :sprint [<name> ...]        simplifed version of :print\n" ++
205
206
 "   :step                       single-step after stopping at a breakpoint\n"++
 "   :step <expr>                single-step into <expr>\n"++
207
208
 "   :steplocal                  single-step restricted to the current top level decl.\n"++
 "   :stepmodule                 single-step restricted to the current module\n"++
209
210
211
212
213
 "   :trace                      trace after stopping at a breakpoint\n"++
 "   :trace <expr>               trace into <expr> (remembers breakpoints for :history)\n"++

 "\n" ++
 " -- Commands for changing settings:\n" ++
214
215
216
217
 "\n" ++
 "   :set <option> ...           set options\n" ++
 "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
 "   :set prog <progname>        set the value returned by System.getProgName\n" ++
Simon Marlow's avatar
Simon Marlow committed
218
 "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
Ian Lynagh's avatar
Ian Lynagh committed
219
 "   :set editor <cmd>           set the command used for :edit\n" ++
Simon Marlow's avatar
Simon Marlow committed
220
 "   :set stop <cmd>             set the command to run when a breakpoint is hit\n" ++
221
222
 "   :unset <option> ...         unset options\n" ++
 "\n" ++
223
 "  Options for ':set' and ':unset':\n" ++
224
225
226
227
228
 "\n" ++
 "    +r            revert top-level expressions after each evaluation\n" ++
 "    +s            print timing/memory stats after each evaluation\n" ++
 "    +t            print type after evaluation\n" ++
 "    -<flags>      most GHC command line flags can also be set here\n" ++
mnislaih's avatar
mnislaih committed
229
 "                         (eg. -v2, -fglasgow-exts, etc.)\n" ++
230
231
 "                    for GHCi-specific flags, see User's Guide,\n"++
 "                    Flag reference, Interactive-mode options\n" ++
232
233
234
235
236
237
238
 "\n" ++
 " -- Commands for displaying information:\n" ++
 "\n" ++
 "   :show bindings              show the current bindings made at the prompt\n" ++
 "   :show breaks                show the active breakpoints\n" ++
 "   :show context               show the breakpoint context\n" ++
 "   :show modules               show the currently loaded modules\n" ++
239
240
 "   :show packages              show the currently active package flags\n" ++
 "   :show languages             show the currently active language flags\n" ++
241
 "   :show <setting>             show anything that can be set with :set (e.g. args)\n" ++
242
 "\n" 
243

Simon Marlow's avatar
Simon Marlow committed
244
findEditor :: IO String
Simon Marlow's avatar
Simon Marlow committed
245
246
247
findEditor = do
  getEnv "EDITOR" 
    `IO.catch` \_ -> do
248
249
#if mingw32_HOST_OS
	win <- System.Win32.getWindowsDirectory
Simon Marlow's avatar
Simon Marlow committed
250
	return (win `joinFileName` "notepad.exe")
Simon Marlow's avatar
Simon Marlow committed
251
252
253
254
#else
	return ""
#endif

255
interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
256
interactiveUI session srcs maybe_expr = do
257
258
259
260
261
262
263
264
265
266
267
268
   -- 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.
   newStablePtr stdin
   newStablePtr stdout
   newStablePtr stderr

Ian Lynagh's avatar
Ian Lynagh committed
269
    -- Initialise buffering for the *interpreted* I/O system
270
   initInterpBuffering session
271

272
   when (isNothing maybe_expr) $ do
Ian Lynagh's avatar
Ian Lynagh committed
273
274
275
276
277
278
279
280
281
282
283
284
        -- Only for GHCi (not runghc and ghc -e):

        -- Turn buffering off for the compiled program's stdout/stderr
        turnOffBuffering
        -- Turn buffering off for GHCi's stdout
        hFlush stdout
        hSetBuffering stdout NoBuffering
        -- We don't want the cmd line to buffer any input that might be
        -- intended for the program, so unbuffer stdin.
        hSetBuffering stdin NoBuffering

        -- initial context is just the Prelude
Simon Marlow's avatar
Simon Marlow committed
285
286
   prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude") 
                                      (Just basePackageId)
Simon Marlow's avatar
Simon Marlow committed
287
   GHC.setContext session [] [prel_mod]
288

289
#ifdef USE_READLINE
290
   Readline.initialize
Simon Marlow's avatar
Simon Marlow committed
291
292
293
294
295
296
297
298
299
300
   Readline.setAttemptedCompletionFunction (Just completeWord)
   --Readline.parseAndBind "set show-all-if-ambiguous 1"

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

   Readline.setBasicWordBreakCharacters word_break_chars
   Readline.setCompleterWordBreakCharacters word_break_chars
301
302
#endif

Simon Marlow's avatar
Simon Marlow committed
303
304
   default_editor <- findEditor

305
   startGHCi (runGHCi srcs maybe_expr)
306
307
	GHCiState{ progname = "<interactive>",
		   args = [],
Simon Marlow's avatar
Simon Marlow committed
308
                   prompt = "%s> ",
Simon Marlow's avatar
Simon Marlow committed
309
                   stop = "",
Simon Marlow's avatar
Simon Marlow committed
310
		   editor = default_editor,
311
		   session = session,
Simon Marlow's avatar
Simon Marlow committed
312
		   options = [],
mnislaih's avatar
mnislaih committed
313
                   prelude = prel_mod,
314
315
                   break_ctr = 0,
                   breaks = [],
316
                   tickarrays = emptyModuleEnv,
Simon Marlow's avatar
Simon Marlow committed
317
318
                   cmdqueue = [],
                   remembered_ctx = Nothing
mnislaih's avatar
mnislaih committed
319
                 }
rrt's avatar
rrt committed
320

321
#ifdef USE_READLINE
rrt's avatar
rrt committed
322
323
324
   Readline.resetTerminal Nothing
#endif

325
326
   return ()

327
runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
328
runGHCi paths maybe_expr = do
329
  let read_dot_files = not opt_IgnoreDotGhci
330
331
332
333
334
335
336
337
338
339
340

  when (read_dot_files) $ do
    -- Read in ./.ghci.
    let file = "./.ghci"
    exists <- io (doesFileExist file)
    when exists $ do
       dir_ok  <- io (checkPerms ".")
       file_ok <- io (checkPerms file)
       when (dir_ok && file_ok) $ do
  	  either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
  	  case either_hdl of
Simon Marlow's avatar
Simon Marlow committed
341
  	     Left _e   -> return ()
342
  	     Right hdl -> runCommands (fileLoop hdl False False)
343
344
345
    
  when (read_dot_files) $ do
    -- Read in $HOME/.ghci
346
    either_dir <- io (IO.try getHomeDirectory)
347
    case either_dir of
Simon Marlow's avatar
Simon Marlow committed
348
       Left _e -> return ()
349
350
351
352
353
354
355
356
       Right dir -> do
  	  cwd <- io (getCurrentDirectory)
  	  when (dir /= cwd) $ do
  	     let file = dir ++ "/.ghci"
  	     ok <- io (checkPerms file)
  	     when ok $ do
  	       either_hdl <- io (IO.try (openFile file ReadMode))
  	       case either_hdl of
Simon Marlow's avatar
Simon Marlow committed
357
  		  Left _e   -> return ()
358
  		  Right hdl -> runCommands (fileLoop hdl False False)
359

360
  -- Perform a :load for files given on the GHCi command line
361
362
363
364
365
366
367
  -- 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
     ok <- ghciHandle (\e -> do showException e; return Failed) $ 
		loadModule paths
     when (isJust maybe_expr && failed ok) $
	io (exitWith (ExitFailure 1))
368

369
370
  -- if verbosity is greater than 0, or we are connected to a
  -- terminal, display the prompt in the interactive loop.
371
  is_tty <- io (hIsTerminalDevice stdin)
372
  dflags <- getDynFlags
373
374
  let show_prompt = verbosity dflags > 0 || is_tty

375
  case maybe_expr of
Ian Lynagh's avatar
Ian Lynagh committed
376
        Nothing ->
sof's avatar
sof committed
377
          do
Simon Marlow's avatar
Simon Marlow committed
378
#if defined(mingw32_HOST_OS)
Ian Lynagh's avatar
Ian Lynagh committed
379
            -- The win32 Console API mutates the first character of
sof's avatar
sof committed
380
381
382
383
            -- type-ahead when reading from it in a non-buffered manner. Work
            -- around this by flushing the input buffer of type-ahead characters,
            -- but only if stdin is available.
            flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
Ian Lynagh's avatar
Ian Lynagh committed
384
385
386
387
            case flushed of
             Left err | isDoesNotExistError err -> return ()
                      | otherwise -> io (ioError err)
             Right () -> return ()
sof's avatar
sof committed
388
#endif
Ian Lynagh's avatar
Ian Lynagh committed
389
390
391
392
393
394
            -- enter the interactive loop
            interactiveLoop is_tty show_prompt
        Just expr -> do
            -- just evaluate the expression we were given
            runCommandEval expr
            return ()
395
396

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


Simon Marlow's avatar
Simon Marlow committed
400
interactiveLoop :: Bool -> Bool -> GHCi ()
401
interactiveLoop is_tty show_prompt =
402
  -- Ignore ^C exceptions caught here
403
  ghciHandleDyn (\e -> case e of 
404
			Interrupted -> do
sof's avatar
sof committed
405
#if defined(mingw32_HOST_OS)
406
				io (putStrLn "")
sof's avatar
sof committed
407
#endif
408
409
410
411
412
				interactiveLoop is_tty show_prompt
			_other      -> return ()) $ 

  ghciUnblock $ do -- unblock necessary if we recursed from the 
		   -- exception handler above.
413

414
  -- read commands from stdin
415
#ifdef USE_READLINE
416
  if (is_tty) 
417
	then runCommands readlineLoop
418
	else runCommands (fileLoop stdin show_prompt is_tty)
419
#else
420
  runCommands (fileLoop stdin show_prompt is_tty)
421
#endif
422
423


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

rrt's avatar
rrt committed
428
429
430
431
-- 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.
432
433

checkPerms :: String -> IO Bool
434
#ifdef mingw32_HOST_OS
Simon Marlow's avatar
Simon Marlow committed
435
checkPerms _ =
436
  return True
sof's avatar
sof committed
437
#else
Simon Marlow's avatar
Simon Marlow committed
438
checkPerms name =
439
  Util.handle (\_ -> return False) $ do
440
441
442
443
444
445
446
447
448
449
450
451
452
453
     st <- getFileStatus name
     me <- getRealUserID
     if fileOwner st /= me then do
   	putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
   	return False
      else do
   	let mode =  fileMode st
   	if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
   	   || (otherWriteMode == (mode `intersectFileModes` otherWriteMode)) 
   	   then do
   	       putStrLn $ "*** WARNING: " ++ name ++ 
   			  " is writable by someone else, IGNORING!"
   	       return False
   	  else return True
sof's avatar
sof committed
454
#endif
455

456
457
fileLoop :: Handle -> Bool -> Bool -> GHCi (Maybe String)
fileLoop hdl show_prompt is_tty = do
458
459
460
   when show_prompt $ do
        prompt <- mkPrompt
        (io (putStr prompt))
461
462
   l <- io (IO.try (hGetLine hdl))
   case l of
463
464
465
466
467
468
469
470
        Left e | isEOFError e              -> return Nothing
               | InvalidArgument <- etype  -> return Nothing
               | otherwise                 -> io (ioError e)
                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.
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
        Right l -> do
                   str <- io $ consoleInputToUnicode is_tty l
                   return (Just str)

#ifdef mingw32_HOST_OS
-- Convert the console input into Unicode according to the current code page.
-- The Windows console stores Unicode characters directly, so this is a
-- rather roundabout way of doing things... oh well.
-- See #782, #1483, #1649
consoleInputToUnicode :: Bool -> String -> IO String
consoleInputToUnicode is_tty str
  | is_tty = do
    cp <- System.Win32.getConsoleCP
    System.Win32.stringToUnicode cp str
  | otherwise =
    decodeStringAsUTF8 str
#else
-- for Unix, assume the input is in UTF-8 and decode it to a Unicode String. 
-- See #782.
consoleInputToUnicode :: Bool -> String -> IO String
consoleInputToUnicode _is_tty str = decodeStringAsUTF8 str
#endif

decodeStringAsUTF8 :: String -> IO String
decodeStringAsUTF8 str =
  withCStringLen str $ \(cstr,len) -> 
    utf8DecodeString (castPtr cstr :: Ptr Word8) len
498

Simon Marlow's avatar
Simon Marlow committed
499
mkPrompt :: GHCi String
500
501
502
503
mkPrompt = do
  session <- getSession
  (toplevs,exports) <- io (GHC.getContext session)
  resumes <- io $ GHC.getResumeContext session
Simon Marlow's avatar
Simon Marlow committed
504
  -- st <- getGHCiState
505
506
507
508

  context_bit <-
        case resumes of
            [] -> return empty
Simon Marlow's avatar
Simon Marlow committed
509
            r:_ -> do
510
511
512
513
514
                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)
515
                        span <- io$ GHC.getHistorySpan session hist
516
517
518
                        return (brackets (ppr (negate ix) <> char ':' 
                                          <+> ppr span) <> space)
  let
Simon Marlow's avatar
Simon Marlow committed
519
        dots | _:rs <- resumes, not (null rs) = text "... "
520
521
             | otherwise = empty

Simon Marlow's avatar
Simon Marlow committed
522
523
        

524
        modules_bit = 
Simon Marlow's avatar
Simon Marlow committed
525
526
527
528
529
       -- ToDo: maybe...
       --  let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
       --  hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
       --  hsep (map (\m -> char '!'  <> ppr (GHC.moduleName m)) bexports) <+>
             hsep (map (\m -> char '*'  <> ppr (GHC.moduleName m)) toplevs) <+>
530
531
             hsep (map (ppr . GHC.moduleName) exports)

532
533
534
535
536
537
538
539
540
        deflt_prompt = dots <> context_bit <> modules_bit

        f ('%':'s':xs) = deflt_prompt <> f xs
        f ('%':'%':xs) = char '%' <> f xs
        f (x:xs) = char x <> f xs
        f [] = empty
   --
  st <- getGHCiState
  return (showSDoc (f (prompt st)))
541

542

543
#ifdef USE_READLINE
544
readlineLoop :: GHCi (Maybe String)
545
readlineLoop = do
546
   io yield
Simon Marlow's avatar
Simon Marlow committed
547
   saveSession -- for use by completion
548
549
   prompt <- mkPrompt
   l <- io (readline prompt `finally` setNonBlockingFD 0)
550
551
                -- readline sometimes puts stdin into blocking mode,
                -- so we need to put it back for the IO library
Simon Marlow's avatar
Simon Marlow committed
552
   splatSavedSession
553
   case l of
554
555
556
        Nothing -> return Nothing
        Just l  -> do
                   io (addHistory l)
557
558
                   str <- io $ consoleInputToUnicode True l
                   return (Just str)
559
#endif
560

561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
queryQueue :: GHCi (Maybe String)
queryQueue = do
  st <- getGHCiState
  case cmdqueue st of
    []   -> return Nothing
    c:cs -> do setGHCiState st{ cmdqueue = cs }
               return (Just c)

runCommands :: GHCi (Maybe String) -> GHCi ()
runCommands getCmd = do
  mb_cmd <- noSpace queryQueue
  mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
  case mb_cmd of 
    Nothing -> return ()
    Just c  -> do
      b <- ghciHandle handler (doCommand c)
      if b then return () else runCommands getCmd
578
  where
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
    noSpace q = q >>= maybe (return Nothing)
                            (\c->case removeSpaces c of 
                                   ""   -> noSpace q
                                   ":{" -> multiLineCmd q
                                   c    -> return (Just c) )
    multiLineCmd q = do
      st <- getGHCiState
      let p = prompt st
      setGHCiState st{ prompt = "%s| " }
      mb_cmd <- collectCommand q ""
      getGHCiState >>= \st->setGHCiState st{ prompt = p }
      return mb_cmd
    -- we can't use removeSpaces for the sublines here, so 
    -- multiline commands are somewhat more brittle against
    -- fileformat errors (such as \r in dos input on unix), 
    -- we get rid of any extra spaces for the ":}" test; 
    -- we also avoid silent failure if ":}" is not found;
    -- and since there is no (?) valid occurrence of \r (as 
    -- opposed to its String representation, "\r") inside a
    -- ghci command, we replace any such with ' ' (argh:-(
    collectCommand q c = q >>= 
      maybe (io (ioError collectError))
            (\l->if removeSpaces l == ":}" 
                 then return (Just $ removeSpaces c) 
                 else collectCommand q (c++map normSpace l))
      where normSpace '\r' = ' '
            normSpace   c  = c
    -- QUESTION: is userError the one to use here?
    collectError = userError "unterminated multiline command :{ .. :}"
    doCommand (':' : cmd) = specialCommand cmd
    doCommand stmt        = do timeIt $ runStmt stmt GHC.RunToCompletion
                               return False
611
612
613
614
615
616

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

617

618
619
620
-- This version is for the GHC command-line option -e.  The only difference
-- from runCommand is that it catches the ExitException exception and
-- exits, rather than printing out the exception.
Simon Marlow's avatar
Simon Marlow committed
621
runCommandEval :: String -> GHCi Bool
622
623
624
runCommandEval c = ghciHandle handleEval (doCommand c)
  where 
    handleEval (ExitException code) = io (exitWith code)
625
    handleEval e                    = do handler e
626
627
				         io (exitWith (ExitFailure 1))

628
629
    doCommand (':' : command) = specialCommand command
    doCommand stmt
630
       = do r <- runStmt stmt GHC.RunToCompletion
631
632
	    case r of 
		False -> io (exitWith (ExitFailure 1))
633
		  -- failure to run the command causes exit(1) for ghc -e.
634
		_       -> return True
635

636
637
runStmt :: String -> SingleStep -> GHCi Bool
runStmt stmt step
638
 | null (filter (not.isSpace) stmt) = return False
639
 | ["import", mod] <- words stmt    = keepGoing setContext ('+':mod)
640
 | otherwise
641
 = do st <- getGHCiState
642
643
      session <- getSession
      result <- io $ withProgName (progname st) $ withArgs (args st) $
644
	     	     GHC.runStmt session stmt step
645
      afterRunStmt (const True) result
646

647

648
--afterRunStmt :: GHC.RunResult -> GHCi Bool
Simon Marlow's avatar
Simon Marlow committed
649
                                 -- False <=> the statement failed to compile
Simon Marlow's avatar
Simon Marlow committed
650
afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
651
afterRunStmt _ (GHC.RunException e) = throw e
652
afterRunStmt step_here run_result = do
653
654
  session     <- getSession
  resumes <- io $ GHC.getResumeContext session
Simon Marlow's avatar
Simon Marlow committed
655
656
657
  case run_result of
     GHC.RunOk names -> do
        show_types <- isOptionSet ShowType
658
        when show_types $ printTypeOfNames session names
659
660
     GHC.RunBreak _ names mb_info 
         | isNothing  mb_info || 
661
           step_here (GHC.resumeSpan $ head resumes) -> do
662
663
               printForUser $ ptext SLIT("Stopped at") <+> 
                       ppr (GHC.resumeSpan $ head resumes)
664
--               printTypeOfNames session names
665
666
667
               let namesSorted = sortBy compareNames names
               tythings <- catMaybes `liftM` 
                              io (mapM (GHC.lookupName session) namesSorted)
668
669
               docs <- io$ pprTypeAndContents session [id | AnId id <- tythings]
               printForUserPartWay docs
670
671
672
673
674
675
               maybe (return ()) runBreakCmd mb_info
               -- run the command set with ":set stop <cmd>"
               st <- getGHCiState
               enqueueCommands [stop st]
               return ()
         | otherwise -> io(GHC.resume session GHC.SingleStep) >>= 
676
                        afterRunStmt step_here >> return ()
Simon Marlow's avatar
Simon Marlow committed
677
678
     _ -> return ()

679
680
681
682
683
  flushInterpBuffers
  io installSignalHandlers
  b <- isOptionSet RevertCAFs
  io (when b revertCAFs)

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

686
687
688
689
690
runBreakCmd :: GHC.BreakInfo -> GHCi ()
runBreakCmd info = do
  let mod = GHC.breakInfo_module info
      nm  = GHC.breakInfo_number info
  st <- getGHCiState
Simon Marlow's avatar
Simon Marlow committed
691
  case  [ loc | (_,loc) <- breaks st,
692
693
694
695
696
                breakModule loc == mod, breakTick loc == nm ] of
        []  -> return ()
        loc:_ | null cmd  -> return ()
              | otherwise -> do enqueueCommands [cmd]; return ()
              where cmd = onBreakCmd loc
697

698
699
printTypeOfNames :: Session -> [Name] -> GHCi ()
printTypeOfNames session names
700
701
702
703
 = mapM_ (printTypeOfName session) $ sortBy compareNames names

compareNames :: Name -> Name -> Ordering
n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
704
705
706
707
    where compareWith n = (getOccString n, getSrcSpan n)

printTypeOfName :: Session -> Name -> GHCi ()
printTypeOfName session n
708
   = do maybe_tything <- io (GHC.lookupName session n)
709
710
711
        case maybe_tything of
            Nothing    -> return ()
            Just thing -> printTyThing thing
712

713

714
715


716
specialCommand :: String -> GHCi Bool
717
specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
718
719
specialCommand str = do
  let (cmd,rest) = break isSpace str
Simon Marlow's avatar
Simon Marlow committed
720
721
722
  maybe_cmd <- io (lookupCommand cmd)
  case maybe_cmd of
    Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n" 
723
		                    ++ shortHelpText) >> return False)
724
    Just (_,f,_,_) -> f (dropWhile isSpace rest)
Simon Marlow's avatar
Simon Marlow committed
725
726
727

lookupCommand :: String -> IO (Maybe Command)
lookupCommand str = do
Simon Marlow's avatar
Simon Marlow committed
728
729
  macros <- readIORef macros_ref
  let cmds = builtin_commands ++ macros
Simon Marlow's avatar
Simon Marlow committed
730
731
732
  -- look for exact match first, then the first prefix match
  case [ c | c <- cmds, str == cmdName c ] of
     c:_ -> return (Just c)
733
     [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
Simon Marlow's avatar
Simon Marlow committed
734
735
     		[] -> return Nothing
     		c:_ -> return (Just c)
736

737
738
739
740
741
742
743

getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
getCurrentBreakSpan = do
  session <- getSession
  resumes <- io $ GHC.getResumeContext session
  case resumes of
    [] -> return Nothing
Simon Marlow's avatar
Simon Marlow committed
744
    (r:_) -> do
745
746
747
748
749
750
751
752
        let ix = GHC.resumeHistoryIx r
        if ix == 0
           then return (Just (GHC.resumeSpan r))
           else do
                let hist = GHC.resumeHistory r !! (ix-1)
                span <- io $ GHC.getHistorySpan session hist
                return (Just span)

753
754
755
756
757
758
getCurrentBreakModule :: GHCi (Maybe Module)
getCurrentBreakModule = do
  session <- getSession
  resumes <- io $ GHC.getResumeContext session
  case resumes of
    [] -> return Nothing
Simon Marlow's avatar
Simon Marlow committed
759
    (r:_) -> do
760
761
        let ix = GHC.resumeHistoryIx r
        if ix == 0
mnislaih's avatar
mnislaih committed
762
           then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
763
764
765
766
           else do
                let hist = GHC.resumeHistory r !! (ix-1)
                return $ Just $ GHC.getHistoryModule  hist

767
768
769
-----------------------------------------------------------------------------
-- Commands

770
771
noArgs :: GHCi () -> String -> GHCi ()
noArgs m "" = m
Simon Marlow's avatar
Simon Marlow committed
772
noArgs _ _  = io $ putStrLn "This command takes no arguments"
773

774
775
776
help :: String -> GHCi ()
help _ = io (putStr helpText)

rrt's avatar
rrt committed
777
info :: String -> GHCi ()
778
info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
779
info s  = do { let names = words s
780
	     ; session <- getSession
781
	     ; dflags <- getDynFlags
782
783
	     ; let pefas = dopt Opt_PrintExplicitForalls dflags
	     ; mapM_ (infoThing pefas session) names }
784
  where
785
    infoThing pefas session str = io $ do
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
786
787
	names     <- GHC.parseName session str
	mb_stuffs <- mapM (GHC.getInfo session) names
Simon Marlow's avatar
Simon Marlow committed
788
	let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
789
790
791
	unqual <- GHC.getPrintUnqual session
	putStrLn (showSDocForUser unqual $
     		   vcat (intersperse (text "") $
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
792
		         map (pprInfo pefas) filtered))
793
794
795
796

  -- Filter out names whose parent is also there Good
  -- example is '[]', which is both a type and data
  -- constructor in the same type
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
797
798
799
800
801
filterOutChildren :: (a -> TyThing) -> [a] -> [a]
filterOutChildren get_thing xs 
  = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
  where
    implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
802

803
804
805
pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
pprInfo pefas (thing, fixity, insts)
  =  pprTyThingInContextLoc pefas thing
806
807
  $$ show_fixity fixity
  $$ vcat (map GHC.pprInstance insts)
808
  where
809
    show_fixity fix 
810
811
	| fix == GHC.defaultFixity = empty
	| otherwise		   = ppr fix <+> ppr (GHC.getName thing)
812

813
814
815
runMain :: String -> GHCi ()
runMain args = do
  let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
816
  enqueueCommands  ['[': ss ++ "] `System.Environment.withArgs` main"]
817

sof's avatar
sof committed
818
819
addModule :: [FilePath] -> GHCi ()
addModule files = do
820
  io (revertCAFs)			-- always revert CAFs on load/add.
821
  files <- mapM expandPath files
822
  targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
823
824
  session <- getSession
  io (mapM_ (GHC.addTarget session) targets)
Simon Marlow's avatar
Simon Marlow committed
825
  prev_context <- io $ GHC.getContext session
826
  ok <- io (GHC.load session LoadAllTargets)
Simon Marlow's avatar
Simon Marlow committed
827
  afterLoad ok session False prev_context
828

829
changeDirectory :: String -> GHCi ()
830
changeDirectory dir = do
831
832
833
  session <- getSession
  graph <- io (GHC.getModuleGraph session)
  when (not (null graph)) $
834
	io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
Simon Marlow's avatar
Simon Marlow committed
835
  prev_context <- io $ GHC.getContext session
836
  io (GHC.setTargets session [])
837
  io (GHC.load session LoadAllTargets)
Simon Marlow's avatar
Simon Marlow committed
838
  setContextAfterLoad session prev_context []
839
  io (GHC.workingDirectoryChanged session)
840
841
  dir <- expandPath dir
  io (setCurrentDirectory dir)
842

Simon Marlow's avatar
Simon Marlow committed
843
editFile :: String -> GHCi ()
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
editFile str =
  do file <- if null str then chooseEditFile else return str
     st <- getGHCiState
     let cmd = editor st
     when (null cmd) 
       $ throwDyn (CmdLineError "editor not set, use :set editor")
     io $ system (cmd ++ ' ':file)
     return ()

-- The user didn't specify a file so we pick one for them.
-- Our strategy is to pick the first module that failed to load,
-- or otherwise the first target.
--
-- XXX: Can we figure out what happened if the depndecy analysis fails
--      (e.g., because the porgrammeer mistyped the name of a module)?
-- XXX: Can we figure out the location of an error to pass to the editor?
-- XXX: if we could figure out the list of errors that occured during the
-- last load/reaload, then we could start the editor focused on the first
-- of those.
chooseEditFile :: GHCi String
chooseEditFile =
  do session <- getSession
     let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x

     graph <- io (GHC.getModuleGraph session)
     failed_graph <- filterM hasFailed graph
     let order g  = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
         pick xs  = case xs of
                      x : _ -> GHC.ml_hs_file (GHC.ms_location x)
                      _     -> Nothing

     case pick (order failed_graph) of
       Just file -> return file
       Nothing   -> 
         do targets <- io (GHC.getTargets session)
            case msum (map fromTarget targets) of
              Just file -> return file
              Nothing   -> throwDyn (CmdLineError "No files to edit.")
          
  where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
        fromTarget _ = Nothing -- when would we get a module target?
Simon Marlow's avatar
Simon Marlow committed
885

Simon Marlow's avatar
Simon Marlow committed
886
887
defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
defineMacro overwrite s = do
888
  let (macro_name, definition) = break isSpace s
Simon Marlow's avatar
Simon Marlow committed
889
890
  macros <- io (readIORef macros_ref)
  let defined = map cmdName macros
891
  if (null macro_name) 
Simon Marlow's avatar
Simon Marlow committed
892
893
894
895
	then if null defined
                then io $ putStrLn "no macros defined"
                else io $ putStr ("the following macros are defined:\n" ++
                                  unlines defined)
896
	else do
Simon Marlow's avatar
Simon Marlow committed
897
  if (not overwrite && macro_name `elem` defined)
898
	then throwDyn (CmdLineError 
Simon Marlow's avatar
Simon Marlow committed
899
		("macro '" ++ macro_name ++ "' is already defined"))
900
901
	else do

Simon Marlow's avatar
Simon Marlow committed
902
903
  let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]

904
905
906
907
908
  -- give the expression a type signature, so we can be sure we're getting
  -- something of the right type.
  let new_expr = '(' : definition ++ ") :: String -> IO String"

  -- compile the expression
909
910
  cms <- getSession
  maybe_hv <- io (GHC.compileExpr cms new_expr)
911
  case maybe_hv of
912
     Nothing -> return ()
Simon Marlow's avatar
Simon Marlow committed
913
914
     Just hv -> io (writeIORef macros_ref --
		    (filtered ++ [(macro_name, runMacro hv, False, completeNone)]))
915

916
runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
917
918
runMacro fun s = do
  str <- io ((unsafeCoerce# fun :: String -> IO String) s)
919
920
  enqueueCommands (lines str)
  return False
921
922

undefineMacro :: String -> GHCi ()