ghc/compiler/ghci/InteractiveUI.hs

   1 {-# OPTIONS -#include "Linker.h" #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: InteractiveUI.hs,v 1.159 2003/09/04 11:08:46 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 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 thing
 727
 728       thingDecl thing@(AClass c) =
 729         let rn_decl = ifaceTyThing 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 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   where
 751
 752 -----------------------------------------------------------------------------
 753 -- Setting the module context
 754
 755 setContext str
 756   | all sensible mods = fn mods
 757   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
 758   where
 759     (fn, mods) = case str of
 760                         '+':stuff -> (addToContext,      words stuff)
 761                         '-':stuff -> (removeFromContext, words stuff)
 762                         stuff     -> (newContext,        words stuff)
 763
 764     sensible ('*':m) = looksLikeModuleName m
 765     sensible m       = looksLikeModuleName m
 766
 767 newContext mods = do
 768   cms <- getCmState
 769   dflags <- io getDynFlags
 770   (as,bs) <- separate cms mods [] []
 771   let bs' = if null as && prel `notElem` bs then prel:bs else bs
 772   cms' <- io (cmSetContext cms dflags as bs')
 773   setCmState cms'
 774
 775 separate cmstate []           as bs = return (as,bs)
 776 separate cmstate (('*':m):ms) as bs = do
 777    b <- io (cmModuleIsInterpreted cmstate m)
 778    if b then separate cmstate ms (m:as) bs
 779         else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
 780 separate cmstate (m:ms)       as bs = separate cmstate ms as (m:bs)
 781
 782 prel = "Prelude"
 783
 784
 785 addToContext mods = do
 786   cms <- getCmState
 787   dflags <- io getDynFlags
 788   (as,bs) <- io (cmGetContext cms)
 789
 790   (as',bs') <- separate cms mods [] []
 791
 792   let as_to_add = as' \\ (as ++ bs)
 793       bs_to_add = bs' \\ (as ++ bs)
 794
 795   cms' <- io (cmSetContext cms dflags
 796                         (as ++ as_to_add) (bs ++ bs_to_add))
 797   setCmState cms'
 798
 799
 800 removeFromContext mods = do
 801   cms <- getCmState
 802   dflags <- io getDynFlags
 803   (as,bs) <- io (cmGetContext cms)
 804
 805   (as_to_remove,bs_to_remove) <- separate cms mods [] []
 806
 807   let as' = as \\ (as_to_remove ++ bs_to_remove)
 808       bs' = bs \\ (as_to_remove ++ bs_to_remove)
 809
 810   cms' <- io (cmSetContext cms dflags as' bs')
 811   setCmState cms'
 812
 813 ----------------------------------------------------------------------------
 814 -- Code for `:set'
 815
 816 -- set options in the interpreter.  Syntax is exactly the same as the
 817 -- ghc command line, except that certain options aren't available (-C,
 818 -- -E etc.)
 819 --
 820 -- This is pretty fragile: most options won't work as expected.  ToDo:
 821 -- figure out which ones & disallow them.
 822
 823 setCmd :: String -> GHCi ()
 824 setCmd ""
 825   = do st <- getGHCiState
 826        let opts = options st
 827        io $ putStrLn (showSDoc (
 828               text "options currently set: " <>
 829               if null opts
 830                    then text "none."
 831                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 832            ))
 833 setCmd str
 834   = case words str of
 835         ("args":args) -> setArgs args
 836         ("prog":prog) -> setProg prog
 837         wds -> setOptions wds
 838
 839 setArgs args = do
 840   st <- getGHCiState
 841   setGHCiState st{ args = args }
 842
 843 setProg [prog] = do
 844   st <- getGHCiState
 845   setGHCiState st{ progname = prog }
 846 setProg _ = do
 847   io (hPutStrLn stderr "syntax: :set prog <progname>")
 848
 849 setOptions wds =
 850    do -- first, deal with the GHCi opts (+s, +t, etc.)
 851       let (plus_opts, minus_opts)  = partition isPlus wds
 852       mapM_ setOpt plus_opts
 853
 854       -- now, the GHC flags
 855       pkgs_before <- io (readIORef v_ExplicitPackages)
 856       leftovers   <- io (processArgs static_flags minus_opts [])
 857       pkgs_after  <- io (readIORef v_ExplicitPackages)
 858
 859       -- update things if the users wants more packages
 860       let new_packages = pkgs_after \\ pkgs_before
 861       when (not (null new_packages)) $
 862          newPackages new_packages
 863
 864       -- don't forget about the extra command-line flags from the
 865       -- extra_ghc_opts fields in the new packages
 866       new_package_details <- io (getPackageDetails new_packages)
 867       let pkg_extra_opts = concatMap extra_ghc_opts new_package_details
 868       pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts [])
 869
 870       -- then, dynamic flags
 871       io $ do
 872         restoreDynFlags
 873         leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) []
 874         saveDynFlags
 875
 876         if (not (null leftovers))
 877                 then throwDyn (CmdLineError ("unrecognised flags: " ++
 878                                                 unwords leftovers))
 879                 else return ()
 880
 881
 882 unsetOptions :: String -> GHCi ()
 883 unsetOptions str
 884   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 885        let opts = words str
 886            (minus_opts, rest1) = partition isMinus opts
 887            (plus_opts, rest2)  = partition isPlus rest1
 888
 889        if (not (null rest2))
 890           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 891           else do
 892
 893        mapM_ unsetOpt plus_opts
 894
 895        -- can't do GHC flags for now
 896        if (not (null minus_opts))
 897           then throwDyn (CmdLineError "can't unset GHC command-line flags")
 898           else return ()
 899
 900 isMinus ('-':s) = True
 901 isMinus _ = False
 902
 903 isPlus ('+':s) = True
 904 isPlus _ = False
 905
 906 setOpt ('+':str)
 907   = case strToGHCiOpt str of
 908         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 909         Just o  -> setOption o
 910
 911 unsetOpt ('+':str)
 912   = case strToGHCiOpt str of
 913         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 914         Just o  -> unsetOption o
 915
 916 strToGHCiOpt :: String -> (Maybe GHCiOption)
 917 strToGHCiOpt "s" = Just ShowTiming
 918 strToGHCiOpt "t" = Just ShowType
 919 strToGHCiOpt "r" = Just RevertCAFs
 920 strToGHCiOpt _   = Nothing
 921
 922 optToStr :: GHCiOption -> String
 923 optToStr ShowTiming = "s"
 924 optToStr ShowType   = "t"
 925 optToStr RevertCAFs = "r"
 926
 927 newPackages new_pkgs = do       -- The new packages are already in v_Packages
 928   state    <- getGHCiState
 929   dflags   <- io getDynFlags
 930   cmstate1 <- io (cmUnload (cmstate state) dflags)
 931   setGHCiState state{ cmstate = cmstate1, targets = [] }
 932   io (linkPackages dflags new_pkgs)
 933   setContextAfterLoad []
 934
 935 -- ---------------------------------------------------------------------------
 936 -- code for `:show'
 937
 938 showCmd str =
 939   case words str of
 940         ["modules" ] -> showModules
 941         ["bindings"] -> showBindings
 942         ["linker"]   -> io showLinkerState
 943         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
 944
 945 showModules = do
 946   cms <- getCmState
 947   let (mg, hpt) = cmGetModInfo cms
 948   mapM_ (showModule hpt) mg
 949
 950
 951 showModule :: HomePackageTable -> ModSummary -> GHCi ()
 952 showModule hpt mod_summary
 953   = case lookupModuleEnv hpt mod of
 954         Nothing       -> panic "missing linkable"
 955         Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
 956                       where
 957                          obj_linkable = isObjectLinkable (hm_linkable mod_info)
 958   where
 959     mod = ms_mod mod_summary
 960     locn = ms_location mod_summary
 961
 962 showBindings = do
 963   cms <- getCmState
 964   let
 965         unqual = cmGetPrintUnqual cms
 966         showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
 967
 968   io (mapM_ showBinding (cmGetBindings cms))
 969   return ()
 970
 971
 972 -----------------------------------------------------------------------------
 973 -- GHCi monad
 974
 975 data GHCiState = GHCiState
 976      {
 977         progname       :: String,
 978         args           :: [String],
 979         targets        :: [FilePath],
 980         cmstate        :: CmState,
 981         options        :: [GHCiOption]
 982      }
 983
 984 data GHCiOption
 985         = ShowTiming            -- show time/allocs after evaluation
 986         | ShowType              -- show the type of expressions
 987         | RevertCAFs            -- revert CAFs after every evaluation
 988         deriving Eq
 989
 990 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
 991
 992 startGHCi :: GHCi a -> GHCiState -> IO a
 993 startGHCi g state = do ref <- newIORef state; unGHCi g ref
 994
 995 instance Monad GHCi where
 996   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
 997   return a  = GHCi $ \s -> return a
 998
 999 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1000 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1001    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1002
