ghc/compiler/ghci/InteractiveUI.hs

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