ghc/compiler/ghci/InteractiveUI.hs

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