1003 getGHCiState   = GHCi $ \r -> readIORef r
1004 setGHCiState s = GHCi $ \r -> writeIORef r s
1005
1006 -- for convenience...
1007 getCmState = getGHCiState >>= return . cmstate
1008 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
1009
1010 isOptionSet :: GHCiOption -> GHCi Bool
1011 isOptionSet opt
1012  = do st <- getGHCiState
1013       return (opt `elem` options st)
1014
1015 setOption :: GHCiOption -> GHCi ()
1016 setOption opt
1017  = do st <- getGHCiState
1018       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1019
1020 unsetOption :: GHCiOption -> GHCi ()
1021 unsetOption opt
1022  = do st <- getGHCiState
1023       setGHCiState (st{ options = filter (/= opt) (options st) })
1024
1025 io :: IO a -> GHCi a
1026 io m = GHCi { unGHCi = \s -> m >>= return }
1027
1028 -----------------------------------------------------------------------------
1029 -- recursive exception handlers
1030
1031 -- Don't forget to unblock async exceptions in the handler, or if we're
1032 -- in an exception loop (eg. let a = error a in a) the ^C exception
1033 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1034
1035 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1036 ghciHandle h (GHCi m) = GHCi $ \s ->
1037    Exception.catch (m s)
1038         (\e -> unGHCi (ghciUnblock (h e)) s)
1039
1040 ghciUnblock :: GHCi a -> GHCi a
1041 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1042
1043 -----------------------------------------------------------------------------
1044 -- timing & statistics
1045
1046 timeIt :: GHCi a -> GHCi a
1047 timeIt action
1048   = do b <- isOptionSet ShowTiming
1049        if not b
1050           then action
1051           else do allocs1 <- io $ getAllocations
1052                   time1   <- io $ getCPUTime
1053                   a <- action
1054                   allocs2 <- io $ getAllocations
1055                   time2   <- io $ getCPUTime
1056                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
1057                   return a
1058
1059 foreign import ccall "getAllocations" getAllocations :: IO Int
1060
1061 printTimes :: Int -> Integer -> IO ()
1062 printTimes allocs psecs
1063    = do let secs = (fromIntegral psecs / (10^12)) :: Float
1064             secs_str = showFFloat (Just 2) secs
1065         putStrLn (showSDoc (
1066                  parens (text (secs_str "") <+> text "secs" <> comma <+>
1067                          int allocs <+> text "bytes")))
1068
1069 -----------------------------------------------------------------------------
1070 -- reverting CAFs
1071
1072 revertCAFs :: IO ()
1073 revertCAFs = do
1074   rts_revertCAFs
1075   turnOffBuffering
1076         -- Have to turn off buffering again, because we just
1077         -- reverted stdout, stderr & stdin to their defaults.
1078
1079 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
1080         -- Make it "safe", just in case
1081
1082 -- -----------------------------------------------------------------------------
1083 -- Utils
1084
1085 expandPath :: String -> GHCi String
1086 expandPath path =
1087   case dropWhile isSpace path of
1088    ('~':d) -> do
1089         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1090         return (tilde ++ '/':d)
1091    other ->
1092         return other