ghc/compiler/ghci/InteractiveUI.hs

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