ghc/compiler/ghci/InteractiveUI.hs

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