ghc/compiler/ghci/InteractiveUI.hs

   1 {-# OPTIONS -#include "Linker.h" #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: InteractiveUI.hs,v 1.144 2003/02/13 01:50:04 sof 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 Id               ( isRecordSelector, isImplicitId, recordSelectorFieldLabel, idName )
  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            ( GhcException(..), showGhcException )
  45 import Config
  46
  47 #ifndef mingw32_TARGET_OS
  48 import System.Posix
  49 #endif
  50
  51 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
  52 import Control.Concurrent       ( yield )       -- Used in readline loop
  53 import System.Console.Readline as Readline
  54 #endif
  55
  56 --import SystemExts
  57
  58 import Control.Exception as Exception
  59 import Data.Dynamic
  60 import Control.Concurrent
  61
  62 import Numeric
  63 import Data.List
  64 import System.Cmd
  65 import System.CPUTime
  66 import System.Environment
  67 import System.Directory
  68 import System.IO as IO
  69 import Data.Char
  70 import Control.Monad as Monad
  71
  72 import GHC.Exts         ( unsafeCoerce# )
  73
  74 import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )
  75
  76 import GHC.Posix        ( setNonBlockingFD )
  77
  78 -----------------------------------------------------------------------------
  79
  80 ghciWelcomeMsg = "\
  81 \   ___         ___ _\n\
  82 \  / _ \\ /\\  /\\/ __(_)\n\
  83 \ / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
  84 \/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n\
  85 \\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
  86
  87 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
  88
  89 builtin_commands :: [(String, String -> GHCi Bool)]
  90 builtin_commands = [
  91   ("add",       keepGoingPaths addModule),
  92   ("browse",    keepGoing browseCmd),
  93   ("cd",        keepGoing changeDirectory),
  94   ("def",       keepGoing defineMacro),
  95   ("help",      keepGoing help),
  96   ("?",         keepGoing help),
  97   ("info",      keepGoing info),
  98   ("load",      keepGoingPaths loadModule),
  99   ("module",    keepGoing setContext),
 100   ("reload",    keepGoing reloadModule),
 101   ("set",       keepGoing setCmd),
 102   ("show",      keepGoing showCmd),
 103   ("type",      keepGoing typeOfExpr),
 104   ("unset",     keepGoing unsetOptions),
 105   ("undef",     keepGoing undefineMacro),
 106   ("quit",      quit)
 107   ]
 108
 109 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 110 keepGoing a str = a str >> return False
 111
 112 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
 113 keepGoingPaths a str = a (toArgs str) >> return False
 114
 115 shortHelpText = "use :? for help.\n"
 116
 117 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
 118 helpText = "\
 119 \ Commands available from the prompt:\n\
 120 \\n\
 121 \   <stmt>                     evaluate/run <stmt>\n\
 122 \   :add <filename> ...        add module(s) to the current target set\n\
 123 \   :browse [*]<module>        display the names defined by <module>\n\
 124 \   :cd <dir>                  change directory to <dir>\n\
 125 \   :def <cmd> <expr>          define a command :<cmd>\n\
 126 \   :help, :?                  display this list of commands\n\
 127 \   :info [<name> ...]         display information about the given names\n\
 128 \   :load <filename> ...       load module(s) and their dependents\n\
 129 \   :module [+/-] [*]<mod> ... set the context for expression evaluation\n\
 130 \   :reload                    reload the current module set\n\
 131 \\n\
 132 \   :set <option> ...          set options\n\
 133 \   :set args <arg> ...        set the arguments returned by System.getArgs\n\
 134 \   :set prog <progname>       set the value returned by System.getProgName\n\
 135 \\n\
 136 \   :show modules              show the currently loaded modules\n\
 137 \   :show bindings             show the current bindings made at the prompt\n\
 138 \\n\
 139 \   :type <expr>               show the type of <expr>\n\
 140 \   :undef <cmd>               undefine user-defined command :<cmd>\n\
 141 \   :unset <option> ...        unset options\n\
 142 \   :quit                      exit GHCi\n\
 143 \   :!<command>                run the shell command <command>\n\
 144 \\n\
 145 \ Options for `:set' and `:unset':\n\
 146 \\n\
 147 \    +r                 revert top-level expressions after each evaluation\n\
 148 \    +s                 print timing/memory stats after each evaluation\n\
 149 \    +t                 print type after evaluation\n\
 150 \    -<flags>           most GHC command line flags can also be set here\n\
 151 \                         (eg. -v2, -fglasgow-exts, etc.)\n\
 152 \"
 153
 154 interactiveUI :: CmState -> [FilePath] -> [FilePath] -> IO ()
 155 interactiveUI cmstate paths cmdline_objs = do
 156    hFlush stdout
 157    hSetBuffering stdout NoBuffering
 158
 159    dflags <- getDynFlags
 160
 161    initLinker
 162
 163         -- link packages requested explicitly on the command-line
 164    expl <- readIORef v_ExplicitPackages
 165    linkPackages dflags expl
 166
 167         -- link libraries from the command-line
 168    linkLibraries dflags cmdline_objs
 169
 170         -- Initialise buffering for the *interpreted* I/O system
 171    cmstate <- initInterpBuffering cmstate dflags
 172
 173         -- We don't want the cmd line to buffer any input that might be
 174         -- intended for the program, so unbuffer stdin.
 175    hSetBuffering stdin NoBuffering
 176
 177         -- initial context is just the Prelude
 178    cmstate <- cmSetContext cmstate dflags [] ["Prelude"]
 179
 180 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 181    Readline.initialize
 182 #endif
 183
 184    startGHCi (runGHCi paths dflags)
 185         GHCiState{ progname = "<interactive>",
 186                    args = [],
 187                    targets = paths,
 188                    cmstate = cmstate,
 189                    options = [] }
 190
 191 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 192    Readline.resetTerminal Nothing
 193 #endif
 194
 195    return ()
 196
 197 runGHCi :: [FilePath] -> DynFlags -> GHCi ()
 198 runGHCi paths dflags = do
 199   read_dot_files <- io (readIORef v_Read_DotGHCi)
 200
 201   when (read_dot_files) $ do
 202     -- Read in ./.ghci.
 203     let file = "./.ghci"
 204     exists <- io (doesFileExist file)
 205     when exists $ do
 206        dir_ok  <- io (checkPerms ".")
 207        file_ok <- io (checkPerms file)
 208        when (dir_ok && file_ok) $ do
 209           either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
 210           case either_hdl of
 211              Left e    -> return ()
 212              Right hdl -> fileLoop hdl False
 213
 214   when (read_dot_files) $ do
 215     -- Read in $HOME/.ghci
 216     either_dir <- io (IO.try (getEnv "HOME"))
 217     case either_dir of
 218        Left e -> return ()
 219        Right dir -> do
 220           cwd <- io (getCurrentDirectory)
 221           when (dir /= cwd) $ do
 222              let file = dir ++ "/.ghci"
 223              ok <- io (checkPerms file)
 224              when ok $ do
 225                either_hdl <- io (IO.try (openFile file ReadMode))
 226                case either_hdl of
 227                   Left e    -> return ()
 228                   Right hdl -> fileLoop hdl False
 229
 230   -- perform a :load for files given on the GHCi command line
 231   when (not (null paths)) $
 232      ghciHandle showException $
 233         loadModule paths
 234
 235   -- enter the interactive loop
 236 #if defined(mingw32_TARGET_OS)
 237    -- always show prompt, since hIsTerminalDevice returns True for Consoles
 238    -- only, which we may or may not be running under (cf. Emacs sub-shells.)
 239   interactiveLoop True
 240 #else
 241   is_tty <- io (hIsTerminalDevice stdin)
 242   interactiveLoop is_tty
 243 #endif
 244
 245   -- and finally, exit
 246   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
 247
 248
 249 interactiveLoop is_tty = do
 250   -- ignore ^C exceptions caught here
 251   ghciHandleDyn (\e -> case e of
 252                         Interrupted -> ghciUnblock (interactiveLoop is_tty)
 253                         _other      -> return ()) $ do
 254
 255   -- read commands from stdin
 256 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 257   if (is_tty)
 258         then readlineLoop
 259         else fileLoop stdin False  -- turn off prompt for non-TTY input
 260 #else
 261   fileLoop stdin is_tty
 262 #endif
 263
 264
 265 -- NOTE: We only read .ghci files if they are owned by the current user,
 266 -- and aren't world writable.  Otherwise, we could be accidentally
 267 -- running code planted by a malicious third party.
 268
 269 -- Furthermore, We only read ./.ghci if . is owned by the current user
 270 -- and isn't writable by anyone else.  I think this is sufficient: we
 271 -- don't need to check .. and ../.. etc. because "."  always refers to
 272 -- the same directory while a process is running.
 273
 274 checkPerms :: String -> IO Bool
 275 checkPerms name =
 276 #ifdef mingw32_TARGET_OS
 277   return True
 278 #else
 279   DriverUtil.handle (\_ -> return False) $ do
 280      st <- getFileStatus name
 281      me <- getRealUserID
 282      if fileOwner st /= me then do
 283         putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
 284         return False
 285       else do
 286         let mode =  fileMode st
 287         if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
 288            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
 289            then do
 290                putStrLn $ "*** WARNING: " ++ name ++
 291                           " is writable by someone else, IGNORING!"
 292                return False
 293           else return True
 294 #endif
 295
 296 fileLoop :: Handle -> Bool -> GHCi ()
 297 fileLoop hdl prompt = do
 298    cmstate <- getCmState
 299    (mod,imports) <- io (cmGetContext cmstate)
 300    when prompt (io (putStr (mkPrompt mod imports)))
 301    l <- io (IO.try (hGetLine hdl))
 302    case l of
 303         Left e | isEOFError e -> return ()
 304                | otherwise    -> io (ioError e)
 305         Right l ->
 306           case remove_spaces l of
 307             "" -> fileLoop hdl prompt
 308             l  -> do quit <- runCommand l
 309                      if quit then return () else fileLoop hdl prompt
 310
 311 stringLoop :: [String] -> GHCi ()
 312 stringLoop [] = return ()
 313 stringLoop (s:ss) = do
 314    case remove_spaces s of
 315         "" -> stringLoop ss
 316         l  -> do quit <- runCommand l
 317                  if quit then return () else stringLoop ss
 318
 319 mkPrompt toplevs exports
 320    = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
 321
 322 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 323 readlineLoop :: GHCi ()
 324 readlineLoop = do
 325    cmstate <- getCmState
 326    (mod,imports) <- io (cmGetContext cmstate)
 327    io yield
 328    l <- io (readline (mkPrompt mod imports)
 329                 `finally` setNonBlockingFD 0)
 330                 -- readline sometimes puts stdin into blocking mode,
 331                 -- so we need to put it back for the IO library
 332    case l of
 333         Nothing -> return ()
 334         Just l  ->
 335           case remove_spaces l of
 336             "" -> readlineLoop
 337             l  -> do
 338                   io (addHistory l)
 339                   quit <- runCommand l
 340                   if quit then return () else readlineLoop
 341 #endif
 342
 343 runCommand :: String -> GHCi Bool
 344 runCommand c = ghciHandle handler (doCommand c)
 345
 346 -- This is the exception handler for exceptions generated by the
 347 -- user's code; it normally just prints out the exception.  The
 348 -- handler must be recursive, in case showing the exception causes
 349 -- more exceptions to be raised.
 350 --
 351 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
 352 -- raising another exception.  We therefore don't put the recursive
 353 -- handler arond the flushing operation, so if stderr is closed
 354 -- GHCi will just die gracefully rather than going into an infinite loop.
 355 handler :: Exception -> GHCi Bool
 356 handler exception = do
 357   flushInterpBuffers
 358   ghciHandle handler (showException exception >> return False)
 359
 360 showException (DynException dyn) =
 361   case fromDynamic dyn of
 362     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
 363     Just Interrupted      -> io (putStrLn "Interrupted.")
 364     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
 365     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
 366     Just other_ghc_ex     -> io (print other_ghc_ex)
 367
 368 showException other_exception
 369   = io (putStrLn ("*** Exception: " ++ show other_exception))
 370
 371 doCommand (':' : command) = specialCommand command
 372 doCommand stmt
 373    = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
 374         return False
 375
 376 runStmt :: String -> GHCi [Name]
 377 runStmt stmt
 378  | null (filter (not.isSpace) stmt) = return []
 379  | otherwise
 380  = do st <- getGHCiState
 381       dflags <- io getDynFlags
 382       let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
 383       (new_cmstate, result) <-
 384         io $ withProgName (progname st) $ withArgs (args st) $
 385         cmRunStmt (cmstate st) dflags' stmt
 386       setGHCiState st{cmstate = new_cmstate}
 387       case result of
 388         CmRunFailed      -> return []
 389         CmRunException e -> showException e >> return []
 390         CmRunOk names    -> return names
 391
 392 -- possibly print the type and revert CAFs after evaluating an expression
 393 finishEvalExpr names
 394  = do b <- isOptionSet ShowType
 395       cmstate <- getCmState
 396       when b (mapM_ (showTypeOfName cmstate) names)
 397
 398       flushInterpBuffers
 399       b <- isOptionSet RevertCAFs
 400       io (when b revertCAFs)
 401       return True
 402
 403 showTypeOfName :: CmState -> Name -> GHCi ()
 404 showTypeOfName cmstate n
 405    = do maybe_str <- io (cmTypeOfName cmstate n)
 406         case maybe_str of
 407           Nothing  -> return ()
 408           Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
 409
 410 specialCommand :: String -> GHCi Bool
 411 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 412 specialCommand str = do
 413   let (cmd,rest) = break isSpace str
 414   cmds <- io (readIORef commands)
 415   case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
 416      []      -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
 417                                     ++ shortHelpText) >> return False)
 418      [(_,f)] -> f (dropWhile isSpace rest)
 419      cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++
 420                                       " matches multiple commands (" ++
 421                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
 422                                          ++ ")") >> return False)
 423
 424 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
 425
 426
 427 -----------------------------------------------------------------------------
 428 -- To flush buffers for the *interpreted* computation we need
 429 -- to refer to *its* stdout/stderr handles
 430
 431 GLOBAL_VAR(flush_interp,       error "no flush_interp", IO ())
 432 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
 433
 434 no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++
 435              " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
 436 flush_cmd  = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr"
 437
 438 initInterpBuffering :: CmState -> DynFlags -> IO CmState
 439 initInterpBuffering cmstate dflags
 440  = do (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags no_buf_cmd
 441
 442       case maybe_hval of
 443         Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
 444         other     -> panic "interactiveUI:setBuffering"
 445
 446       (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags flush_cmd
 447       case maybe_hval of
 448         Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
 449         _         -> panic "interactiveUI:flush"
 450
 451       turnOffBuffering  -- Turn it off right now
 452
 453       return cmstate
 454
 455
 456 flushInterpBuffers :: GHCi ()
 457 flushInterpBuffers
 458  = io $ do Monad.join (readIORef flush_interp)
 459            return ()
 460
 461 turnOffBuffering :: IO ()
 462 turnOffBuffering
 463  = do Monad.join (readIORef turn_off_buffering)
 464       return ()
 465
 466 -----------------------------------------------------------------------------
 467 -- Commands
 468
 469 help :: String -> GHCi ()
 470 help _ = io (putStr helpText)
 471
 472 info :: String -> GHCi ()
 473 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
 474 info s = do
 475   let names = words s
 476   init_cms <- getCmState
 477   dflags <- io getDynFlags
 478   let
 479     infoThings cms [] = return cms
 480     infoThings cms (name:names) = do
 481       (cms, stuff) <- io (cmInfoThing cms dflags name)
 482       io (putStrLn (showSDocForUser unqual (
 483             vcat (intersperse (text "") (map showThing stuff))))
 484          )
 485       infoThings cms names
 486
 487     unqual = cmGetPrintUnqual init_cms
 488
 489     showThing (ty_thing, fixity)
 490         = vcat [ text "-- " <> showTyThing ty_thing,
 491                  showFixity fixity (getName ty_thing),
 492                  ppr (ifaceTyThing ty_thing) ]
 493
 494     showFixity fix name
 495         | fix == defaultFixity = empty
 496         | otherwise            = ppr fix <+>
 497                                  (if isSymOcc (nameOccName name)
 498                                         then ppr name
 499                                         else char '`' <> ppr name <> char '`')
 500
 501     showTyThing (AClass cl)
 502        = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
 503     showTyThing (ADataCon dc)
 504        = hcat [ppr dc, text " is a data constructor", showSrcLoc (dataConName dc)]
 505     showTyThing (ATyCon ty)
 506        | isPrimTyCon ty
 507        = hcat [ppr ty, text " is a primitive type constructor"]
 508        | otherwise
 509        = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
 510     showTyThing (AnId   id)
 511        = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
 512
 513     idDescr id
 514        | isRecordSelector id =
 515                 case tyConClass_maybe (fieldLabelTyCon (
 516                                 recordSelectorFieldLabel id)) of
 517                         Nothing -> text "record selector"
 518                         Just c  -> text "method in class " <> ppr c
 519        | otherwise           = text "variable"
 520
 521         -- also print out the source location for home things
 522     showSrcLoc name
 523         | isHomePackageName name && isGoodSrcLoc loc
 524         = hsep [ text ", defined at", ppr loc ]
 525         | otherwise
 526         = empty
 527         where loc = nameSrcLoc name
 528
 529   cms <- infoThings init_cms names
 530   setCmState cms
 531   return ()
 532
 533 addModule :: [FilePath] -> GHCi ()
 534 addModule files = do
 535   state <- getGHCiState
 536   dflags <- io (getDynFlags)
 537   io (revertCAFs)                       -- always revert CAFs on load/add.
 538   let new_targets = files ++ targets state
 539   graph <- io (cmDepAnal (cmstate state) dflags new_targets)
 540   (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
 541   setGHCiState state{ cmstate = cmstate1, targets = new_targets }
 542   setContextAfterLoad mods
 543   modulesLoadedMsg ok mods dflags
 544
 545 changeDirectory :: String -> GHCi ()
 546 changeDirectory ('~':d) = do
 547    tilde <- io (getEnv "HOME")  -- will fail if HOME not defined
 548    io (setCurrentDirectory (tilde ++ '/':d))
 549 changeDirectory d = io (setCurrentDirectory d)
 550
 551 defineMacro :: String -> GHCi ()
 552 defineMacro s = do
 553   let (macro_name, definition) = break isSpace s
 554   cmds <- io (readIORef commands)
 555   if (null macro_name)
 556         then throwDyn (CmdLineError "invalid macro name")
 557         else do
 558   if (macro_name `elem` map fst cmds)
 559         then throwDyn (CmdLineError
 560                 ("command `" ++ macro_name ++ "' is already defined"))
 561         else do
 562
 563   -- give the expression a type signature, so we can be sure we're getting
 564   -- something of the right type.
 565   let new_expr = '(' : definition ++ ") :: String -> IO String"
 566
 567   -- compile the expression
 568   cms <- getCmState
 569   dflags <- io getDynFlags
 570   (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
 571   setCmState new_cmstate
 572   case maybe_hv of
 573      Nothing -> return ()
 574      Just hv -> io (writeIORef commands --
 575                     ((macro_name, keepGoing (runMacro hv)) : cmds))
 576
 577 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
 578 runMacro fun s = do
 579   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 580   stringLoop (lines str)
 581
 582 undefineMacro :: String -> GHCi ()
 583 undefineMacro macro_name = do
 584   cmds <- io (readIORef commands)
 585   if (macro_name `elem` map fst builtin_commands)
 586         then throwDyn (CmdLineError
 587                 ("command `" ++ macro_name ++ "' cannot be undefined"))
 588         else do
 589   if (macro_name `notElem` map fst cmds)
 590         then throwDyn (CmdLineError
 591                 ("command `" ++ macro_name ++ "' not defined"))
 592         else do
 593   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 594
 595
 596 loadModule :: [FilePath] -> GHCi ()
 597 loadModule fs = timeIt (loadModule' fs)
 598
 599 loadModule' :: [FilePath] -> GHCi ()
 600 loadModule' files = do
 601   state <- getGHCiState
 602   dflags <- io getDynFlags
 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