ghc/compiler/ghci/InteractiveUI.hs

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