ghc/compiler/ghci/InteractiveUI.hs

   1 {-# OPTIONS -#include "Linker.h" #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: InteractiveUI.hs,v 1.190 2005/02/23 15:38:52 simonmar 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, isSymOcc, 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 | isSymOcc occ = parens (ppr occ)
 626              | otherwise    = ppr occ
 627
 628
 629 -----------------------------------------------------------------------------
 630 -- Commands
 631
 632 addModule :: [FilePath] -> GHCi ()
 633 addModule files = do
 634   state <- getGHCiState
 635   io (revertCAFs)                       -- always revert CAFs on load/add.
 636   files <- mapM expandPath files
 637   let new_targets = files ++ targets state
 638   graph <- io (cmDepAnal (cmstate state) new_targets)
 639   (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) graph)
 640   setGHCiState state{ cmstate = cmstate1, targets = new_targets }
 641   setContextAfterLoad mods
 642   dflags <- getDynFlags
 643   modulesLoadedMsg ok mods dflags
 644
 645 changeDirectory :: String -> GHCi ()
 646 changeDirectory dir = do
 647   state    <- getGHCiState
 648   when (targets state /= []) $
 649         io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
 650   cmstate1 <- io (cmUnload (cmstate state))
 651   setGHCiState state{ cmstate = cmstate1, targets = [] }
 652   setContextAfterLoad []
 653   dir <- expandPath dir
 654   io (setCurrentDirectory dir)
 655
 656 defineMacro :: String -> GHCi ()
 657 defineMacro s = do
 658   let (macro_name, definition) = break isSpace s
 659   cmds <- io (readIORef commands)
 660   if (null macro_name)
 661         then throwDyn (CmdLineError "invalid macro name")
 662         else do
 663   if (macro_name `elem` map fst cmds)
 664         then throwDyn (CmdLineError
 665                 ("command '" ++ macro_name ++ "' is already defined"))
 666         else do
 667
 668   -- give the expression a type signature, so we can be sure we're getting
 669   -- something of the right type.
 670   let new_expr = '(' : definition ++ ") :: String -> IO String"
 671
 672   -- compile the expression
 673   cms <- getCmState
 674   maybe_hv <- io (cmCompileExpr cms new_expr)
 675   case maybe_hv of
 676      Nothing -> return ()
 677      Just hv -> io (writeIORef commands --
 678                     ((macro_name, keepGoing (runMacro hv)) : cmds))
 679
 680 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
 681 runMacro fun s = do
 682   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 683   stringLoop (lines str)
 684
 685 undefineMacro :: String -> GHCi ()
 686 undefineMacro macro_name = do
 687   cmds <- io (readIORef commands)
 688   if (macro_name `elem` map fst builtin_commands)
 689         then throwDyn (CmdLineError
 690                 ("command '" ++ macro_name ++ "' cannot be undefined"))
 691         else do
 692   if (macro_name `notElem` map fst cmds)
 693         then throwDyn (CmdLineError
 694                 ("command '" ++ macro_name ++ "' not defined"))
 695         else do
 696   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 697
 698
 699 loadModule :: [FilePath] -> GHCi ()
 700 loadModule fs = timeIt (loadModule' fs)
 701
 702 loadModule' :: [FilePath] -> GHCi ()
 703 loadModule' files = do
 704   state <- getGHCiState
 705
 706   -- expand tildes
 707   files <- mapM expandPath files
 708
 709   -- do the dependency anal first, so that if it fails we don't throw
 710   -- away the current set of modules.
 711   graph <- io (cmDepAnal (cmstate state) files)
 712
 713   -- Dependency anal ok, now unload everything
 714   cmstate1 <- io (cmUnload (cmstate state))
 715   setGHCiState state{ cmstate = cmstate1, targets = [] }
 716
 717   io (revertCAFs)  -- always revert CAFs on load.
 718   (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 graph)
 719   setGHCiState state{ cmstate = cmstate2, targets = files }
 720
 721   setContextAfterLoad mods
 722   dflags <- getDynFlags
 723   modulesLoadedMsg ok mods dflags
 724
 725
 726 reloadModule :: String -> GHCi ()
 727 reloadModule "" = do
 728   state <- getGHCiState
 729   case targets state of
 730    [] -> io (putStr "no current target\n")
 731    paths -> do
 732         -- do the dependency anal first, so that if it fails we don't throw
 733         -- away the current set of modules.
 734         graph <- io (cmDepAnal (cmstate state) paths)
 735
 736         io (revertCAFs)         -- always revert CAFs on reload.
 737         (cmstate1, ok, mods)
 738                 <- io (cmLoadModules (cmstate state) graph)
 739         setGHCiState state{ cmstate=cmstate1 }
 740         setContextAfterLoad mods
 741         dflags <- getDynFlags
 742         modulesLoadedMsg ok mods dflags
 743
 744 reloadModule _ = noArgs ":reload"
 745
 746 setContextAfterLoad [] = setContext prel
 747 setContextAfterLoad (m:_) = do
 748   cmstate <- getCmState
 749   b <- io (cmModuleIsInterpreted cmstate m)
 750   if b then setContext ('*':m) else setContext m
 751
 752 modulesLoadedMsg ok mods dflags =
 753   when (verbosity dflags > 0) $ do
 754    let mod_commas
 755         | null mods = text "none."
 756         | otherwise = hsep (
 757             punctuate comma (map text mods)) <> text "."
 758    case ok of
 759     Failed ->
 760        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 761     Succeeded  ->
 762        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 763
 764
 765 typeOfExpr :: String -> GHCi ()
 766 typeOfExpr str
 767   = do cms <- getCmState
 768        maybe_tystr <- io (cmTypeOfExpr cms str)
 769        case maybe_tystr of
 770           Nothing    -> return ()
 771           Just tystr -> io (putStrLn tystr)
 772
 773 kindOfType :: String -> GHCi ()
 774 kindOfType str
 775   = do cms <- getCmState
 776        maybe_tystr <- io (cmKindOfType cms str)
 777        case maybe_tystr of
 778           Nothing    -> return ()
 779           Just tystr -> io (putStrLn tystr)
 780
 781 quit :: String -> GHCi Bool
 782 quit _ = return True
 783
 784 shellEscape :: String -> GHCi Bool
 785 shellEscape str = io (system str >> return False)
 786
 787 -----------------------------------------------------------------------------
 788 -- Browsing a module's contents
 789
 790 browseCmd :: String -> GHCi ()
 791 browseCmd m =
 792   case words m of
 793     ['*':m] | looksLikeModuleName m -> browseModule m False
 794     [m]     | looksLikeModuleName m -> browseModule m True
 795     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 796
 797 browseModule m exports_only = do
 798   cms <- getCmState
 799
 800   is_interpreted <- io (cmModuleIsInterpreted cms m)
 801   when (not is_interpreted && not exports_only) $
 802         throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
 803
 804   -- Temporarily set the context to the module we're interested in,
 805   -- just so we can get an appropriate PrintUnqualified
 806   (as,bs) <- io (cmGetContext cms)
 807   cms1 <- io (if exports_only then cmSetContext cms [] [prel,m]
 808                               else cmSetContext cms [m] [])
 809   cms2 <- io (cmSetContext cms1 as bs)
 810
 811   things <- io (cmBrowseModule cms2 m exports_only)
 812
 813   let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
 814
 815   dflags <- getDynFlags
 816   let exts = dopt Opt_GlasgowExts dflags
 817   io (putStrLn (showSDocForUser unqual (
 818          vcat (map (showDecl exts (const True)) things)
 819       )))
 820
 821 -----------------------------------------------------------------------------
 822 -- Setting the module context
 823
 824 setContext str
 825   | all sensible mods = fn mods
 826   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
 827   where
 828     (fn, mods) = case str of
 829                         '+':stuff -> (addToContext,      words stuff)
 830                         '-':stuff -> (removeFromContext, words stuff)
 831                         stuff     -> (newContext,        words stuff)
 832
 833     sensible ('*':m) = looksLikeModuleName m
 834     sensible m       = looksLikeModuleName m
 835
 836 newContext mods = do
 837   cms <- getCmState
 838   (as,bs) <- separate cms mods [] []
 839   let bs' = if null as && prel `notElem` bs then prel:bs else bs
 840   cms' <- io (cmSetContext cms as bs')
 841   setCmState cms'
 842
 843 separate cmstate []           as bs = return (as,bs)
 844 separate cmstate (('*':m):ms) as bs = do
 845    b <- io (cmModuleIsInterpreted cmstate m)
 846    if b then separate cmstate ms (m:as) bs
 847         else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
 848 separate cmstate (m:ms)       as bs = separate cmstate ms as (m:bs)
 849
 850 prel = "Prelude"
 851
 852
 853 addToContext mods = do
 854   cms <- getCmState
 855   (as,bs) <- io (cmGetContext cms)
 856
 857   (as',bs') <- separate cms mods [] []
 858
 859   let as_to_add = as' \\ (as ++ bs)
 860       bs_to_add = bs' \\ (as ++ bs)
 861
 862   cms' <- io (cmSetContext cms
 863                         (as ++ as_to_add) (bs ++ bs_to_add))
 864   setCmState cms'
 865
 866
 867 removeFromContext mods = do
 868   cms <- getCmState
 869   (as,bs) <- io (cmGetContext cms)
 870
 871   (as_to_remove,bs_to_remove) <- separate cms mods [] []
 872
 873   let as' = as \\ (as_to_remove ++ bs_to_remove)
 874       bs' = bs \\ (as_to_remove ++ bs_to_remove)
 875
 876   cms' <- io (cmSetContext cms as' bs')
 877   setCmState cms'
 878
 879 ----------------------------------------------------------------------------
 880 -- Code for `:set'
 881
 882 -- set options in the interpreter.  Syntax is exactly the same as the
 883 -- ghc command line, except that certain options aren't available (-C,
 884 -- -E etc.)
 885 --
 886 -- This is pretty fragile: most options won't work as expected.  ToDo:
 887 -- figure out which ones & disallow them.
 888
 889 setCmd :: String -> GHCi ()
 890 setCmd ""
 891   = do st <- getGHCiState
 892        let opts = options st
 893        io $ putStrLn (showSDoc (
 894               text "options currently set: " <>
 895               if null opts
 896                    then text "none."
 897                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 898            ))
 899 setCmd str
 900   = case words str of
 901         ("args":args) -> setArgs args
 902         ("prog":prog) -> setProg prog
 903         wds -> setOptions wds
 904
 905 setArgs args = do
 906   st <- getGHCiState
 907   setGHCiState st{ args = args }
 908
 909 setProg [prog] = do
 910   st <- getGHCiState
 911   setGHCiState st{ progname = prog }
 912 setProg _ = do
 913   io (hPutStrLn stderr "syntax: :set prog <progname>")
 914
 915 setOptions wds =
 916    do -- first, deal with the GHCi opts (+s, +t, etc.)
 917       let (plus_opts, minus_opts)  = partition isPlus wds
 918       mapM_ setOpt plus_opts
 919
 920       -- now, the GHC flags
 921       leftovers <- io $ processStaticFlags minus_opts
 922
 923       -- then, dynamic flags
 924       dflags <- getDynFlags
 925       (dflags',leftovers) <- io $ processDynamicFlags leftovers dflags
 926       setDynFlags dflags'
 927
 928         -- update things if the users wants more packages
 929 {- TODO:
 930         let new_packages = pkgs_after \\ pkgs_before
 931         when (not (null new_packages)) $
 932            newPackages new_packages
 933 -}
 934
 935       if (not (null leftovers))
 936                 then throwDyn (CmdLineError ("unrecognised flags: " ++
 937                                                 unwords leftovers))
 938                 else return ()
 939
 940
 941 unsetOptions :: String -> GHCi ()
 942 unsetOptions str
 943   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 944        let opts = words str
 945            (minus_opts, rest1) = partition isMinus opts
 946            (plus_opts, rest2)  = partition isPlus rest1
 947
 948        if (not (null rest2))
 949           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
 950           else do
 951
 952        mapM_ unsetOpt plus_opts
 953
 954        -- can't do GHC flags for now
 955        if (not (null minus_opts))
 956           then throwDyn (CmdLineError "can't unset GHC command-line flags")
 957           else return ()
 958
 959 isMinus ('-':s) = True
 960 isMinus _ = False
 961
 962 isPlus ('+':s) = True
 963 isPlus _ = False
 964
 965 setOpt ('+':str)
 966   = case strToGHCiOpt str of
 967         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
 968         Just o  -> setOption o
 969
 970 unsetOpt ('+':str)
 971   = case strToGHCiOpt str of
 972         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
 973         Just o  -> unsetOption o
 974
 975 strToGHCiOpt :: String -> (Maybe GHCiOption)
 976 strToGHCiOpt "s" = Just ShowTiming
 977 strToGHCiOpt "t" = Just ShowType
 978 strToGHCiOpt "r" = Just RevertCAFs
 979 strToGHCiOpt _   = Nothing
 980
 981 optToStr :: GHCiOption -> String
 982 optToStr ShowTiming = "s"
 983 optToStr ShowType   = "t"
 984 optToStr RevertCAFs = "r"
 985
 986 newPackages new_pkgs = do       -- The new packages are already in v_Packages
 987   state    <- getGHCiState
 988   cmstate1 <- io (cmUnload (cmstate state))
 989   setGHCiState state{ cmstate = cmstate1, targets = [] }
 990   dflags   <- getDynFlags
 991   io (linkPackages dflags new_pkgs)
 992   setContextAfterLoad []
 993
 994 -- ---------------------------------------------------------------------------
 995 -- code for `:show'
 996
 997 showCmd str =
 998   case words str of
 999         ["modules" ] -> showModules
