[project @ 2005-03-18 17:16:00 by simonpj]
[ghc-hetmet.git] / ghc / compiler / ghci / InteractiveUI.hs
1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.195 2005/03/18 17:16:03 simonpj Exp $
4 --
5 -- GHC Interactive User Interface
6 --
7 -- (c) The GHC Team 2004
8 --
9 -----------------------------------------------------------------------------
10 module InteractiveUI ( 
11         interactiveUI,  -- :: CmState -> [FilePath] -> IO ()
12         ghciWelcomeMsg
13    ) where
14
15 #include "HsVersions.h"
16
17 import CompManager
18 import IfaceSyn         ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..),
19                           IfaceConDecl(..), IfaceType,
20                           pprIfaceDeclHead, pprParendIfaceType,
21                           pprIfaceForAllPart, pprIfaceType )
22 import FunDeps          ( pprFundeps )
23 import Util             ( removeSpaces, handle )
24 import Linker           ( showLinkerState, linkPackages )
25 import Util
26 import Name             ( Name, NamedThing(..) )
27 import OccName          ( OccName, parenSymOcc, occNameUserString )
28 import BasicTypes       ( StrictnessMark(..), defaultFixity, SuccessFlag(..) )
29 import Outputable
30 import DynFlags
31 import Panic            hiding ( showException )
32 import Config
33 import SrcLoc           ( SrcLoc, isGoodSrcLoc )
34 import StaticFlags      ( opt_IgnoreDotGhci )
35
36 #ifndef mingw32_HOST_OS
37 import Util             ( handle )
38 import System.Posix
39 #if __GLASGOW_HASKELL__ > 504
40         hiding (getEnv)
41 #endif
42 #endif
43
44 #ifdef USE_READLINE
45 import Control.Concurrent       ( yield )       -- Used in readline loop
46 import System.Console.Readline as Readline
47 #endif
48
49 --import SystemExts
50
51 import Control.Exception as Exception
52 import Data.Dynamic
53 -- import Control.Concurrent
54
55 import Numeric
56 import Data.List
57 import Data.Int         ( Int64 )
58 import System.Cmd
59 import System.CPUTime
60 import System.Environment
61 import System.Exit      ( exitWith, ExitCode(..) )
62 import System.Directory
63 import System.IO
64 import System.IO.Error as IO
65 import Data.Char
66 import Control.Monad as Monad
67 import Foreign.StablePtr        ( newStablePtr )
68
69 import GHC.Exts         ( unsafeCoerce# )
70 import GHC.IOBase       ( IOErrorType(InvalidArgument) )
71
72 import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )
73
74 import System.Posix.Internals ( setNonBlockingFD )
75
76 -----------------------------------------------------------------------------
77
78 ghciWelcomeMsg =
79  "   ___         ___ _\n"++
80  "  / _ \\ /\\  /\\/ __(_)\n"++
81  " / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
82  "/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n"++
83  "\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
84
85 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
86
87 builtin_commands :: [(String, String -> GHCi Bool)]
88 builtin_commands = [
89   ("add",       keepGoingPaths addModule),
90   ("browse",    keepGoing browseCmd),
91   ("cd",        keepGoing changeDirectory),
92   ("def",       keepGoing defineMacro),
93   ("help",      keepGoing help),
94   ("?",         keepGoing help),
95   ("info",      keepGoing info),
96   ("load",      keepGoingPaths loadModule),
97   ("module",    keepGoing setContext),
98   ("reload",    keepGoing reloadModule),
99   ("set",       keepGoing setCmd),
100   ("show",      keepGoing showCmd),
101   ("type",      keepGoing typeOfExpr),
102   ("kind",      keepGoing kindOfType),
103   ("unset",     keepGoing unsetOptions),
104   ("undef",     keepGoing undefineMacro),
105   ("quit",      quit)
106   ]
107
108 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
109 keepGoing a str = a str >> return False
110
111 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
112 keepGoingPaths a str = a (toArgs str) >> return False
113
114 shortHelpText = "use :? for help.\n"
115
116 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
117 helpText =
118  " Commands available from the prompt:\n" ++
119  "\n" ++
120  "   <stmt>                      evaluate/run <stmt>\n" ++
121  "   :add <filename> ...         add module(s) to the current target set\n" ++
122  "   :browse [*]<module>         display the names defined by <module>\n" ++
123  "   :cd <dir>                   change directory to <dir>\n" ++
124  "   :def <cmd> <expr>           define a command :<cmd>\n" ++
125  "   :help, :?                   display this list of commands\n" ++
126  "   :info [<name> ...]          display information about the given names\n" ++
127  "   :load <filename> ...        load module(s) and their dependents\n" ++
128  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
129  "   :reload                     reload the current module set\n" ++
130  "\n" ++
131  "   :set <option> ...           set options\n" ++
132  "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
133  "   :set prog <progname>        set the value returned by System.getProgName\n" ++
134  "\n" ++
135  "   :show modules               show the currently loaded modules\n" ++
136  "   :show bindings              show the current bindings made at the prompt\n" ++
137  "\n" ++
138  "   :type <expr>                show the type of <expr>\n" ++
139  "   :kind <type>                show the kind of <type>\n" ++
140  "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
141  "   :unset <option> ...         unset options\n" ++
142  "   :quit                       exit GHCi\n" ++
143  "   :!<command>                 run the shell command <command>\n" ++
144  "\n" ++
145  " Options for ':set' and ':unset':\n" ++
146  "\n" ++
147  "    +r            revert top-level expressions after each evaluation\n" ++
148  "    +s            print timing/memory stats after each evaluation\n" ++
149  "    +t            print type after evaluation\n" ++
150  "    -<flags>      most GHC command line flags can also be set here\n" ++
151  "                         (eg. -v2, -fglasgow-exts, etc.)\n"
152
153
154 interactiveUI :: DynFlags -> [FilePath] -> Maybe String -> IO ()
155 interactiveUI dflags srcs maybe_expr = do
156
157    cmstate <- cmInit dflags;
158
159    -- HACK! If we happen to get into an infinite loop (eg the user
160    -- types 'let x=x in x' at the prompt), then the thread will block
161    -- on a blackhole, and become unreachable during GC.  The GC will
162    -- detect that it is unreachable and send it the NonTermination
163    -- exception.  However, since the thread is unreachable, everything
164    -- it refers to might be finalized, including the standard Handles.
165    -- This sounds like a bug, but we don't have a good solution right
166    -- now.
167    newStablePtr stdin
168    newStablePtr stdout
169    newStablePtr stderr
170
171    hFlush stdout
172    hSetBuffering stdout NoBuffering
173
174         -- Initialise buffering for the *interpreted* I/O system
175    initInterpBuffering cmstate
176
177         -- We don't want the cmd line to buffer any input that might be
178         -- intended for the program, so unbuffer stdin.
179    hSetBuffering stdin NoBuffering
180
181         -- initial context is just the Prelude
182    cmstate <- cmSetContext cmstate [] ["Prelude"]
183
184 #ifdef USE_READLINE
185    Readline.initialize
186 #endif
187
188    startGHCi (runGHCi srcs dflags maybe_expr)
189         GHCiState{ progname = "<interactive>",
190                    args = [],
191                    targets = srcs,
192                    cmstate = cmstate,
193                    options = [] }
194
195 #ifdef USE_READLINE
196    Readline.resetTerminal Nothing
197 #endif
198
199    return ()
200
201 runGHCi :: [FilePath] -> DynFlags -> Maybe String -> GHCi ()
202 runGHCi paths dflags maybe_expr = do
203   let read_dot_files = not opt_IgnoreDotGhci
204
205   when (read_dot_files) $ do
206     -- Read in ./.ghci.
207     let file = "./.ghci"
208     exists <- io (doesFileExist file)
209     when exists $ do
210        dir_ok  <- io (checkPerms ".")
211        file_ok <- io (checkPerms file)
212        when (dir_ok && file_ok) $ do
213           either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
214           case either_hdl of
215              Left e    -> return ()
216              Right hdl -> fileLoop hdl False
217     
218   when (read_dot_files) $ do
219     -- Read in $HOME/.ghci
220     either_dir <- io (IO.try (getEnv "HOME"))
221     case either_dir of
222        Left e -> return ()
223        Right dir -> do
224           cwd <- io (getCurrentDirectory)
225           when (dir /= cwd) $ do
226              let file = dir ++ "/.ghci"
227              ok <- io (checkPerms file)
228              when ok $ do
229                either_hdl <- io (IO.try (openFile file ReadMode))
230                case either_hdl of
231                   Left e    -> return ()
232                   Right hdl -> fileLoop hdl False
233
234   -- Perform a :load for files given on the GHCi command line
235   when (not (null paths)) $
236      ghciHandle showException $
237         loadModule paths
238
239   -- if verbosity is greater than 0, or we are connected to a
240   -- terminal, display the prompt in the interactive loop.
241   is_tty <- io (hIsTerminalDevice stdin)
242   let show_prompt = verbosity dflags > 0 || is_tty
243
244   case maybe_expr of
245         Nothing -> 
246             -- enter the interactive loop
247             interactiveLoop is_tty show_prompt
248         Just expr -> do
249             -- just evaluate the expression we were given
250             runCommandEval expr
251             return ()
252
253   -- and finally, exit
254   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
255
256
257 interactiveLoop is_tty show_prompt = do
258   -- Ignore ^C exceptions caught here
259   ghciHandleDyn (\e -> case e of 
260                         Interrupted -> ghciUnblock (interactiveLoop is_tty show_prompt)
261                         _other      -> return ()) $ do
262
263   -- read commands from stdin
264 #ifdef USE_READLINE
265   if (is_tty) 
266         then readlineLoop
267         else fileLoop stdin show_prompt
268 #else
269   fileLoop stdin show_prompt
270 #endif
271
272
273 -- NOTE: We only read .ghci files if they are owned by the current user,
274 -- and aren't world writable.  Otherwise, we could be accidentally 
275 -- running code planted by a malicious third party.
276
277 -- Furthermore, We only read ./.ghci if . is owned by the current user
278 -- and isn't writable by anyone else.  I think this is sufficient: we
279 -- don't need to check .. and ../.. etc. because "."  always refers to
280 -- the same directory while a process is running.
281
282 checkPerms :: String -> IO Bool
283 checkPerms name =
284 #ifdef mingw32_HOST_OS
285   return True
286 #else
287   Util.handle (\_ -> return False) $ do
288      st <- getFileStatus name
289      me <- getRealUserID
290      if fileOwner st /= me then do
291         putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
292         return False
293       else do
294         let mode =  fileMode st
295         if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
296            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode)) 
297            then do
298                putStrLn $ "*** WARNING: " ++ name ++ 
299                           " is writable by someone else, IGNORING!"
300                return False
301           else return True
302 #endif
303
304 fileLoop :: Handle -> Bool -> GHCi ()
305 fileLoop hdl prompt = do
306    cmstate <- getCmState
307    (mod,imports) <- io (cmGetContext cmstate)
308    when prompt (io (putStr (mkPrompt mod imports)))
309    l <- io (IO.try (hGetLine hdl))
310    case l of
311         Left e | isEOFError e              -> return ()
312                | InvalidArgument <- etype  -> return ()
313                | otherwise                 -> io (ioError e)
314                 where etype = ioeGetErrorType e
315                 -- treat InvalidArgument in the same way as EOF:
316                 -- this can happen if the user closed stdin, or
317                 -- perhaps did getContents which closes stdin at
318                 -- EOF.
319         Right l -> 
320           case removeSpaces l of
321             "" -> fileLoop hdl prompt
322             l  -> do quit <- runCommand l
323                      if quit then return () else fileLoop hdl prompt
324
325 stringLoop :: [String] -> GHCi ()
326 stringLoop [] = return ()
327 stringLoop (s:ss) = do
328    case removeSpaces s of
329         "" -> stringLoop ss
330         l  -> do quit <- runCommand l
331                  if quit then return () else stringLoop ss
332
333 mkPrompt toplevs exports
334    = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
335
336 #ifdef USE_READLINE
337 readlineLoop :: GHCi ()
338 readlineLoop = do
339    cmstate <- getCmState
340    (mod,imports) <- io (cmGetContext cmstate)
341    io yield
342    l <- io (readline (mkPrompt mod imports)
343                 `finally` setNonBlockingFD 0)
344                 -- readline sometimes puts stdin into blocking mode,
345                 -- so we need to put it back for the IO library
346    case l of
347         Nothing -> return ()
348         Just l  ->
349           case removeSpaces l of
350             "" -> readlineLoop
351             l  -> do
352                   io (addHistory l)
353                   quit <- runCommand l
354                   if quit then return () else readlineLoop
355 #endif
356
357 runCommand :: String -> GHCi Bool
358 runCommand c = ghciHandle handler (doCommand c)
359
360 -- This version is for the GHC command-line option -e.  The only difference
361 -- from runCommand is that it catches the ExitException exception and
362 -- exits, rather than printing out the exception.
363 runCommandEval c = ghciHandle handleEval (doCommand c)
364   where 
365     handleEval (ExitException code) = io (exitWith code)
366     handleEval e                    = do showException e
367                                          io (exitWith (ExitFailure 1))
368
369 -- This is the exception handler for exceptions generated by the
370 -- user's code; it normally just prints out the exception.  The
371 -- handler must be recursive, in case showing the exception causes
372 -- more exceptions to be raised.
373 --
374 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
375 -- raising another exception.  We therefore don't put the recursive
376 -- handler arond the flushing operation, so if stderr is closed
377 -- GHCi will just die gracefully rather than going into an infinite loop.
378 handler :: Exception -> GHCi Bool
379 handler exception = do
380   flushInterpBuffers
381   io installSignalHandlers
382   ghciHandle handler (showException exception >> return False)
383
384 showException (DynException dyn) =
385   case fromDynamic dyn of
386     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
387     Just Interrupted      -> io (putStrLn "Interrupted.")
388     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
389     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
390     Just other_ghc_ex     -> io (print other_ghc_ex)
391
392 showException other_exception
393   = io (putStrLn ("*** Exception: " ++ show other_exception))
394
395 doCommand (':' : command) = specialCommand command
396 doCommand stmt
397    = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
398         return False
399
400 runStmt :: String -> GHCi [Name]
401 runStmt stmt
402  | null (filter (not.isSpace) stmt) = return []
403  | otherwise
404  = do st <- getGHCiState
405       cmstate <- getCmState
406       (new_cmstate, result) <- 
407         io $ withProgName (progname st) $ withArgs (args st) $
408              cmRunStmt cmstate stmt
409       setGHCiState st{cmstate = new_cmstate}
410       case result of
411         CmRunFailed      -> return []
412         CmRunException e -> throw e  -- this is caught by runCommand(Eval)
413         CmRunOk names    -> return names
414
415 -- possibly print the type and revert CAFs after evaluating an expression
416 finishEvalExpr names
417  = do b <- isOptionSet ShowType
418       cmstate <- getCmState
419       when b (mapM_ (showTypeOfName cmstate) names)
420
421       flushInterpBuffers
422       io installSignalHandlers
423       b <- isOptionSet RevertCAFs
424       io (when b revertCAFs)
425       return True
426
427 showTypeOfName :: CmState -> Name -> GHCi ()
428 showTypeOfName cmstate n
429    = do maybe_str <- io (cmTypeOfName cmstate n)
430         case maybe_str of
431           Nothing  -> return ()
432           Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
433
434 specialCommand :: String -> GHCi Bool
435 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
436 specialCommand str = do
437   let (cmd,rest) = break isSpace str
438   cmds <- io (readIORef commands)
439   case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
440      []      -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n" 
441                                     ++ shortHelpText) >> return False)
442      [(_,f)] -> f (dropWhile isSpace rest)
443      cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++ 
444                                       " matches multiple commands (" ++ 
445                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
446                                          ++ ")") >> return False)
447
448 noArgs c = throwDyn (CmdLineError ("command '" ++ c ++ "' takes no arguments"))
449
450
451 -----------------------------------------------------------------------------
452 -- To flush buffers for the *interpreted* computation we need
453 -- to refer to *its* stdout/stderr handles
454
455 GLOBAL_VAR(flush_interp,       error "no flush_interp", IO ())
456 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
457
458 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
459              " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
460 flush_cmd  = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
461
462 initInterpBuffering :: CmState -> IO ()
463 initInterpBuffering cmstate
464  = do maybe_hval <- cmCompileExpr cmstate no_buf_cmd
465         
466       case maybe_hval of
467         Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
468         other     -> panic "interactiveUI:setBuffering"
469         
470       maybe_hval <- cmCompileExpr cmstate flush_cmd
471       case maybe_hval of
472         Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
473         _         -> panic "interactiveUI:flush"
474
475       turnOffBuffering  -- Turn it off right now
476
477       return ()
478
479
480 flushInterpBuffers :: GHCi ()
481 flushInterpBuffers
482  = io $ do Monad.join (readIORef flush_interp)
483            return ()
484
485 turnOffBuffering :: IO ()
486 turnOffBuffering
487  = do Monad.join (readIORef turn_off_buffering)
488       return ()
489
490 -----------------------------------------------------------------------------
491 -- Commands
492
493 help :: String -> GHCi ()
494 help _ = io (putStr helpText)
495
496 info :: String -> GHCi ()
497 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
498 info s  = do { let names = words s
499              ; init_cms <- getCmState
500              ; dflags <- getDynFlags
501              ; let exts = dopt Opt_GlasgowExts dflags
502              ; mapM_ (infoThing exts init_cms) names }
503   where
504     infoThing exts cms name
505         = do { stuff <- io (cmGetInfo cms name)
506              ; io (putStrLn (showSDocForUser (cmGetPrintUnqual cms) $
507                    vcat (intersperse (text "") (map (showThing exts) stuff)))) }
508
509 showThing :: Bool -> GetInfoResult -> SDoc
510 showThing exts (wanted_str, thing, fixity, src_loc, insts) 
511     = vcat [ showWithLoc src_loc (showDecl exts want_name thing),
512              show_fixity fixity,
513              vcat (map show_inst insts)]
514   where
515     want_name occ = wanted_str == occNameUserString occ
516
517     show_fixity fix 
518         | fix == defaultFixity = empty
519         | otherwise            = ppr fix <+> text wanted_str
520
521     show_inst (inst_ty, loc)
522         = showWithLoc loc (ptext SLIT("instance") <+> ppr inst_ty)
523
524 showWithLoc :: SrcLoc -> SDoc -> SDoc
525 showWithLoc loc doc 
526     = hang doc 2 (char '\t' <> show_loc loc)
527                 -- The tab tries to make them line up a bit
528   where
529     show_loc loc        -- The ppr function for SrcLocs is a bit wonky
530         | isGoodSrcLoc loc = comment <+> ptext SLIT("Defined at") <+> ppr loc
531         | otherwise        = comment <+> ppr loc
532     comment = ptext SLIT("--")
533
534
535 -- Now there is rather a lot of goop just to print declarations in a
536 -- civilised way with "..." for the parts we are less interested in.
537
538 showDecl :: Bool -> (OccName -> Bool) -> IfaceDecl -> SDoc
539 showDecl exts want_name (IfaceForeign {ifName = tc})
540   = ppr tc <+> ptext SLIT("is a foreign type")
541
542 showDecl exts want_name (IfaceId {ifName = var, ifType = ty})
543   = ppr var <+> dcolon <+> showType exts ty 
544
545 showDecl exts want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty})
546   = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
547        2 (equals <+> ppr mono_ty)
548
549 showDecl exts want_name (IfaceData {ifName = tycon, 
550                      ifTyVars = tyvars, ifCons = condecls})
551   = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
552        2 (add_bars (ppr_trim show_con cs))
553   where
554     show_con (IfVanillaCon { ifConOcc = con_name, ifConInfix = is_infix, ifConArgTys = tys, 
555                              ifConStricts = strs, ifConFields = flds})
556         | want_name tycon || want_name con_name || any want_name flds
557         = Just (show_guts con_name is_infix tys_w_strs flds)
558         | otherwise = Nothing
559         where
560           tys_w_strs = tys `zip` (strs ++ repeat NotMarkedStrict)
561     show_con (IfGadtCon { ifConOcc = con_name, ifConTyVars = tvs, ifConCtxt = theta, 
562                           ifConArgTys = arg_tys, ifConResTys = res_tys, ifConStricts = strs })
563         | want_name tycon || want_name con_name
564         = Just (ppr_bndr con_name <+> colon <+> pprIfaceForAllPart tvs theta pp_tau)
565         | otherwise = Nothing
566         where
567           tys_w_strs = arg_tys `zip` (strs ++ repeat NotMarkedStrict)
568           pp_tau = foldr add pp_res_ty tys_w_strs
569           pp_res_ty = ppr_bndr tycon <+> hsep (map pprParendIfaceType res_tys)
570           add bty pp_ty = ppr_bangty bty <+> arrow <+> pp_ty
571
572     show_guts con True [ty1, ty2] flds = sep [ppr_bangty ty1, ppr con, ppr_bangty ty2]
573     show_guts con _ tys []   = ppr_bndr con <+> sep (map ppr_bangty tys)
574     show_guts con _ tys flds 
575         = ppr_bndr con <+> braces (sep (punctuate comma (ppr_trim show_fld (tys `zip` flds))))
576         where
577           show_fld (bty, fld) | want_name tycon || want_name con || want_name fld
578                               = Just (ppr_bndr fld <+> dcolon <+> ppr_bangty bty)
579                               | otherwise = Nothing
580
581     (pp_nd, context, cs) = case condecls of
582                     IfAbstractTyCon           -> (ptext SLIT("data"), [],   [])
583                     IfDataTyCon (Just cxt) cs -> (ptext SLIT("data"), cxt, cs)
584                     IfDataTyCon Nothing cs    -> (ptext SLIT("data"), [],  cs)
585                     IfNewTyCon c              -> (ptext SLIT("newtype"), [], [c])
586
587     add_bars []      = empty
588     add_bars [c]     = equals <+> c
589     add_bars (c:cs)  = equals <+> sep (c : map (char '|' <+>) cs)
590
591     ppr_bangty (ty, str) = ppr_str str <> pprParendIfaceType ty
592     ppr_str MarkedStrict    = char '!'
593     ppr_str MarkedUnboxed   = ptext SLIT("!!")
594     ppr_str NotMarkedStrict = empty
595
596 showDecl exts want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, 
597                       ifFDs = fds, ifSigs = sigs})
598   = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars
599                 <+> pprFundeps fds <+> opt_where)
600        2 (vcat (ppr_trim show_op sigs))
601   where
602     opt_where | null sigs = empty
603               | otherwise = ptext SLIT("where")
604     show_op (IfaceClassOp op dm ty) 
605         | want_name clas || want_name op 
606         = Just (ppr_bndr op <+> dcolon <+> showType exts ty)
607         | otherwise
608         = Nothing
609
610 showType :: Bool -> IfaceType -> SDoc
611 showType True  ty = pprIfaceType ty -- -fglasgow-exts: print with the foralls
612 showType False ty = ppr ty          -- otherwise, print without the foralls
613
614 ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc]
615 ppr_trim show xs
616   = snd (foldr go (False, []) xs)
617   where
618     go x (eliding, so_far)
619         | Just doc <- show x = (False, doc : so_far)
620         | otherwise = if eliding then (True, so_far)
621                                  else (True, ptext SLIT("...") : so_far)
622
623 ppr_bndr :: OccName -> SDoc
624 -- Wrap operators in ()
625 ppr_bndr occ = parenSymOcc occ (ppr occ)
626
627
628 -----------------------------------------------------------------------------
629 -- Commands
630
631 addModule :: [FilePath] -> GHCi ()
632 addModule files = do
633   state <- getGHCiState
634   io (revertCAFs)                       -- always revert CAFs on load/add.
635   files <- mapM expandPath files
636   let new_targets = files ++ targets state 
637   graph <- io (cmDepAnal (cmstate state) new_targets)
638   (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) graph)
639   setGHCiState state{ cmstate = cmstate1, targets = new_targets }
640   setContextAfterLoad mods
641   dflags <- getDynFlags
642   modulesLoadedMsg ok mods dflags
643
644 changeDirectory :: String -> GHCi ()
645 changeDirectory dir = do
646   state    <- getGHCiState
647   when (targets state /= []) $
648         io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
649   cmstate1 <- io (cmUnload (cmstate state))
650   setGHCiState state{ cmstate = cmstate1, targets = [] }
651   setContextAfterLoad []
652   dir <- expandPath dir
653   io (setCurrentDirectory dir)
654
655 defineMacro :: String -> GHCi ()
656 defineMacro s = do
657   let (macro_name, definition) = break isSpace s
658   cmds <- io (readIORef commands)
659   if (null macro_name) 
660         then throwDyn (CmdLineError "invalid macro name") 
661         else do
662   if (macro_name `elem` map fst cmds) 
663         then throwDyn (CmdLineError 
664                 ("command '" ++ macro_name ++ "' is already defined"))
665         else do
666
667   -- give the expression a type signature, so we can be sure we're getting
668   -- something of the right type.
669   let new_expr = '(' : definition ++ ") :: String -> IO String"
670
671   -- compile the expression
672   cms <- getCmState
673   maybe_hv <- io (cmCompileExpr cms new_expr)
674   case maybe_hv of
675      Nothing -> return ()
676      Just hv -> io (writeIORef commands --
677                     ((macro_name, keepGoing (runMacro hv)) : cmds))
678
679 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
680 runMacro fun s = do
681   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
682   stringLoop (lines str)
683
684 undefineMacro :: String -> GHCi ()
685 undefineMacro macro_name = do
686   cmds <- io (readIORef commands)
687   if (macro_name `elem` map fst builtin_commands) 
688         then throwDyn (CmdLineError
689                 ("command '" ++ macro_name ++ "' cannot be undefined"))
690         else do
691   if (macro_name `notElem` map fst cmds) 
692         then throwDyn (CmdLineError 
693                 ("command '" ++ macro_name ++ "' not defined"))
694         else do
695   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
696
697
698 loadModule :: [FilePath] -> GHCi ()
699 loadModule fs = timeIt (loadModule' fs)
700
701 loadModule' :: [FilePath] -> GHCi ()
702 loadModule' files = do
703   state <- getGHCiState
704
705   -- expand tildes
706   files <- mapM expandPath files
707
708   -- do the dependency anal first, so that if it fails we don't throw
709   -- away the current set of modules.
710   graph <- io (cmDepAnal (cmstate state) files)
711
712   -- Dependency anal ok, now unload everything
713   cmstate1 <- io (cmUnload (cmstate state))
714   setGHCiState state{ cmstate = cmstate1, targets = [] }
715
716   io (revertCAFs)  -- always revert CAFs on load.
717   (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 graph)
718   setGHCiState state{ cmstate = cmstate2, targets = files }
719
720   setContextAfterLoad mods
721   dflags <- getDynFlags
722   modulesLoadedMsg ok mods dflags
723
724
725 reloadModule :: String -> GHCi ()
726 reloadModule "" = do
727   state <- getGHCiState
728   case targets state of
729    [] -> io (putStr "no current target\n")
730    paths -> do
731         -- do the dependency anal first, so that if it fails we don't throw
732         -- away the current set of modules.
733         graph <- io (cmDepAnal (cmstate state) paths)
734
735         io (revertCAFs)         -- always revert CAFs on reload.
736         (cmstate1, ok, mods) 
737                 <- io (cmLoadModules (cmstate state) graph)
738         setGHCiState state{ cmstate=cmstate1 }
739         setContextAfterLoad mods
740         dflags <- getDynFlags
741         modulesLoadedMsg ok mods dflags
742
743 reloadModule _ = noArgs ":reload"
744
745 setContextAfterLoad [] = setContext prel
746 setContextAfterLoad (m:_) = do
747   cmstate <- getCmState
748   b <- io (cmModuleIsInterpreted cmstate m)
749   if b then setContext ('*':m) else setContext m
750
751 modulesLoadedMsg ok mods dflags =
752   when (verbosity dflags > 0) $ do
753    let mod_commas 
754         | null mods = text "none."
755         | otherwise = hsep (
756             punctuate comma (map text mods)) <> text "."
757    case ok of
758     Failed ->
759        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
760     Succeeded  ->
761        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
762
763
764 typeOfExpr :: String -> GHCi ()
765 typeOfExpr str 
766   = do cms <- getCmState
767        maybe_tystr <- io (cmTypeOfExpr cms str)
768        case maybe_tystr of
769           Nothing    -> return ()
770           Just tystr -> io (putStrLn tystr)
771
772 kindOfType :: String -> GHCi ()
773 kindOfType str 
774   = do cms <- getCmState
775        maybe_tystr <- io (cmKindOfType cms str)
776        case maybe_tystr of
777           Nothing    -> return ()
778           Just tystr -> io (putStrLn tystr)
779
780 quit :: String -> GHCi Bool
781 quit _ = return True
782
783 shellEscape :: String -> GHCi Bool
784 shellEscape str = io (system str >> return False)
785
786 -----------------------------------------------------------------------------
787 -- Browsing a module's contents
788
789 browseCmd :: String -> GHCi ()
790 browseCmd m = 
791   case words m of
792     ['*':m] | looksLikeModuleName m -> browseModule m False
793     [m]     | looksLikeModuleName m -> browseModule m True
794     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
795
796 browseModule m exports_only = do
797   cms <- getCmState
798
799   is_interpreted <- io (cmModuleIsInterpreted cms m)
800   when (not is_interpreted && not exports_only) $
801         throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
802
803   -- Temporarily set the context to the module we're interested in,
804   -- just so we can get an appropriate PrintUnqualified
805   (as,bs) <- io (cmGetContext cms)
806   cms1 <- io (if exports_only then cmSetContext cms [] [prel,m]
807                               else cmSetContext cms [m] [])
808   cms2 <- io (cmSetContext cms1 as bs)
809
810   things <- io (cmBrowseModule cms2 m exports_only)
811
812   let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
813
814   dflags <- getDynFlags
815   let exts = dopt Opt_GlasgowExts dflags
816   io (putStrLn (showSDocForUser unqual (
817          vcat (map (showDecl exts (const True)) things)
818       )))
819
820 -----------------------------------------------------------------------------
821 -- Setting the module context
822
823 setContext str
824   | all sensible mods = fn mods
825   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
826   where
827     (fn, mods) = case str of 
828                         '+':stuff -> (addToContext,      words stuff)
829                         '-':stuff -> (removeFromContext, words stuff)
830                         stuff     -> (newContext,        words stuff) 
831
832     sensible ('*':m) = looksLikeModuleName m
833     sensible m       = looksLikeModuleName m
834
835 newContext mods = do
836   cms <- getCmState
837   (as,bs) <- separate cms mods [] []
838   let bs' = if null as && prel `notElem` bs then prel:bs else bs
839   cms' <- io (cmSetContext cms as bs')
840   setCmState cms'
841
842 separate cmstate []           as bs = return (as,bs)
843 separate cmstate (('*':m):ms) as bs = do
844    b <- io (cmModuleIsInterpreted cmstate m)
845    if b then separate cmstate ms (m:as) bs
846         else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
847 separate cmstate (m:ms)       as bs = separate cmstate ms as (m:bs)
848
849 prel = "Prelude"
850
851
852 addToContext mods = do
853   cms <- getCmState
854   (as,bs) <- io (cmGetContext cms)
855
856   (as',bs') <- separate cms mods [] []
857
858   let as_to_add = as' \\ (as ++ bs)
859       bs_to_add = bs' \\ (as ++ bs)
860
861   cms' <- io (cmSetContext cms
862                         (as ++ as_to_add) (bs ++ bs_to_add))
863   setCmState cms'
864
865
866 removeFromContext mods = do
867   cms <- getCmState
868   (as,bs) <- io (cmGetContext cms)
869
870   (as_to_remove,bs_to_remove) <- separate cms mods [] []
871
872   let as' = as \\ (as_to_remove ++ bs_to_remove)
873       bs' = bs \\ (as_to_remove ++ bs_to_remove)
874
875   cms' <- io (cmSetContext cms as' bs')
876   setCmState cms'
877
878 ----------------------------------------------------------------------------
879 -- Code for `:set'
880
881 -- set options in the interpreter.  Syntax is exactly the same as the
882 -- ghc command line, except that certain options aren't available (-C,
883 -- -E etc.)
884 --
885 -- This is pretty fragile: most options won't work as expected.  ToDo:
886 -- figure out which ones & disallow them.
887
888 setCmd :: String -> GHCi ()
889 setCmd ""
890   = do st <- getGHCiState
891        let opts = options st
892        io $ putStrLn (showSDoc (
893               text "options currently set: " <> 
894               if null opts
895                    then text "none."
896                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
897            ))
898 setCmd str
899   = case words str of
900         ("args":args) -> setArgs args
901         ("prog":prog) -> setProg prog
902         wds -> setOptions wds
903
904 setArgs args = do
905   st <- getGHCiState
906   setGHCiState st{ args = args }
907
908 setProg [prog] = do
909   st <- getGHCiState
910   setGHCiState st{ progname = prog }
911 setProg _ = do
912   io (hPutStrLn stderr "syntax: :set prog <progname>")
913
914 setOptions wds =
915    do -- first, deal with the GHCi opts (+s, +t, etc.)
916       let (plus_opts, minus_opts)  = partition isPlus wds
917       mapM_ setOpt plus_opts
918
919       -- then, dynamic flags
920       dflags <- getDynFlags
921       (dflags',leftovers) <- io $ parseDynamicFlags dflags minus_opts
922       setDynFlags dflags'
923
924         -- update things if the users wants more packages
925 {- TODO:
926         let new_packages = pkgs_after \\ pkgs_before
927         when (not (null new_packages)) $
928            newPackages new_packages
929 -}
930
931       if (not (null leftovers))
932                 then throwDyn (CmdLineError ("unrecognised flags: " ++ 
933                                                 unwords leftovers))
934                 else return ()
935
936
937 unsetOptions :: String -> GHCi ()
938 unsetOptions str
939   = do -- first, deal with the GHCi opts (+s, +t, etc.)
940        let opts = words str
941            (minus_opts, rest1) = partition isMinus opts
942            (plus_opts, rest2)  = partition isPlus rest1
943
944        if (not (null rest2)) 
945           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
946           else do
947
948        mapM_ unsetOpt plus_opts
949  
950        -- can't do GHC flags for now
951        if (not (null minus_opts))
952           then throwDyn (CmdLineError "can't unset GHC command-line flags")
953           else return ()
954
955 isMinus ('-':s) = True
956 isMinus _ = False
957
958 isPlus ('+':s) = True
959 isPlus _ = False
960
961 setOpt ('+':str)
962   = case strToGHCiOpt str of
963         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
964         Just o  -> setOption o
965
966 unsetOpt ('+':str)
967   = case strToGHCiOpt str of
968         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
969         Just o  -> unsetOption o
970
971 strToGHCiOpt :: String -> (Maybe GHCiOption)
972 strToGHCiOpt "s" = Just ShowTiming
973 strToGHCiOpt "t" = Just ShowType
974 strToGHCiOpt "r" = Just RevertCAFs
975 strToGHCiOpt _   = Nothing
976
977 optToStr :: GHCiOption -> String
978 optToStr ShowTiming = "s"
979 optToStr ShowType   = "t"
980 optToStr RevertCAFs = "r"
981
982 newPackages new_pkgs = do       -- The new packages are already in v_Packages
983   state    <- getGHCiState
984   cmstate1 <- io (cmUnload (cmstate state))
985   setGHCiState state{ cmstate = cmstate1, targets = [] }
986   dflags   <- getDynFlags
987   io (linkPackages dflags new_pkgs)
988   setContextAfterLoad []
989
990 -- ---------------------------------------------------------------------------
991 -- code for `:show'
992
993 showCmd str =
994   case words str of
995         ["modules" ] -> showModules
996         ["bindings"] -> showBindings
997         ["linker"]   -> io showLinkerState
998         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
999
1000 showModules
1001   = do  { cms <- getCmState
1002         ; let show_one ms = io (putStrLn (cmShowModule cms ms))
1003         ; mapM_ show_one (cmGetModuleGraph cms) }
1004
1005 showBindings = do
1006   cms <- getCmState
1007   let
1008         unqual = cmGetPrintUnqual cms
1009 --      showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
1010         showBinding b = putStrLn (showSDocForUser unqual (ppr (getName b)))
1011
1012   io (mapM_ showBinding (cmGetBindings cms))
1013   return ()
1014
1015
1016 -----------------------------------------------------------------------------
1017 -- GHCi monad
1018
1019 data GHCiState = GHCiState
1020      { 
1021         progname       :: String,
1022         args           :: [String],
1023         targets        :: [FilePath],
1024         cmstate        :: CmState,
1025         options        :: [GHCiOption]
1026      }
1027
1028 data GHCiOption 
1029         = ShowTiming            -- show time/allocs after evaluation
1030         | ShowType              -- show the type of expressions
1031         | RevertCAFs            -- revert CAFs after every evaluation
1032         deriving Eq
1033
1034 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1035
1036 startGHCi :: GHCi a -> GHCiState -> IO a
1037 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1038
1039 instance Monad GHCi where
1040   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1041   return a  = GHCi $ \s -> return a
1042
1043 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1044 ghciHandleDyn h (GHCi m) = GHCi $ \s -> 
1045    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1046
1047 getGHCiState   = GHCi $ \r -> readIORef r
1048 setGHCiState s = GHCi $ \r -> writeIORef r s
1049
1050 -- for convenience...
1051 getCmState = getGHCiState >>= return . cmstate
1052 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
1053
1054 getDynFlags = getCmState >>= return . cmGetDFlags
1055
1056 setDynFlags dflags = do s <- getCmState; setCmState (cmSetDFlags s dflags)
1057
1058 isOptionSet :: GHCiOption -> GHCi Bool
1059 isOptionSet opt
1060  = do st <- getGHCiState
1061       return (opt `elem` options st)
1062
1063 setOption :: GHCiOption -> GHCi ()
1064 setOption opt
1065  = do st <- getGHCiState
1066       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1067
1068 unsetOption :: GHCiOption -> GHCi ()
1069 unsetOption opt
1070  = do st <- getGHCiState
1071       setGHCiState (st{ options = filter (/= opt) (options st) })
1072
1073 io :: IO a -> GHCi a
1074 io m = GHCi { unGHCi = \s -> m >>= return }
1075
1076 -----------------------------------------------------------------------------
1077 -- recursive exception handlers
1078
1079 -- Don't forget to unblock async exceptions in the handler, or if we're
1080 -- in an exception loop (eg. let a = error a in a) the ^C exception
1081 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1082
1083 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1084 ghciHandle h (GHCi m) = GHCi $ \s -> 
1085    Exception.catch (m s) 
1086         (\e -> unGHCi (ghciUnblock (h e)) s)
1087
1088 ghciUnblock :: GHCi a -> GHCi a
1089 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1090
1091 -----------------------------------------------------------------------------
1092 -- timing & statistics
1093
1094 timeIt :: GHCi a -> GHCi a
1095 timeIt action
1096   = do b <- isOptionSet ShowTiming
1097        if not b 
1098           then action 
1099           else do allocs1 <- io $ getAllocations
1100                   time1   <- io $ getCPUTime
1101                   a <- action
1102                   allocs2 <- io $ getAllocations
1103                   time2   <- io $ getCPUTime
1104                   io $ printTimes (fromIntegral (allocs2 - allocs1)) 
1105                                   (time2 - time1)
1106                   return a
1107
1108 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1109         -- defined in ghc/rts/Stats.c
1110
1111 printTimes :: Integer -> Integer -> IO ()
1112 printTimes allocs psecs
1113    = do let secs = (fromIntegral psecs / (10^12)) :: Float
1114             secs_str = showFFloat (Just 2) secs
1115         putStrLn (showSDoc (
1116                  parens (text (secs_str "") <+> text "secs" <> comma <+> 
1117                          text (show allocs) <+> text "bytes")))
1118
1119 -----------------------------------------------------------------------------
1120 -- reverting CAFs
1121         
1122 revertCAFs :: IO ()
1123 revertCAFs = do
1124   rts_revertCAFs
1125   turnOffBuffering
1126         -- Have to turn off buffering again, because we just 
1127         -- reverted stdout, stderr & stdin to their defaults.
1128
1129 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()  
1130         -- Make it "safe", just in case
1131
1132 -- -----------------------------------------------------------------------------
1133 -- Utils
1134
1135 expandPath :: String -> GHCi String
1136 expandPath path = 
1137   case dropWhile isSpace path of
1138    ('~':d) -> do
1139         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1140         return (tilde ++ '/':d)
1141    other -> 
1142         return other