ghc/compiler/ghci/InteractiveUI.hs

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