ghc/compiler/ghci/InteractiveUI.hs

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