ghc/compiler/ghci/InteractiveUI.hs

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