ghc/compiler/ghci/InteractiveUI.hs

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