ghc/compiler/ghci/InteractiveUI.hs

   1 {-# OPTIONS -#include "Linker.h" #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: InteractiveUI.hs,v 1.145 2003/02/17 12:24:26 simonmar 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            hiding ( showException )
  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   io installSignalHandlers
 359   ghciHandle handler (showException exception >> return False)
 360
 361 showException (DynException dyn) =
 362   case fromDynamic dyn of
 363     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
 364     Just Interrupted      -> io (putStrLn "Interrupted.")
 365     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
 366     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
 367     Just other_ghc_ex     -> io (print other_ghc_ex)
 368
 369 showException other_exception
 370   = io (putStrLn ("*** Exception: " ++ show other_exception))
 371
 372 doCommand (':' : command) = specialCommand command
 373 doCommand stmt
 374    = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
 375         return False
 376
 377 runStmt :: String -> GHCi [Name]
 378 runStmt stmt
 379  | null (filter (not.isSpace) stmt) = return []
 380  | otherwise
 381  = do st <- getGHCiState
 382       dflags <- io getDynFlags
 383       let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
 384       (new_cmstate, result) <-
 385         io $ withProgName (progname st) $ withArgs (args st) $
 386         cmRunStmt (cmstate st) dflags' stmt
 387       setGHCiState st{cmstate = new_cmstate}
 388       case result of
 389         CmRunFailed      -> return []
 390         CmRunException e -> showException e >> return []
 391         CmRunOk names    -> return names
 392
 393 -- possibly print the type and revert CAFs after evaluating an expression
 394 finishEvalExpr names
 395  = do b <- isOptionSet ShowType
 396       cmstate <- getCmState
 397       when b (mapM_ (showTypeOfName cmstate) names)
 398
 399       flushInterpBuffers
 400       io installSignalHandlers
 401       b <- isOptionSet RevertCAFs
 402       io (when b revertCAFs)
 403       return True
 404
 405 showTypeOfName :: CmState -> Name -> GHCi ()
 406 showTypeOfName cmstate n
 407    = do maybe_str <- io (cmTypeOfName cmstate n)
 408         case maybe_str of
 409           Nothing  -> return ()
 410           Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
 411
 412 specialCommand :: String -> GHCi Bool
 413 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 414 specialCommand str = do
 415   let (cmd,rest) = break isSpace str
 416   cmds <- io (readIORef commands)
 417   case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
 418      []      -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
 419                                     ++ shortHelpText) >> return False)
 420      [(_,f)] -> f (dropWhile isSpace rest)
 421      cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++
 422                                       " matches multiple commands (" ++
 423                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
 424                                          ++ ")") >> return False)
 425
 426 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
 427
 428
 429 -----------------------------------------------------------------------------
 430 -- To flush buffers for the *interpreted* computation we need
 431 -- to refer to *its* stdout/stderr handles
 432
 433 GLOBAL_VAR(flush_interp,       error "no flush_interp", IO ())
 434 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
 435
 436 no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++
 437              " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
 438 flush_cmd  = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr"
 439
 440 initInterpBuffering :: CmState -> DynFlags -> IO CmState
 441 initInterpBuffering cmstate dflags
 442  = do (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags no_buf_cmd
 443
 444       case maybe_hval of
 445         Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
 446         other     -> panic "interactiveUI:setBuffering"
 447
 448       (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags flush_cmd
 449       case maybe_hval of
 450         Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
 451         _         -> panic "interactiveUI:flush"
 452
 453       turnOffBuffering  -- Turn it off right now
 454
 455       return cmstate
 456
 457
 458 flushInterpBuffers :: GHCi ()
 459 flushInterpBuffers
 460  = io $ do Monad.join (readIORef flush_interp)
 461            return ()
 462
 463 turnOffBuffering :: IO ()
 464 turnOffBuffering
 465  = do Monad.join (readIORef turn_off_buffering)
 466       return ()
 467
 468 -----------------------------------------------------------------------------
 469 -- Commands
 470
 471 help :: String -> GHCi ()
 472 help _ = io (putStr helpText)
 473
 474 info :: String -> GHCi ()
 475 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
 476 info s = do
 477   let names = words s
 478   init_cms <- getCmState
 479   dflags <- io getDynFlags
 480   let
 481     infoThings cms [] = return cms
 482     infoThings cms (name:names) = do
 483       (cms, stuff) <- io (cmInfoThing cms dflags name)
 484       io (putStrLn (showSDocForUser unqual (
 485             vcat (intersperse (text "") (map showThing stuff))))
 486          )
 487       infoThings cms names
 488
 489     unqual = cmGetPrintUnqual init_cms
 490
 491     showThing (ty_thing, fixity)
 492         = vcat [ text "-- " <> showTyThing ty_thing,
 493                  showFixity fixity (getName ty_thing),
 494                  ppr (ifaceTyThing ty_thing) ]
 495
 496     showFixity fix name
 497         | fix == defaultFixity = empty
 498         | otherwise            = ppr fix <+>
 499                                  (if isSymOcc (nameOccName name)
 500                                         then ppr name
 501                                         else char '`' <> ppr name <> char '`')
 502
 503     showTyThing (AClass cl)
 504        = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
 505     showTyThing (ADataCon dc)
 506        = hcat [ppr dc, text " is a data constructor", showSrcLoc (dataConName dc)]
 507     showTyThing (ATyCon ty)
 508        | isPrimTyCon ty
 509        = hcat [ppr ty, text " is a primitive type constructor"]
 510        | otherwise
 511        = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
 512     showTyThing (AnId   id)
 513        = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
 514
 515     idDescr id
 516        | isRecordSelector id =
 517                 case tyConClass_maybe (fieldLabelTyCon (
 518                                 recordSelectorFieldLabel id)) of
 519                         Nothing -> text "record selector"
 520                         Just c  -> text "method in class " <> ppr c
 521        | otherwise           = text "variable"
 522
 523         -- also print out the source location for home things
 524     showSrcLoc name
 525         | isHomePackageName name && isGoodSrcLoc loc
 526         = hsep [ text ", defined at", ppr loc ]
 527         | otherwise
 528         = empty
 529         where loc = nameSrcLoc name
 530
 531   cms <- infoThings init_cms names
 532   setCmState cms
 533   return ()
 534
 535 addModule :: [FilePath] -> GHCi ()
 536 addModule files = do
 537   state <- getGHCiState
 538   dflags <- io (getDynFlags)
 539   io (revertCAFs)                       -- always revert CAFs on load/add.
 540   let new_targets = files ++ targets state
 541   graph <- io (cmDepAnal (cmstate state) dflags new_targets)
 542   (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
 543   setGHCiState state{ cmstate = cmstate1, targets = new_targets }
 544   setContextAfterLoad mods
 545   modulesLoadedMsg ok mods dflags
 546
 547 changeDirectory :: String -> GHCi ()
 548 changeDirectory ('~':d) = do
 549    tilde <- io (getEnv "HOME")  -- will fail if HOME not defined
 550    io (setCurrentDirectory (tilde ++ '/':d))
 551 changeDirectory d = io (setCurrentDirectory d)
 552
 553 defineMacro :: String -> GHCi ()
 554 defineMacro s = do
 555   let (macro_name, definition) = break isSpace s
 556   cmds <- io (readIORef commands)
 557   if (null macro_name)
 558         then throwDyn (CmdLineError "invalid macro name")
 559         else do
 560   if (macro_name `elem` map fst cmds)
 561         then throwDyn (CmdLineError
 562                 ("command `" ++ macro_name ++ "' is already defined"))
 563         else do
 564
 565   -- give the expression a type signature, so we can be sure we're getting
 566   -- something of the right type.
 567   let new_expr = '(' : definition ++ ") :: String -> IO String"
 568
 569   -- compile the expression
 570   cms <- getCmState
 571   dflags <- io getDynFlags
 572   (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
 573   setCmState new_cmstate
 574   case maybe_hv of
 575      Nothing -> return ()
 576      Just hv -> io (writeIORef commands --
 577                     ((macro_name, keepGoing (runMacro hv)) : cmds))
 578
 579 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
 580 runMacro fun s = do
 581   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 582   stringLoop (lines str)
 583
 584 undefineMacro :: String -> GHCi ()
 585 undefineMacro macro_name = do
 586   cmds <- io (readIORef commands)
 587   if (macro_name `elem` map fst builtin_commands)
 588         then throwDyn (CmdLineError
 589                 ("command `" ++ macro_name ++ "' cannot be undefined"))
 590         else do
 591   if (macro_name `notElem` map fst cmds)
 592         then throwDyn (CmdLineError
 593                 ("command `" ++ macro_name ++ "' not defined"))
 594         else do
 595   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 596
 597
 598 loadModule :: [FilePath] -> GHCi ()
 599 loadModule fs = timeIt (loadModule' fs)
 600
 601 loadModule' :: [FilePath] -> GHCi ()
 602 loadModule' files = do
 603   state <- getGHCiState
 604   dflags <- io getDynFlags
 605
 606   -- do the dependency anal first, so that if it fails we don't throw
 607   -- away the current set of modules.
 608   graph <- io (cmDepAnal (cmstate state) dflags files)
 609
 610   -- Dependency anal ok, now unload everything
 611   cmstate1 <- io (cmUnload (cmstate state) dflags)
 612   setGHCiState state{ cmstate = cmstate1, targets = [] }
 613
 614   io (revertCAFs)  -- always revert CAFs on load.
 615   (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
 616   setGHCiState state{ cmstate = cmstate2, targets = files }
 617
 618   setContextAfterLoad mods
 619   modulesLoadedMsg ok mods dflags
 620
 621
 622 reloadModule :: String -> GHCi ()
 623 reloadModule "" = do
 624   state <- getGHCiState
 625   dflags <- io getDynFlags
 626   case targets state of
 627    [] -> io (putStr "no current target\n")
 628    paths -> do
 629         -- do the dependency anal first, so that if it fails we don't throw
 630         -- away the current set of modules.
 631         graph <- io (cmDepAnal (cmstate state) dflags paths)
 632
 633         io (revertCAFs)         -- always revert CAFs on reload.
 634         (cmstate1, ok, mods)
 635                 <- io (cmLoadModules (cmstate state) dflags graph)
 636         setGHCiState state{ cmstate=cmstate1 }
 637         setContextAfterLoad mods
 638         modulesLoadedMsg ok mods dflags
 639
 640 reloadModule _ = noArgs ":reload"
 641
 642 setContextAfterLoad [] = setContext prel
 643 setContextAfterLoad (m:_) = do
 644   cmstate <- getCmState
 645   b <- io (cmModuleIsInterpreted cmstate m)
 646   if b then setContext ('*':m) else setContext m
 647
 648 modulesLoadedMsg ok mods dflags =
 649   when (verbosity dflags > 0) $ do
 650    let mod_commas
 651         | null mods = text "none."
 652         | otherwise = hsep (
 653             punctuate comma (map text mods)) <> text "."
 654    case ok of
 655     Failed ->
 656        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 657     Succeeded  ->
 658        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 659
 660
 661 typeOfExpr :: String -> GHCi ()
 662 typeOfExpr str
 663   = do cms <- getCmState
 664        dflags <- io getDynFlags
 665        (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
 666        setCmState new_cmstate
 667        case maybe_tystr of
 668           Nothing    -> return ()
 669           Just tystr -> io (putStrLn tystr)
 670
 671 quit :: String -> GHCi Bool
 672 quit _ = return True
 673
 674 shellEscape :: String -> GHCi Bool
 675 shellEscape str = io (system str >> return False)
 676
 677 -----------------------------------------------------------------------------
 678 -- Browing a module's contents
 679
 680 browseCmd :: String -> GHCi ()
 681 browseCmd m =
 682   case words m of
 683     ['*':m] | looksLikeModuleName m -> browseModule m False
 684     [m]     | looksLikeModuleName m -> browseModule m True
 685     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 686
 687 browseModule m exports_only = do
 688   cms <- getCmState
 689   dflags <- io getDynFlags
 690
 691   is_interpreted <- io (cmModuleIsInterpreted cms m)
 692   when (not is_interpreted && not exports_only) $
 693         throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
 694
 695   -- temporarily set the context to the module we're interested in,
 696   -- just so we can get an appropriate PrintUnqualified
 697   (as,bs) <- io (cmGetContext cms)
 698   cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m]
 699                               else cmSetContext cms dflags [m] [])
 700   cms2 <- io (cmSetContext cms1 dflags as bs)
 701
 702   (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)
 703
 704   setCmState cms3
 705
 706   let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
 707
 708       things' = filter wantToSee things
 709
 710       wantToSee (AnId id)    = not (isImplicitId id)
 711       wantToSee (ADataCon _) = False    -- They'll come via their TyCon
 712       wantToSee _            = True
 713
 714       thing_names = map getName things
 715
 716       thingDecl thing@(AnId id)  = ifaceTyThing thing
 717
 718       thingDecl thing@(AClass c) =
 719         let rn_decl = ifaceTyThing thing in
 720         case rn_decl of
 721           ClassDecl { tcdSigs = cons } ->
 722                 rn_decl{ tcdSigs = filter methodIsVisible cons }
 723           other -> other
 724         where
 725            methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
 726
 727       thingDecl thing@(ATyCon t) =
 728         let rn_decl = ifaceTyThing thing in
 729         case rn_decl of
 730           TyData { tcdCons = DataCons cons } ->
 731                 rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
 732           other -> other
 733         where
 734           conIsVisible (ConDecl n _ _ _ _) = n `elem` thing_names
 735
 736   io (putStrLn (showSDocForUser unqual (
 737          vcat (map (ppr . thingDecl) things')))
 738    )
 739
 740   where
 741
 742 -----------------------------------------------------------------------------
 743 -- Setting the module context
 744
 745 setContext str
 746   | all sensible mods = fn mods
 747   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
 748   where
 749     (fn, mods) = case str of
 750                         '+':stuff -> (addToContext,      words stuff)
 751                         '-':stuff -> (removeFromContext, words stuff)
 752                         stuff     -> (newContext,        words stuff)
 753
 754     sensible ('*':m) = looksLikeModuleName m
 755     sensible m       = looksLikeModuleName m
 756
 757 newContext mods = do
 758   cms <- getCmState
 759   dflags <- io getDynFlags
 760   (as,bs) <- separate cms mods [] []
 761   let bs' = if null as && prel `notElem` bs then prel:bs else bs
 762   cms' <- io (cmSetContext cms dflags as bs')
 763   setCmState cms'
 764
 765 separate cmstate []           as bs = return (as,bs)
 766 separate cmstate (('*':m):ms) as bs = do
 767    b <- io (cmModuleIsInterpreted cmstate m)
 768    if b then separate cmstate ms (m:as) bs
 769         else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
 770 separate cmstate (m:ms)       as bs = separate cmstate ms as (m:bs)
 771
 772 prel = "Prelude"
 773
 774
 775 addToContext mods = do
 776   cms <- getCmState
 777   dflags <- io getDynFlags
 778   (as,bs) <- io (cmGetContext cms)
 779
 780   (as',bs') <- separate cms mods [] []
 781
 782   let as_to_add = as' \\ (as ++ bs)
 783       bs_to_add = bs' \\ (as ++ bs)
 784
 785   cms' <- io (cmSetContext cms dflags
 786                         (as ++ as_to_add) (bs ++ bs_to_add))
 787   setCmState cms'
 788
 789
 790 removeFromContext mods = do
 791   cms <- getCmState
 792   dflags <- io getDynFlags
 793   (as,bs) <- io (cmGetContext cms)
 794
 795   (as_to_remove,bs_to_remove) <- separate cms mods [] []
 796
 797   let as' = as \\ (as_to_remove ++ bs_to_remove)
 798       bs' = bs \\ (as_to_remove ++ bs_to_remove)
 799
 800   cms' <- io (cmSetContext cms dflags as' bs')
 801   setCmState cms'
 802
 803 ----------------------------------------------------------------------------
 804 -- Code for `:set'
 805
 806 -- set options in the interpreter.  Syntax is exactly the same as the
 807 -- ghc command line, except that certain options aren't available (-C,
 808 -- -E etc.)
 809 --
 810 -- This is pretty fragile: most options won't work as expected.  ToDo:
 811 -- figure out which ones & disallow them.
 812
 813 setCmd :: String -> GHCi ()
 814 setCmd ""
 815   = do st <- getGHCiState
 816        let opts = options st
 817        io $ putStrLn (showSDoc (
 818               text "options currently set: " <>
 819               if null opts
 820                    then text "none."
 821                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 822            ))
 823 setCmd str
 824   = case words str of
 825         ("args":args) -> setArgs args
 826         ("prog":prog) -> setProg prog
 827         wds -> setOptions wds
 828
 829 setArgs args = do
 830   st <- getGHCiState
 831   setGHCiState st{ args = args }
 832
 833 setProg [prog] = do
 834   st <- getGHCiState
 835   setGHCiState st{ progname = prog }
 836 setProg _ = do
 837   io (hPutStrLn stderr "syntax: :set prog <progname>")
 838
 839 setOptions wds =
 840    do -- first, deal with the GHCi opts (+s, +t, etc.)
 841       let (plus_opts, minus_opts)  = partition isPlus wds
 842       mapM_ setOpt plus_opts
 843
 844       -- now, the GHC flags
 845       pkgs_before <- io (readIORef v_ExplicitPackages)
 846       leftovers   <- io (processArgs static_flags minus_opts [])
 847       pkgs_after  <- io (readIORef v_ExplicitPackages)
 848
 849       -- update things if the users wants more packages
 850       let new_packages = pkgs_after \\ pkgs_before
 851       when (not (null new_packages)) $
 852          newPackages new_packages
 853
 854       -- don't forget about the extra command-line flags from the
 855       -- extra_ghc_opts fields in the new packages
 856       new_package_details <- io (getPackageDetails new_packages)
 857       let pkg_extra_opts = concatMap extra_ghc_opts new_package_details
 858       pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts [])
 859
 860       -- then, dynamic flags
 861       io $ do
 862         restoreDynFlags
 863         leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) []
 864         saveDynFlags
 865
 866         if (not (null leftovers))
 867                 then throwDyn (CmdLineError ("unrecognised flags: " ++
 868                                                 unwords leftovers))
 869                 else return ()
 870
 871
 872 unsetOptions :: String -> GHCi ()
 873 unsetOptions str
 874   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 875        let opts = words str
 876            (minus_opts, rest1) = partition isMinus opts
 877            (plus_opts, rest2)  = partition isPlus rest1
 878
 879        if (not (null rest2))
 880           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 881           else do
 882
 883        mapM_ unsetOpt plus_opts
 884
 885        -- can't do GHC flags for now
 886        if (not (null minus_opts))
 887           then throwDyn (CmdLineError "can't unset GHC command-line flags")
 888           else return ()
 889
 890 isMinus ('-':s) = True
 891 isMinus _ = False
 892
 893 isPlus ('+':s) = True
 894 isPlus _ = False
 895
 896 setOpt ('+':str)
 897   = case strToGHCiOpt str of
 898         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 899         Just o  -> setOption o
 900
 901 unsetOpt ('+':str)
 902   = case strToGHCiOpt str of
 903         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 904         Just o  -> unsetOption o
 905
 906 strToGHCiOpt :: String -> (Maybe GHCiOption)
 907 strToGHCiOpt "s" = Just ShowTiming
 908 strToGHCiOpt "t" = Just ShowType
 909 strToGHCiOpt "r" = Just RevertCAFs
 910 strToGHCiOpt _   = Nothing
 911
 912 optToStr :: GHCiOption -> String
 913 optToStr ShowTiming = "s"
 914 optToStr ShowType   = "t"
 915 optToStr RevertCAFs = "r"
 916
 917 newPackages new_pkgs = do       -- The new packages are already in v_Packages
 918   state    <- getGHCiState
 919   dflags   <- io getDynFlags
 920   cmstate1 <- io (cmUnload (cmstate state) dflags)
 921   setGHCiState state{ cmstate = cmstate1, targets = [] }
 922   io (linkPackages dflags new_pkgs)
 923   setContextAfterLoad []
 924
 925 -- ---------------------------------------------------------------------------
 926 -- code for `:show'
 927
 928 showCmd str =
 929   case words str of
 930         ["modules" ] -> showModules
 931         ["bindings"] -> showBindings
 932         ["linker"]   -> io showLinkerState
 933         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
 934
 935 showModules = do
 936   cms <- getCmState
 937   let (mg, hpt) = cmGetModInfo cms
 938   mapM_ (showModule hpt) mg
 939
 940
 941 showModule :: HomePackageTable -> ModSummary -> GHCi ()
 942 showModule hpt mod_summary
 943   = case lookupModuleEnv hpt mod of
 944         Nothing       -> panic "missing linkable"
 945         Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
 946                       where
 947                          obj_linkable = isObjectLinkable (hm_linkable mod_info)
 948   where
 949     mod = ms_mod mod_summary
 950     locn = ms_location mod_summary
 951
 952 showBindings = do
 953   cms <- getCmState
 954   let
 955         unqual = cmGetPrintUnqual cms
 956         showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
 957
 958   io (mapM_ showBinding (cmGetBindings cms))
 959   return ()
 960
 961
 962 -----------------------------------------------------------------------------
 963 -- GHCi monad
 964
 965 data GHCiState = GHCiState
 966      {
 967         progname       :: String,
 968         args           :: [String],
 969         targets        :: [FilePath],
 970         cmstate        :: CmState,
 971         options        :: [GHCiOption]
 972      }
 973
 974 data GHCiOption
 975         = ShowTiming            -- show time/allocs after evaluation
 976         | ShowType              -- show the type of expressions
 977         | RevertCAFs            -- revert CAFs after every evaluation
 978         deriving Eq
 979
 980 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
 981
 982 startGHCi :: GHCi a -> GHCiState -> IO a
 983 startGHCi g state = do ref <- newIORef state; unGHCi g ref
 984
 985 instance Monad GHCi where
 986   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
 987   return a  = GHCi $ \s -> return a
 988
 989 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
 990 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 991    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 992
 993 getGHCiState   = GHCi $ \r -> readIORef r
 994 setGHCiState s = GHCi $ \r -> writeIORef r s
 995
 996 -- for convenience...
 997 getCmState = getGHCiState >>= return . cmstate
 998 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
 999
1000 isOptionSet :: GHCiOption -> GHCi Bool
1001 isOptionSet opt
1002  = do st <- getGHCiState
1003       return (opt `elem` options st)
1004
1005 setOption :: GHCiOption -> GHCi ()
1006 setOption opt
1007  = do st <- getGHCiState
1008       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1009
1010 unsetOption :: GHCiOption -> GHCi ()
1011 unsetOption opt
1012  = do st <- getGHCiState
1013       setGHCiState (st{ options = filter (/= opt) (options st) })
1014
1015 io :: IO a -> GHCi a
1016 io m = GHCi { unGHCi = \s -> m >>= return }
1017
1018 -----------------------------------------------------------------------------
1019 -- recursive exception handlers
1020
1021 -- Don't forget to unblock async exceptions in the handler, or if we're
1022 -- in an exception loop (eg. let a = error a in a) the ^C exception
1023 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1024
1025 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1026 ghciHandle h (GHCi m) = GHCi $ \s ->
1027    Exception.catch (m s)
1028         (\e -> unGHCi (ghciUnblock (h e)) s)
1029
1030 ghciUnblock :: GHCi a -> GHCi a
1031 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1032
1033 -----------------------------------------------------------------------------
1034 -- timing & statistics
1035
1036 timeIt :: GHCi a -> GHCi a
1037 timeIt action
1038   = do b <- isOptionSet ShowTiming
1039        if not b
1040           then action
1041           else do allocs1 <- io $ getAllocations
1042                   time1   <- io $ getCPUTime
1043                   a <- action
1044                   allocs2 <- io $ getAllocations
1045                   time2   <- io $ getCPUTime
1046                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
1047                   return a
1048
1049 foreign import ccall "getAllocations" getAllocations :: IO Int
1050
1051 printTimes :: Int -> Integer -> IO ()
1052 printTimes allocs psecs
1053    = do let secs = (fromIntegral psecs / (10^12)) :: Float
1054             secs_str = showFFloat (Just 2) secs
1055         putStrLn (showSDoc (
1056                  parens (text (secs_str "") <+> text "secs" <> comma <+>
1057                          int allocs <+> text "bytes")))
1058
1059 -----------------------------------------------------------------------------
1060 -- reverting CAFs
1061
1062 revertCAFs :: IO ()
1063 revertCAFs = do
1064   rts_revertCAFs
1065   turnOffBuffering
1066         -- Have to turn off buffering again, because we just
1067         -- reverted stdout, stderr & stdin to their defaults.
1068
1069 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
1070         -- Make it "safe", just in case