1000         ["bindings"] -> showBindings
1001         ["linker"]   -> io showLinkerState
1002         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
1003
1004 showModules
1005   = do  { cms <- getCmState
1006         ; let show_one ms = io (putStrLn (cmShowModule cms ms))
1007         ; mapM_ show_one (cmGetModuleGraph cms) }
1008
1009 showBindings = do
1010   cms <- getCmState
1011   let
1012         unqual = cmGetPrintUnqual cms
1013 --      showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
1014         showBinding b = putStrLn (showSDocForUser unqual (ppr (getName b)))
1015
1016   io (mapM_ showBinding (cmGetBindings cms))
1017   return ()
1018
1019
1020 -----------------------------------------------------------------------------
1021 -- GHCi monad
1022
1023 data GHCiState = GHCiState
1024      {
1025         progname       :: String,
1026         args           :: [String],
1027         targets        :: [FilePath],
1028         cmstate        :: CmState,
1029         options        :: [GHCiOption]
1030      }
1031
1032 data GHCiOption
1033         = ShowTiming            -- show time/allocs after evaluation
1034         | ShowType              -- show the type of expressions
1035         | RevertCAFs            -- revert CAFs after every evaluation
1036         deriving Eq
1037
1038 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1039
1040 startGHCi :: GHCi a -> GHCiState -> IO a
1041 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1042
1043 instance Monad GHCi where
1044   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1045   return a  = GHCi $ \s -> return a
1046
1047 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1048 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1049    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1050
1051 getGHCiState   = GHCi $ \r -> readIORef r
1052 setGHCiState s = GHCi $ \r -> writeIORef r s
1053
1054 -- for convenience...
1055 getCmState = getGHCiState >>= return . cmstate
1056 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
1057
1058 getDynFlags = getCmState >>= return . cmGetDFlags
1059
1060 setDynFlags dflags = do s <- getCmState; setCmState (cmSetDFlags s dflags)
1061
1062 isOptionSet :: GHCiOption -> GHCi Bool
1063 isOptionSet opt
1064  = do st <- getGHCiState
1065       return (opt `elem` options st)
1066
1067 setOption :: GHCiOption -> GHCi ()
1068 setOption opt
1069  = do st <- getGHCiState
1070       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1071
1072 unsetOption :: GHCiOption -> GHCi ()
1073 unsetOption opt
1074  = do st <- getGHCiState
1075       setGHCiState (st{ options = filter (/= opt) (options st) })
1076
1077 io :: IO a -> GHCi a
1078 io m = GHCi { unGHCi = \s -> m >>= return }
1079
1080 -----------------------------------------------------------------------------
1081 -- recursive exception handlers
1082
1083 -- Don't forget to unblock async exceptions in the handler, or if we're
1084 -- in an exception loop (eg. let a = error a in a) the ^C exception
1085 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1086
1087 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1088 ghciHandle h (GHCi m) = GHCi $ \s ->
1089    Exception.catch (m s)
1090         (\e -> unGHCi (ghciUnblock (h e)) s)
1091
1092 ghciUnblock :: GHCi a -> GHCi a
1093 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1094
1095 -----------------------------------------------------------------------------
1096 -- timing & statistics
1097
1098 timeIt :: GHCi a -> GHCi a
1099 timeIt action
1100   = do b <- isOptionSet ShowTiming
1101        if not b
1102           then action
1103           else do allocs1 <- io $ getAllocations
1104                   time1   <- io $ getCPUTime
1105                   a <- action
1106                   allocs2 <- io $ getAllocations
1107                   time2   <- io $ getCPUTime
1108                   io $ printTimes (fromIntegral (allocs2 - allocs1))
1109                                   (time2 - time1)
1110                   return a
1111
1112 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1113         -- defined in ghc/rts/Stats.c
1114
1115 printTimes :: Integer -> Integer -> IO ()
1116 printTimes allocs psecs
1117    = do let secs = (fromIntegral psecs / (10^12)) :: Float
1118             secs_str = showFFloat (Just 2) secs
1119         putStrLn (showSDoc (
1120                  parens (text (secs_str "") <+> text "secs" <> comma <+>
1121                          text (show allocs) <+> text "bytes")))
1122
1123 -----------------------------------------------------------------------------
1124 -- reverting CAFs
1125
1126 revertCAFs :: IO ()
1127 revertCAFs = do
1128   rts_revertCAFs
1129   turnOffBuffering
1130         -- Have to turn off buffering again, because we just
1131         -- reverted stdout, stderr & stdin to their defaults.
1132
1133 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
1134         -- Make it "safe", just in case
1135
1136 -- -----------------------------------------------------------------------------
1137 -- Utils
1138
1139 expandPath :: String -> GHCi String
1140 expandPath path =
1141   case dropWhile isSpace path of
1142    ('~':d) -> do
1143         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1144         return (tilde ++ '/':d)
1145    other ->
1146         return other