ghc/compiler/ghci/InteractiveUI.hs

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