ghc/compiler/ghci/InteractiveUI.hs

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