ghc/compiler/ghci/InteractiveUI.hs

   1 {-# OPTIONS -#include "Linker.h" #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: InteractiveUI.hs,v 1.191 2005/02/25 13:07:10 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 <+> ptext SLIT("where"))
 602        2 (vcat (ppr_trim show_op sigs))
 603   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       -- now, the GHC flags
 920       leftovers <- io $ processStaticFlags minus_opts
 921
 922       -- then, dynamic flags
 923       dflags <- getDynFlags
 924       (dflags',leftovers) <- io $ processDynamicFlags leftovers dflags
 925       setDynFlags dflags'
 926
 927         -- update things if the users wants more packages
 928 {- TODO:
 929         let new_packages = pkgs_after \\ pkgs_before
 930         when (not (null new_packages)) $
 931            newPackages new_packages
 932 -}
 933
 934       if (not (null leftovers))
 935                 then throwDyn (CmdLineError ("unrecognised flags: " ++
 936                                                 unwords leftovers))
 937                 else return ()
 938
 939
 940 unsetOptions :: String -> GHCi ()
 941 unsetOptions str
 942   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 943        let opts = words str
 944            (minus_opts, rest1) = partition isMinus opts
 945            (plus_opts, rest2)  = partition isPlus rest1
 946
 947        if (not (null rest2))
 948           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
 949           else do
 950
 951        mapM_ unsetOpt plus_opts
 952
 953        -- can't do GHC flags for now
 954        if (not (null minus_opts))
 955           then throwDyn (CmdLineError "can't unset GHC command-line flags")
 956           else return ()
 957
 958 isMinus ('-':s) = True
 959 isMinus _ = False
 960
 961 isPlus ('+':s) = True
 962 isPlus _ = False
 963
 964 setOpt ('+':str)
 965   = case strToGHCiOpt str of
 966         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
 967         Just o  -> setOption o
 968
 969 unsetOpt ('+':str)
 970   = case strToGHCiOpt str of
 971         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
 972         Just o  -> unsetOption o
 973
 974 strToGHCiOpt :: String -> (Maybe GHCiOption)
 975 strToGHCiOpt "s" = Just ShowTiming
 976 strToGHCiOpt "t" = Just ShowType
 977 strToGHCiOpt "r" = Just RevertCAFs
 978 strToGHCiOpt _   = Nothing
 979
 980 optToStr :: GHCiOption -> String
 981 optToStr ShowTiming = "s"
 982 optToStr ShowType   = "t"
 983 optToStr RevertCAFs = "r"
 984
 985 newPackages new_pkgs = do       -- The new packages are already in v_Packages
 986   state    <- getGHCiState
 987   cmstate1 <- io (cmUnload (cmstate state))
 988   setGHCiState state{ cmstate = cmstate1, targets = [] }
 989   dflags   <- getDynFlags
 990   io (linkPackages dflags new_pkgs)
 991   setContextAfterLoad []
 992
 993 -- ---------------------------------------------------------------------------
 994 -- code for `:show'
 995
 996 showCmd str =
 997   case words str of
 998         ["modules" ] -> showModules
 999         ["bindings"] -> showBindings
1000         ["linker"]   -> io showLinkerState
1001         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
1002
1003 showModules
1004   = do  { cms <- getCmState
1005         ; let show_one ms = io (putStrLn (cmShowModule cms ms))
1006         ; mapM_ show_one (cmGetModuleGraph cms) }
1007
1008 showBindings = do
1009   cms <- getCmState
1010   let
1011         unqual = cmGetPrintUnqual cms
1012 --      showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
1013         showBinding b = putStrLn (showSDocForUser unqual (ppr (getName b)))
1014
1015   io (mapM_ showBinding (cmGetBindings cms))
1016   return ()
1017
1018
1019 -----------------------------------------------------------------------------
1020 -- GHCi monad
1021
1022 data GHCiState = GHCiState
1023      {
1024         progname       :: String,
1025         args           :: [String],
1026         targets        :: [FilePath],
1027         cmstate        :: CmState,
1028         options        :: [GHCiOption]
1029      }
1030
1031 data GHCiOption
1032         = ShowTiming            -- show time/allocs after evaluation
1033         | ShowType              -- show the type of expressions
1034         | RevertCAFs            -- revert CAFs after every evaluation
1035         deriving Eq
1036
1037 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1038
1039 startGHCi :: GHCi a -> GHCiState -> IO a
1040 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1041
1042 instance Monad GHCi where
1043   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1044   return a  = GHCi $ \s -> return a
1045
1046 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1047 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1048    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1049
1050 getGHCiState   = GHCi $ \r -> readIORef r
1051 setGHCiState s = GHCi $ \r -> writeIORef r s
1052
1053 -- for convenience...
1054 getCmState = getGHCiState >>= return . cmstate
1055 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
1056
1057 getDynFlags = getCmState >>= return . cmGetDFlags
1058
1059 setDynFlags dflags = do s <- getCmState; setCmState (cmSetDFlags s dflags)
1060
1061 isOptionSet :: GHCiOption -> GHCi Bool
1062 isOptionSet opt
1063  = do st <- getGHCiState
1064       return (opt `elem` options st)
1065
1066 setOption :: GHCiOption -> GHCi ()
1067 setOption opt
1068  = do st <- getGHCiState
1069       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1070
1071 unsetOption :: GHCiOption -> GHCi ()
1072 unsetOption opt
1073  = do st <- getGHCiState
1074       setGHCiState (st{ options = filter (/= opt) (options st) })
1075
1076 io :: IO a -> GHCi a
1077 io m = GHCi { unGHCi = \s -> m >>= return }
1078
1079 -----------------------------------------------------------------------------
1080 -- recursive exception handlers
1081
1082 -- Don't forget to unblock async exceptions in the handler, or if we're
1083 -- in an exception loop (eg. let a = error a in a) the ^C exception
1084 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1085
1086 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1087 ghciHandle h (GHCi m) = GHCi $ \s ->
1088    Exception.catch (m s)
1089         (\e -> unGHCi (ghciUnblock (h e)) s)
1090
1091 ghciUnblock :: GHCi a -> GHCi a
1092 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1093
1094 -----------------------------------------------------------------------------
1095 -- timing & statistics
1096
1097 timeIt :: GHCi a -> GHCi a
1098 timeIt action
1099   = do b <- isOptionSet ShowTiming
1100        if not b
1101           then action
1102           else do allocs1 <- io $ getAllocations
1103                   time1   <- io $ getCPUTime
1104                   a <- action
1105                   allocs2 <- io $ getAllocations
1106                   time2   <- io $ getCPUTime
1107                   io $ printTimes (fromIntegral (allocs2 - allocs1))
1108                                   (time2 - time1)
1109                   return a
1110
1111 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1112         -- defined in ghc/rts/Stats.c
1113
1114 printTimes :: Integer -> Integer -> IO ()
1115 printTimes allocs psecs
1116    = do let secs = (fromIntegral psecs / (10^12)) :: Float
1117             secs_str = showFFloat (Just 2) secs
1118         putStrLn (showSDoc (
1119                  parens (text (secs_str "") <+> text "secs" <> comma <+>
1120                          text (show allocs) <+> text "bytes")))
1121
1122 -----------------------------------------------------------------------------
1123 -- reverting CAFs
1124
1125 revertCAFs :: IO ()
1126 revertCAFs = do
1127   rts_revertCAFs
1128   turnOffBuffering
1129         -- Have to turn off buffering again, because we just
1130         -- reverted stdout, stderr & stdin to their defaults.
1131
1132 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
1133         -- Make it "safe", just in case
1134
1135 -- -----------------------------------------------------------------------------
1136 -- Utils
1137
1138 expandPath :: String -> GHCi String
1139 expandPath path =
1140   case dropWhile isSpace path of
1141    ('~':d) -> do
1142         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1143         return (tilde ++ '/':d)
1144    other ->
1145         return other