ghc/compiler/ghci/InteractiveUI.hs

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