ghc/compiler/ghci/InteractiveUI.hs

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