ghc/compiler/ghci/InteractiveUI.hs

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