ghc/compiler/ghci/InteractiveUI.hs

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