ghc/compiler/ghci/InteractiveUI.hs

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