ghc/compiler/ghci/InteractiveUI.hs

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