ghc/compiler/ghci/InteractiveUI.hs

   1 {-# OPTIONS -#include "Linker.h" #-}
   2 -----------------------------------------------------------------------------
   3 --
   4 -- GHC Interactive User Interface
   5 --
   6 -- (c) The GHC Team 2005
   7 --
   8 -----------------------------------------------------------------------------
   9 module InteractiveUI (
  10         interactiveUI,
  11         ghciWelcomeMsg
  12    ) where
  13
  14 #include "HsVersions.h"
  15
  16 -- The GHC interface
  17 import qualified GHC
  18 import GHC              ( Session, verbosity, dopt, DynFlag(..), Target(..),
  19                           TargetId(..),
  20                           mkModule, pprModule, Type, Module, SuccessFlag(..),
  21                           TyThing(..), Name, LoadHowMuch(..), Phase,
  22                           GhcException(..), showGhcException,
  23                           CheckedModule(..), SrcLoc )
  24 import PprTyThing
  25 import Outputable
  26
  27 -- for createtags (should these come via GHC?)
  28 import Module           ( moduleString )
  29 import Name             ( nameSrcLoc, nameModule, nameOccName )
  30 import OccName          ( pprOccName )
  31 import SrcLoc           ( isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol )
  32
  33 -- Other random utilities
  34 import Digraph          ( flattenSCCs )
  35 import BasicTypes       ( failed, successIf )
  36 import Panic            ( panic, installSignalHandlers )
  37 import Config
  38 import StaticFlags      ( opt_IgnoreDotGhci )
  39 import Linker           ( showLinkerState )
  40 import Util             ( removeSpaces, handle, global, toArgs,
  41                           looksLikeModuleName, prefixMatch, sortLe )
  42
  43 #ifndef mingw32_HOST_OS
  44 import System.Posix
  45 #if __GLASGOW_HASKELL__ > 504
  46         hiding (getEnv)
  47 #endif
  48 #else
  49 import GHC.ConsoleHandler ( flushConsole )
  50 #endif
  51
  52 #ifdef USE_READLINE
  53 import Control.Concurrent       ( yield )       -- Used in readline loop
  54 import System.Console.Readline as Readline
  55 #endif
  56
  57 --import SystemExts
  58
  59 import Control.Exception as Exception
  60 import Data.Dynamic
  61 -- import Control.Concurrent
  62
  63 import Numeric
  64 import Data.List
  65 import Data.Int         ( Int64 )
  66 import Data.Maybe       ( isJust, fromMaybe, catMaybes )
  67 import System.Cmd
  68 import System.CPUTime
  69 import System.Environment
  70 import System.Exit      ( exitWith, ExitCode(..) )
  71 import System.Directory
  72 import System.IO
  73 import System.IO.Error as IO
  74 import Data.Char
  75 import Control.Monad as Monad
  76 import Foreign.StablePtr        ( newStablePtr )
  77
  78 import GHC.Exts         ( unsafeCoerce# )
  79 import GHC.IOBase       ( IOErrorType(InvalidArgument) )
  80
  81 import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )
  82
  83 import System.Posix.Internals ( setNonBlockingFD )
  84
  85 -----------------------------------------------------------------------------
  86
  87 ghciWelcomeMsg =
  88  "   ___         ___ _\n"++
  89  "  / _ \\ /\\  /\\/ __(_)\n"++
  90  " / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
  91  "/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n"++
  92  "\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
  93
  94 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
  95
  96 builtin_commands :: [(String, String -> GHCi Bool)]
  97 builtin_commands = [
  98   ("add",       keepGoingPaths addModule),
  99   ("browse",    keepGoing browseCmd),
 100   ("cd",        keepGoing changeDirectory),
 101   ("def",       keepGoing defineMacro),
 102   ("help",      keepGoing help),
 103   ("?",         keepGoing help),
 104   ("info",      keepGoing info),
 105   ("load",      keepGoingPaths loadModule_),
 106   ("module",    keepGoing setContext),
 107   ("reload",    keepGoing reloadModule),
 108   ("check",     keepGoing checkModule),
 109   ("set",       keepGoing setCmd),
 110   ("show",      keepGoing showCmd),
 111   ("etags",     keepGoing createETagsFileCmd),
 112   ("ctags",     keepGoing createCTagsFileCmd),
 113   ("type",      keepGoing typeOfExpr),
 114   ("kind",      keepGoing kindOfType),
 115   ("unset",     keepGoing unsetOptions),
 116   ("undef",     keepGoing undefineMacro),
 117   ("quit",      quit)
 118   ]
 119
 120 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 121 keepGoing a str = a str >> return False
 122
 123 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
 124 keepGoingPaths a str = a (toArgs str) >> return False
 125
 126 shortHelpText = "use :? for help.\n"
 127
 128 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
 129 helpText =
 130  " Commands available from the prompt:\n" ++
 131  "\n" ++
 132  "   <stmt>                      evaluate/run <stmt>\n" ++
 133  "   :add <filename> ...         add module(s) to the current target set\n" ++
 134  "   :browse [*]<module>         display the names defined by <module>\n" ++
 135  "   :cd <dir>                   change directory to <dir>\n" ++
 136  "   :def <cmd> <expr>           define a command :<cmd>\n" ++
 137  "   :help, :?                   display this list of commands\n" ++
 138  "   :info [<name> ...]          display information about the given names\n" ++
 139  "   :load <filename> ...        load module(s) and their dependents\n" ++
 140  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
 141  "   :reload                     reload the current module set\n" ++
 142  "\n" ++
 143  "   :set <option> ...           set options\n" ++
 144  "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
 145  "   :set prog <progname>        set the value returned by System.getProgName\n" ++
 146  "\n" ++
 147  "   :show modules               show the currently loaded modules\n" ++
 148  "   :show bindings              show the current bindings made at the prompt\n" ++
 149  "\n" ++
 150  "   :ctags [<file>]             create tags file for Vi (default: \"tags\")\n" ++
 151  "   :etags [<file>]             create tags file for Emacs (defauilt: \"TAGS\")\n" ++
 152  "   :type <expr>                show the type of <expr>\n" ++
 153  "   :kind <type>                show the kind of <type>\n" ++
 154  "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
 155  "   :unset <option> ...         unset options\n" ++
 156  "   :quit                       exit GHCi\n" ++
 157  "   :!<command>                 run the shell command <command>\n" ++
 158  "\n" ++
 159  " Options for ':set' and ':unset':\n" ++
 160  "\n" ++
 161  "    +r            revert top-level expressions after each evaluation\n" ++
 162  "    +s            print timing/memory stats after each evaluation\n" ++
 163  "    +t            print type after evaluation\n" ++
 164  "    -<flags>      most GHC command line flags can also be set here\n" ++
 165  "                         (eg. -v2, -fglasgow-exts, etc.)\n"
 166
 167
 168 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
 169 interactiveUI session srcs maybe_expr = do
 170
 171    -- HACK! If we happen to get into an infinite loop (eg the user
 172    -- types 'let x=x in x' at the prompt), then the thread will block
 173    -- on a blackhole, and become unreachable during GC.  The GC will
 174    -- detect that it is unreachable and send it the NonTermination
 175    -- exception.  However, since the thread is unreachable, everything
 176    -- it refers to might be finalized, including the standard Handles.
 177    -- This sounds like a bug, but we don't have a good solution right
 178    -- now.
 179    newStablePtr stdin
 180    newStablePtr stdout
 181    newStablePtr stderr
 182
 183    hFlush stdout
 184    hSetBuffering stdout NoBuffering
 185
 186         -- Initialise buffering for the *interpreted* I/O system
 187    initInterpBuffering session
 188
 189         -- We don't want the cmd line to buffer any input that might be
 190         -- intended for the program, so unbuffer stdin.
 191    hSetBuffering stdin NoBuffering
 192
 193         -- initial context is just the Prelude
 194    GHC.setContext session [] [prelude_mod]
 195
 196 #ifdef USE_READLINE
 197    Readline.initialize
 198 #endif
 199
 200    startGHCi (runGHCi srcs maybe_expr)
 201         GHCiState{ progname = "<interactive>",
 202                    args = [],
 203                    session = session,
 204                    options = [] }
 205
 206 #ifdef USE_READLINE
 207    Readline.resetTerminal Nothing
 208 #endif
 209
 210    return ()
 211
 212 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
 213 runGHCi paths maybe_expr = do
 214   let read_dot_files = not opt_IgnoreDotGhci
 215
 216   when (read_dot_files) $ do
 217     -- Read in ./.ghci.
 218     let file = "./.ghci"
 219     exists <- io (doesFileExist file)
 220     when exists $ do
 221        dir_ok  <- io (checkPerms ".")
 222        file_ok <- io (checkPerms file)
 223        when (dir_ok && file_ok) $ do
 224           either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
 225           case either_hdl of
 226              Left e    -> return ()
 227              Right hdl -> fileLoop hdl False
 228
 229   when (read_dot_files) $ do
 230     -- Read in $HOME/.ghci
 231     either_dir <- io (IO.try (getEnv "HOME"))
 232     case either_dir of
 233        Left e -> return ()
 234        Right dir -> do
 235           cwd <- io (getCurrentDirectory)
 236           when (dir /= cwd) $ do
 237              let file = dir ++ "/.ghci"
 238              ok <- io (checkPerms file)
 239              when ok $ do
 240                either_hdl <- io (IO.try (openFile file ReadMode))
 241                case either_hdl of
 242                   Left e    -> return ()
 243                   Right hdl -> fileLoop hdl False
 244
 245   -- Perform a :load for files given on the GHCi command line
 246   -- When in -e mode, if the load fails then we want to stop
 247   -- immediately rather than going on to evaluate the expression.
 248   when (not (null paths)) $ do
 249      ok <- ghciHandle (\e -> do showException e; return Failed) $
 250                 loadModule paths
 251      when (isJust maybe_expr && failed ok) $
 252         io (exitWith (ExitFailure 1))
 253
 254   -- if verbosity is greater than 0, or we are connected to a
 255   -- terminal, display the prompt in the interactive loop.
 256   is_tty <- io (hIsTerminalDevice stdin)
 257   dflags <- getDynFlags
 258   let show_prompt = verbosity dflags > 0 || is_tty
 259
 260   case maybe_expr of
 261         Nothing ->
 262 #if defined(mingw32_HOST_OS)
 263           do
 264             -- The win32 Console API mutates the first character of
 265             -- type-ahead when reading from it in a non-buffered manner. Work
 266             -- around this by flushing the input buffer of type-ahead characters,
 267             -- but only if stdin is available.
 268             flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
 269             case flushed of
 270              Left err | isDoesNotExistError err -> return ()
 271                       | otherwise -> io (ioError err)
 272              Right () -> return ()
 273 #endif
 274             -- enter the interactive loop
 275             interactiveLoop is_tty show_prompt
 276         Just expr -> do
 277             -- just evaluate the expression we were given
 278             runCommandEval expr
 279             return ()
 280
 281   -- and finally, exit
 282   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
 283
 284
 285 interactiveLoop is_tty show_prompt =
 286   -- Ignore ^C exceptions caught here
 287   ghciHandleDyn (\e -> case e of
 288                         Interrupted -> do
 289 #if defined(mingw32_HOST_OS)
 290                                 io (putStrLn "")
 291 #endif
 292                                 interactiveLoop is_tty show_prompt
 293                         _other      -> return ()) $
 294
 295   ghciUnblock $ do -- unblock necessary if we recursed from the
 296                    -- exception handler above.
 297
 298   -- read commands from stdin
 299 #ifdef USE_READLINE
 300   if (is_tty)
 301         then readlineLoop
 302         else fileLoop stdin show_prompt
 303 #else
 304   fileLoop stdin show_prompt
 305 #endif
 306
 307
 308 -- NOTE: We only read .ghci files if they are owned by the current user,
 309 -- and aren't world writable.  Otherwise, we could be accidentally
 310 -- running code planted by a malicious third party.
 311
 312 -- Furthermore, We only read ./.ghci if . is owned by the current user
 313 -- and isn't writable by anyone else.  I think this is sufficient: we
 314 -- don't need to check .. and ../.. etc. because "."  always refers to
 315 -- the same directory while a process is running.
 316
 317 checkPerms :: String -> IO Bool
 318 checkPerms name =
 319 #ifdef mingw32_HOST_OS
 320   return True
 321 #else
 322   Util.handle (\_ -> return False) $ do
 323      st <- getFileStatus name
 324      me <- getRealUserID
 325      if fileOwner st /= me then do
 326         putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
 327         return False
 328       else do
 329         let mode =  fileMode st
 330         if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
 331            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
 332            then do
 333                putStrLn $ "*** WARNING: " ++ name ++
 334                           " is writable by someone else, IGNORING!"
 335                return False
 336           else return True
 337 #endif
 338
 339 fileLoop :: Handle -> Bool -> GHCi ()
 340 fileLoop hdl prompt = do
 341    session <- getSession
 342    (mod,imports) <- io (GHC.getContext session)
 343    when prompt (io (putStr (mkPrompt mod imports)))
 344    l <- io (IO.try (hGetLine hdl))
 345    case l of
 346         Left e | isEOFError e              -> return ()
 347                | InvalidArgument <- etype  -> return ()
 348                | otherwise                 -> io (ioError e)
 349                 where etype = ioeGetErrorType e
 350                 -- treat InvalidArgument in the same way as EOF:
 351                 -- this can happen if the user closed stdin, or
 352                 -- perhaps did getContents which closes stdin at
 353                 -- EOF.
 354         Right l ->
 355           case removeSpaces l of
 356             "" -> fileLoop hdl prompt
 357             l  -> do quit <- runCommand l
 358                      if quit then return () else fileLoop hdl prompt
 359
 360 stringLoop :: [String] -> GHCi ()
 361 stringLoop [] = return ()
 362 stringLoop (s:ss) = do
 363    case removeSpaces s of
 364         "" -> stringLoop ss
 365         l  -> do quit <- runCommand l
 366                  if quit then return () else stringLoop ss
 367
 368 mkPrompt toplevs exports
 369   = showSDoc (hsep (map (\m -> char '*' <> pprModule m) toplevs)
 370              <+> hsep (map pprModule exports)
 371              <> text "> ")
 372
 373 #ifdef USE_READLINE
 374 readlineLoop :: GHCi ()
 375 readlineLoop = do
 376    session <- getSession
 377    (mod,imports) <- io (GHC.getContext session)
 378    io yield
 379    l <- io (readline (mkPrompt mod imports)
 380                 `finally` setNonBlockingFD 0)
 381                 -- readline sometimes puts stdin into blocking mode,
 382                 -- so we need to put it back for the IO library
 383    case l of
 384         Nothing -> return ()
 385         Just l  ->
 386           case removeSpaces l of
 387             "" -> readlineLoop
 388             l  -> do
 389                   io (addHistory l)
 390                   quit <- runCommand l
 391                   if quit then return () else readlineLoop
 392 #endif
 393
 394 runCommand :: String -> GHCi Bool
 395 runCommand c = ghciHandle handler (doCommand c)
 396   where
 397     doCommand (':' : command) = specialCommand command
 398     doCommand stmt
 399        = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
 400             return False
 401
 402 -- This version is for the GHC command-line option -e.  The only difference
 403 -- from runCommand is that it catches the ExitException exception and
 404 -- exits, rather than printing out the exception.
 405 runCommandEval c = ghciHandle handleEval (doCommand c)
 406   where
 407     handleEval (ExitException code) = io (exitWith code)
 408     handleEval e                    = do showException e
 409                                          io (exitWith (ExitFailure 1))
 410
 411     doCommand (':' : command) = specialCommand command
 412     doCommand stmt
 413        = do nms <- runStmt stmt
 414             case nms of
 415                 Nothing -> io (exitWith (ExitFailure 1))
 416                   -- failure to run the command causes exit(1) for ghc -e.
 417                 _       -> finishEvalExpr nms
 418
 419 -- This is the exception handler for exceptions generated by the
 420 -- user's code; it normally just prints out the exception.  The
 421 -- handler must be recursive, in case showing the exception causes
 422 -- more exceptions to be raised.
 423 --
 424 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
 425 -- raising another exception.  We therefore don't put the recursive
 426 -- handler arond the flushing operation, so if stderr is closed
 427 -- GHCi will just die gracefully rather than going into an infinite loop.
 428 handler :: Exception -> GHCi Bool
 429 handler exception = do
 430   flushInterpBuffers
 431   io installSignalHandlers
 432   ghciHandle handler (showException exception >> return False)
 433
 434 showException (DynException dyn) =
 435   case fromDynamic dyn of
 436     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
 437     Just Interrupted      -> io (putStrLn "Interrupted.")
 438     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
 439     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
 440     Just other_ghc_ex     -> io (print other_ghc_ex)
 441
 442 showException other_exception
 443   = io (putStrLn ("*** Exception: " ++ show other_exception))
 444
 445 runStmt :: String -> GHCi (Maybe [Name])
 446 runStmt stmt
 447  | null (filter (not.isSpace) stmt) = return (Just [])
 448  | otherwise
 449  = do st <- getGHCiState
 450       session <- getSession
 451       result <- io $ withProgName (progname st) $ withArgs (args st) $
 452                      GHC.runStmt session stmt
 453       case result of
 454         GHC.RunFailed      -> return Nothing
 455         GHC.RunException e -> throw e  -- this is caught by runCommand(Eval)
 456         GHC.RunOk names    -> return (Just names)
 457
 458 -- possibly print the type and revert CAFs after evaluating an expression
 459 finishEvalExpr mb_names
 460  = do b <- isOptionSet ShowType
 461       session <- getSession
 462       case mb_names of
 463         Nothing    -> return ()
 464         Just names -> when b (mapM_ (showTypeOfName session) names)
 465
 466       flushInterpBuffers
 467       io installSignalHandlers
 468       b <- isOptionSet RevertCAFs
 469       io (when b revertCAFs)
 470       return True
 471
 472 showTypeOfName :: Session -> Name -> GHCi ()
 473 showTypeOfName session n
 474    = do maybe_tything <- io (GHC.lookupName session n)
 475         case maybe_tything of
 476           Nothing    -> return ()
 477           Just thing -> showTyThing thing
 478
 479 showForUser :: SDoc -> GHCi String
 480 showForUser doc = do
 481   session <- getSession
 482   unqual <- io (GHC.getPrintUnqual session)
 483   return $! showSDocForUser unqual doc
 484
 485 specialCommand :: String -> GHCi Bool
 486 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 487 specialCommand str = do
 488   let (cmd,rest) = break isSpace str
 489   cmds <- io (readIORef commands)
 490   case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
 491      []      -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
 492                                     ++ shortHelpText) >> return False)
 493      [(_,f)] -> f (dropWhile isSpace rest)
 494      cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++
 495                                       " matches multiple commands (" ++
 496                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
 497                                          ++ ")") >> return False)
 498
 499 -----------------------------------------------------------------------------
 500 -- To flush buffers for the *interpreted* computation we need
 501 -- to refer to *its* stdout/stderr handles
 502
 503 GLOBAL_VAR(flush_interp,       error "no flush_interp", IO ())
 504 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
 505
 506 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
 507              " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
 508 flush_cmd  = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
 509
 510 initInterpBuffering :: Session -> IO ()
 511 initInterpBuffering session
 512  = do maybe_hval <- GHC.compileExpr session no_buf_cmd
 513
 514       case maybe_hval of
 515         Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
 516         other     -> panic "interactiveUI:setBuffering"
 517
 518       maybe_hval <- GHC.compileExpr session flush_cmd
 519       case maybe_hval of
 520         Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
 521         _         -> panic "interactiveUI:flush"
 522
 523       turnOffBuffering  -- Turn it off right now
 524
 525       return ()
 526
 527
 528 flushInterpBuffers :: GHCi ()
 529 flushInterpBuffers
 530  = io $ do Monad.join (readIORef flush_interp)
 531            return ()
 532
 533 turnOffBuffering :: IO ()
 534 turnOffBuffering
 535  = do Monad.join (readIORef turn_off_buffering)
 536       return ()
 537
 538 -----------------------------------------------------------------------------
 539 -- Commands
 540
 541 help :: String -> GHCi ()
 542 help _ = io (putStr helpText)
 543
 544 info :: String -> GHCi ()
 545 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
 546 info s  = do { let names = words s
 547              ; session <- getSession
 548              ; dflags <- getDynFlags
 549              ; let exts = dopt Opt_GlasgowExts dflags
 550              ; mapM_ (infoThing exts session) names }
 551   where
 552     infoThing exts session str = io $ do
 553         names <- GHC.parseName session str
 554         let filtered = filterOutChildren names
 555         mb_stuffs <- mapM (GHC.getInfo session) filtered
 556         unqual <- GHC.getPrintUnqual session
 557         putStrLn (showSDocForUser unqual $
 558                    vcat (intersperse (text "") $
 559                    [ pprInfo exts stuff | Just stuff <-  mb_stuffs ]))
 560
 561   -- Filter out names whose parent is also there Good
 562   -- example is '[]', which is both a type and data
 563   -- constructor in the same type
 564 filterOutChildren :: [Name] -> [Name]
 565 filterOutChildren names = filter (not . parent_is_there) names
 566  where parent_is_there n
 567          | Just p <- GHC.nameParent_maybe n = p `elem` names
 568          | otherwise                       = False
 569
 570 pprInfo exts (thing, fixity, insts)
 571   =  pprTyThingInContextLoc exts thing
 572   $$ show_fixity fixity
 573   $$ vcat (map GHC.pprInstance insts)
 574   where
 575     show_fixity fix
 576         | fix == GHC.defaultFixity = empty
 577         | otherwise                = ppr fix <+> ppr (GHC.getName thing)
 578
 579 -----------------------------------------------------------------------------
 580 -- Commands
 581
 582 addModule :: [FilePath] -> GHCi ()
 583 addModule files = do
 584   io (revertCAFs)                       -- always revert CAFs on load/add.
 585   files <- mapM expandPath files
 586   targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
 587   session <- getSession
 588   io (mapM_ (GHC.addTarget session) targets)
 589   ok <- io (GHC.load session LoadAllTargets)
 590   afterLoad ok session
 591
 592 changeDirectory :: String -> GHCi ()
 593 changeDirectory dir = do
 594   session <- getSession
 595   graph <- io (GHC.getModuleGraph session)
 596   when (not (null graph)) $
 597         io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
 598   io (GHC.setTargets session [])
 599   io (GHC.load session LoadAllTargets)
 600   setContextAfterLoad session []
 601   io (GHC.workingDirectoryChanged session)
 602   dir <- expandPath dir
 603   io (setCurrentDirectory dir)
 604
 605 defineMacro :: String -> GHCi ()
 606 defineMacro s = do
 607   let (macro_name, definition) = break isSpace s
 608   cmds <- io (readIORef commands)
 609   if (null macro_name)
 610         then throwDyn (CmdLineError "invalid macro name")
 611         else do
 612   if (macro_name `elem` map fst cmds)
 613         then throwDyn (CmdLineError
 614                 ("command '" ++ macro_name ++ "' is already defined"))
 615         else do
 616
 617   -- give the expression a type signature, so we can be sure we're getting
 618   -- something of the right type.
 619   let new_expr = '(' : definition ++ ") :: String -> IO String"
 620
 621   -- compile the expression
 622   cms <- getSession
 623   maybe_hv <- io (GHC.compileExpr cms new_expr)
 624   case maybe_hv of
 625      Nothing -> return ()
 626      Just hv -> io (writeIORef commands --
 627                     ((macro_name, keepGoing (runMacro hv)) : cmds))
 628
 629 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi ()
 630 runMacro fun s = do
 631   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 632   stringLoop (lines str)
 633
 634 undefineMacro :: String -> GHCi ()
 635 undefineMacro macro_name = do
 636   cmds <- io (readIORef commands)
 637   if (macro_name `elem` map fst builtin_commands)
 638         then throwDyn (CmdLineError
 639                 ("command '" ++ macro_name ++ "' cannot be undefined"))
 640         else do
 641   if (macro_name `notElem` map fst cmds)
 642         then throwDyn (CmdLineError
 643                 ("command '" ++ macro_name ++ "' not defined"))
 644         else do
 645   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 646
 647
 648 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 649 loadModule fs = timeIt (loadModule' fs)
 650
 651 loadModule_ :: [FilePath] -> GHCi ()
 652 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
 653
 654 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 655 loadModule' files = do
 656   session <- getSession
 657
 658   -- unload first
 659   io (GHC.setTargets session [])
 660   io (GHC.load session LoadAllTargets)
 661
 662   -- expand tildes
 663   let (filenames, phases) = unzip files
 664   exp_filenames <- mapM expandPath filenames
 665   let files' = zip exp_filenames phases
 666   targets <- io (mapM (uncurry GHC.guessTarget) files')
 667
 668   -- NOTE: we used to do the dependency anal first, so that if it
 669   -- fails we didn't throw away the current set of modules.  This would
 670   -- require some re-working of the GHC interface, so we'll leave it
 671   -- as a ToDo for now.
 672
 673   io (GHC.setTargets session targets)
 674   ok <- io (GHC.load session LoadAllTargets)
 675   afterLoad ok session
 676   return ok
 677
 678 checkModule :: String -> GHCi ()
 679 checkModule m = do
 680   let modl = mkModule m
 681   session <- getSession
 682   result <- io (GHC.checkModule session modl)
 683   case result of
 684     Nothing -> io $ putStrLn "Nothing"
 685     Just r  -> io $ putStrLn (showSDoc (
 686         case checkedModuleInfo r of
 687            Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
 688                 let
 689                     (local,global) = partition ((== modl) . GHC.nameModule) scope
 690                 in
 691                         (text "global names: " <+> ppr global) $$
 692                         (text "local  names: " <+> ppr local)
 693            _ -> empty))
 694   afterLoad (successIf (isJust result)) session
 695
 696 reloadModule :: String -> GHCi ()
 697 reloadModule "" = do
 698   io (revertCAFs)               -- always revert CAFs on reload.
 699   session <- getSession
 700   ok <- io (GHC.load session LoadAllTargets)
 701   afterLoad ok session
 702 reloadModule m = do
 703   io (revertCAFs)               -- always revert CAFs on reload.
 704   session <- getSession
 705   ok <- io (GHC.load session (LoadUpTo (mkModule m)))
 706   afterLoad ok session
 707
 708 afterLoad ok session = do
 709   io (revertCAFs)  -- always revert CAFs on load.
 710   graph <- io (GHC.getModuleGraph session)
 711   graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod) graph
 712   setContextAfterLoad session graph'
 713   modulesLoadedMsg ok (map GHC.ms_mod graph')
 714
 715 setContextAfterLoad session [] = do
 716   io (GHC.setContext session [] [prelude_mod])
 717 setContextAfterLoad session ms = do
 718   -- load a target if one is available, otherwise load the topmost module.
 719   targets <- io (GHC.getTargets session)
 720   case [ m | Just m <- map (findTarget ms) targets ] of
 721         []    ->
 722           let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
 723           load_this (last graph')
 724         (m:_) ->
 725           load_this m
 726  where
 727    findTarget ms t
 728     = case filter (`matches` t) ms of
 729         []    -> Nothing
 730         (m:_) -> Just m
 731
 732    summary `matches` Target (TargetModule m) _
 733         = GHC.ms_mod summary == m
 734    summary `matches` Target (TargetFile f _) _
 735         | Just f' <- GHC.ml_hs_file (GHC.ms_location summary)   = f == f'
 736    summary `matches` target
 737         = False
 738
 739    load_this summary | m <- GHC.ms_mod summary = do
 740         b <- io (GHC.moduleIsInterpreted session m)
 741         if b then io (GHC.setContext session [m] [])
 742              else io (GHC.setContext session []  [prelude_mod,m])
 743
 744
 745 modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi ()
 746 modulesLoadedMsg ok mods = do
 747   dflags <- getDynFlags
 748   when (verbosity dflags > 0) $ do
 749    let mod_commas
 750         | null mods = text "none."
 751         | otherwise = hsep (
 752             punctuate comma (map pprModule mods)) <> text "."
 753    case ok of
 754     Failed ->
 755        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 756     Succeeded  ->
 757        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 758
 759
 760 typeOfExpr :: String -> GHCi ()
 761 typeOfExpr str
 762   = do cms <- getSession
 763        maybe_ty <- io (GHC.exprType cms str)
 764        case maybe_ty of
 765           Nothing -> return ()
 766           Just ty -> do ty' <- cleanType ty
 767                         tystr <- showForUser (ppr ty')
 768                         io (putStrLn (str ++ " :: " ++ tystr))
 769
 770 kindOfType :: String -> GHCi ()
 771 kindOfType str
 772   = do cms <- getSession
 773        maybe_ty <- io (GHC.typeKind cms str)
 774        case maybe_ty of
 775           Nothing    -> return ()
 776           Just ty    -> do tystr <- showForUser (ppr ty)
 777                            io (putStrLn (str ++ " :: " ++ tystr))
 778
 779 quit :: String -> GHCi Bool
 780 quit _ = return True
 781
 782 shellEscape :: String -> GHCi Bool
 783 shellEscape str = io (system str >> return False)
 784
 785 -----------------------------------------------------------------------------
 786 -- create tags file for currently loaded modules.
 787
 788 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
 789
 790 createCTagsFileCmd ""   = ghciCreateTagsFile CTags "tags"
 791 createCTagsFileCmd file = ghciCreateTagsFile CTags file
 792
 793 createETagsFileCmd ""    = ghciCreateTagsFile ETags "TAGS"
 794 createETagsFileCmd file  = ghciCreateTagsFile ETags file
 795
 796 data TagsKind = ETags | CTags
 797
 798 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
 799 ghciCreateTagsFile kind file = do
 800   session <- getSession
 801   io $ createTagsFile session kind file
 802
 803 -- ToDo:
 804 --      - remove restriction that all modules must be interpreted
 805 --        (problem: we don't know source locations for entities unless
 806 --        we compiled the module.
 807 --
 808 --      - extract createTagsFile so it can be used from the command-line
 809 --        (probably need to fix first problem before this is useful).
 810 --
 811 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
 812 createTagsFile session tagskind tagFile = do
 813   graph <- GHC.getModuleGraph session
 814   let ms = map GHC.ms_mod graph
 815       tagModule m = do
 816         is_interpreted <- GHC.moduleIsInterpreted session m
 817         -- should we just skip these?
 818         when (not is_interpreted) $
 819           throwDyn (CmdLineError ("module '" ++ moduleString m ++ "' is not interpreted"))
 820
 821         mbModInfo <- GHC.getModuleInfo session m
 822         let unqual
 823               | Just modinfo <- mbModInfo,
 824                 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
 825               | otherwise = GHC.alwaysQualify
 826
 827         case mbModInfo of
 828           Just modInfo -> return $! listTags unqual modInfo
 829           _            -> return []
 830
 831   mtags <- mapM tagModule ms
 832   either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
 833   case either_res of
 834     Left e  -> hPutStrLn stderr $ ioeGetErrorString e
 835     Right _ -> return ()
 836
 837 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
 838 listTags unqual modInfo =
 839            [ tagInfo unqual name loc
 840            | name <- GHC.modInfoExports modInfo
 841            , let loc = nameSrcLoc name
 842            , isGoodSrcLoc loc
 843            ]
 844
 845 type TagInfo = (String -- tag name
 846                ,String -- file name
 847                ,Int    -- line number
 848                ,Int    -- column number
 849                )
 850
 851 -- get tag info, for later translation into Vim or Emacs style
 852 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
 853 tagInfo unqual name loc
 854     = ( showSDocForUser unqual $ pprOccName (nameOccName name)
 855       , showSDocForUser unqual $ ftext (srcLocFile loc)
 856       , srcLocLine loc
 857       , srcLocCol loc
 858       )
 859
 860 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
 861 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
 862   let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
 863   IO.try (writeFile file tags)
 864 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
 865   let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
 866       groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
 867   tagGroups <- mapM tagFileGroup groups
 868   IO.try (writeFile file $ concat tagGroups)
 869   where
 870     tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
 871     tagFileGroup group@((_,fileName,_,_):_) = do
 872       file <- readFile fileName -- need to get additional info from sources..
 873       let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
 874           sortedGroup = sortLe byLine group
 875           tags = unlines $ perFile sortedGroup 1 0 $ lines file
 876       return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
 877     perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
 878       perFile (tagInfo:tags) (count+1) (pos+length line) lines
 879     perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
 880       showETag tagInfo line pos : perFile tags count pos lines
 881     perFile tags count pos lines = []
 882
 883 -- simple ctags format, for Vim et al
 884 showTag :: TagInfo -> String
 885 showTag (tag,file,lineNo,colNo)
 886     =  tag ++ "\t" ++ file ++ "\t" ++ show lineNo
 887
 888 -- etags format, for Emacs/XEmacs
 889 showETag :: TagInfo -> String -> Int -> String
 890 showETag (tag,file,lineNo,colNo) line charPos
 891     =  take colNo line ++ tag
 892     ++ "\x7f" ++ tag
 893     ++ "\x01" ++ show lineNo
 894     ++ "," ++ show charPos
 895
 896 -----------------------------------------------------------------------------
 897 -- Browsing a module's contents
 898
 899 browseCmd :: String -> GHCi ()
 900 browseCmd m =
 901   case words m of
 902     ['*':m] | looksLikeModuleName m -> browseModule m False
 903     [m]     | looksLikeModuleName m -> browseModule m True
 904     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 905
 906 browseModule m exports_only = do
 907   s <- getSession
 908
 909   let modl = mkModule m
 910   is_interpreted <- io (GHC.moduleIsInterpreted s modl)
 911   when (not is_interpreted && not exports_only) $
 912         throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
 913
 914   -- Temporarily set the context to the module we're interested in,
 915   -- just so we can get an appropriate PrintUnqualified
 916   (as,bs) <- io (GHC.getContext s)
 917   io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
 918                       else GHC.setContext s [modl] [])
 919   unqual <- io (GHC.getPrintUnqual s)
 920   io (GHC.setContext s as bs)
 921
 922   mb_mod_info <- io $ GHC.getModuleInfo s modl
 923   case mb_mod_info of
 924     Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
 925     Just mod_info -> do
 926         let names
 927                | exports_only = GHC.modInfoExports mod_info
 928                | otherwise    = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
 929
 930             filtered = filterOutChildren names
 931
 932         things <- io $ mapM (GHC.lookupName s) filtered
 933
 934         dflags <- getDynFlags
 935         let exts = dopt Opt_GlasgowExts dflags
 936         io (putStrLn (showSDocForUser unqual (
 937                 vcat (map (pprTyThingInContext exts) (catMaybes things))
 938            )))
 939         -- ToDo: modInfoInstances currently throws an exception for
 940         -- package modules.  When it works, we can do this:
 941         --      $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
 942
 943 -----------------------------------------------------------------------------
 944 -- Setting the module context
 945
 946 setContext str
 947   | all sensible mods = fn mods
 948   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
 949   where
 950     (fn, mods) = case str of
 951                         '+':stuff -> (addToContext,      words stuff)
 952                         '-':stuff -> (removeFromContext, words stuff)
 953                         stuff     -> (newContext,        words stuff)
 954
 955     sensible ('*':m) = looksLikeModuleName m
 956     sensible m       = looksLikeModuleName m
 957
 958 newContext mods = do
 959   session <- getSession
 960   (as,bs) <- separate session mods [] []
 961   let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs
 962   io (GHC.setContext session as bs')
 963
 964 separate :: Session -> [String] -> [Module] -> [Module]
 965   -> GHCi ([Module],[Module])
 966 separate session []           as bs = return (as,bs)
 967 separate session (('*':m):ms) as bs = do
 968    let modl = mkModule m
 969    b <- io (GHC.moduleIsInterpreted session modl)
 970    if b then separate session ms (modl:as) bs
 971         else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
 972 separate session (m:ms)       as bs = separate session ms as (mkModule m:bs)
 973
 974 prelude_mod = mkModule "Prelude"
 975
 976
 977 addToContext mods = do
 978   cms <- getSession
 979   (as,bs) <- io (GHC.getContext cms)
 980
 981   (as',bs') <- separate cms mods [] []
 982
 983   let as_to_add = as' \\ (as ++ bs)
 984       bs_to_add = bs' \\ (as ++ bs)
 985
 986   io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add))
 987
 988
 989 removeFromContext mods = do
 990   cms <- getSession
 991   (as,bs) <- io (GHC.getContext cms)
 992
 993   (as_to_remove,bs_to_remove) <- separate cms mods [] []
 994
 995   let as' = as \\ (as_to_remove ++ bs_to_remove)
 996       bs' = bs \\ (as_to_remove ++ bs_to_remove)
 997
 998   io (GHC.setContext cms as' bs')
 999
1000 ----------------------------------------------------------------------------
1001 -- Code for `:set'
1002
1003 -- set options in the interpreter.  Syntax is exactly the same as the
1004 -- ghc command line, except that certain options aren't available (-C,
1005 -- -E etc.)
1006 --
1007 -- This is pretty fragile: most options won't work as expected.  ToDo:
1008 -- figure out which ones & disallow them.
1009
1010 setCmd :: String -> GHCi ()
1011 setCmd ""
1012   = do st <- getGHCiState
1013        let opts = options st
1014        io $ putStrLn (showSDoc (
1015               text "options currently set: " <>
1016               if null opts
1017                    then text "none."
1018                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1019            ))
1020 setCmd str
1021   = case words str of
1022         ("args":args) -> setArgs args
1023         ("prog":prog) -> setProg prog
1024         wds -> setOptions wds
1025
1026 setArgs args = do
1027   st <- getGHCiState
1028   setGHCiState st{ args = args }
1029
1030 setProg [prog] = do
1031   st <- getGHCiState
1032   setGHCiState st{ progname = prog }
1033 setProg _ = do
1034   io (hPutStrLn stderr "syntax: :set prog <progname>")
1035
1036 setOptions wds =
1037    do -- first, deal with the GHCi opts (+s, +t, etc.)
1038       let (plus_opts, minus_opts)  = partition isPlus wds
1039       mapM_ setOpt plus_opts
1040
1041       -- then, dynamic flags
1042       dflags <- getDynFlags
1043       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1044       setDynFlags dflags'
1045
1046         -- update things if the users wants more packages
1047 {- TODO:
1048         let new_packages = pkgs_after \\ pkgs_before
1049         when (not (null new_packages)) $
1050            newPackages new_packages
1051 -}
1052
1053       if (not (null leftovers))
1054                 then throwDyn (CmdLineError ("unrecognised flags: " ++
1055                                                 unwords leftovers))
1056                 else return ()
1057
1058
1059 unsetOptions :: String -> GHCi ()
1060 unsetOptions str
1061   = do -- first, deal with the GHCi opts (+s, +t, etc.)
1062        let opts = words str
1063            (minus_opts, rest1) = partition isMinus opts
1064            (plus_opts, rest2)  = partition isPlus rest1
1065
1066        if (not (null rest2))
1067           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1068           else do
1069
1070        mapM_ unsetOpt plus_opts
1071
1072        -- can't do GHC flags for now
1073        if (not (null minus_opts))
1074           then throwDyn (CmdLineError "can't unset GHC command-line flags")
1075           else return ()
1076
1077 isMinus ('-':s) = True
1078 isMinus _ = False
1079
1080 isPlus ('+':s) = True
1081 isPlus _ = False
1082
1083 setOpt ('+':str)
1084   = case strToGHCiOpt str of
1085         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1086         Just o  -> setOption o
1087
1088 unsetOpt ('+':str)
1089   = case strToGHCiOpt str of
1090         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1091         Just o  -> unsetOption o
1092
1093 strToGHCiOpt :: String -> (Maybe GHCiOption)
1094 strToGHCiOpt "s" = Just ShowTiming
1095 strToGHCiOpt "t" = Just ShowType
1096 strToGHCiOpt "r" = Just RevertCAFs
1097 strToGHCiOpt _   = Nothing
1098
1099 optToStr :: GHCiOption -> String
1100 optToStr ShowTiming = "s"
1101 optToStr ShowType   = "t"
1102 optToStr RevertCAFs = "r"
1103
1104 {- ToDo
1105 newPackages new_pkgs = do       -- The new packages are already in v_Packages
1106   session <- getSession
1107   io (GHC.setTargets session [])
1108   io (GHC.load session Nothing)
1109   dflags   <- getDynFlags
1110   io (linkPackages dflags new_pkgs)
1111   setContextAfterLoad []
1112 -}
1113
1114 -- ---------------------------------------------------------------------------
1115 -- code for `:show'
1116
1117 showCmd str =
1118   case words str of
1119         ["modules" ] -> showModules
1120         ["bindings"] -> showBindings
1121         ["linker"]   -> io showLinkerState
1122         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
1123
1124 showModules = do
1125   session <- getSession
1126   let show_one ms = do m <- io (GHC.showModule session ms)
1127                        io (putStrLn m)
1128   graph <- io (GHC.getModuleGraph session)
1129   mapM_ show_one graph
1130
1131 showBindings = do
1132   s <- getSession
1133   unqual <- io (GHC.getPrintUnqual s)
1134   bindings <- io (GHC.getBindings s)
1135   mapM_ showTyThing bindings
1136   return ()
1137
1138 showTyThing (AnId id) = do
1139   ty' <- cleanType (GHC.idType id)
1140   str <- showForUser (ppr id <> text " :: " <> ppr ty')
1141   io (putStrLn str)
1142 showTyThing _  = return ()
1143
1144 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1145 cleanType :: Type -> GHCi Type
1146 cleanType ty = do
1147   dflags <- getDynFlags
1148   if dopt Opt_GlasgowExts dflags
1149         then return ty
1150         else return $! GHC.dropForAlls ty
1151
1152 -----------------------------------------------------------------------------
1153 -- GHCi monad
1154
1155 data GHCiState = GHCiState
1156      {
1157         progname       :: String,
1158         args           :: [String],
1159         session        :: GHC.Session,
1160         options        :: [GHCiOption]
1161      }
1162
1163 data GHCiOption
1164         = ShowTiming            -- show time/allocs after evaluation
1165         | ShowType              -- show the type of expressions
1166         | RevertCAFs            -- revert CAFs after every evaluation
1167         deriving Eq
1168
1169 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1170
1171 startGHCi :: GHCi a -> GHCiState -> IO a
1172 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1173
1174 instance Monad GHCi where
1175   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1176   return a  = GHCi $ \s -> return a
1177
1178 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1179 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1180    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1181
1182 getGHCiState   = GHCi $ \r -> readIORef r
1183 setGHCiState s = GHCi $ \r -> writeIORef r s
1184
1185 -- for convenience...
1186 getSession = getGHCiState >>= return . session
1187
1188 getDynFlags = do
1189   s <- getSession
1190   io (GHC.getSessionDynFlags s)
1191 setDynFlags dflags = do
1192   s <- getSession
1193   io (GHC.setSessionDynFlags s dflags)
1194
1195 isOptionSet :: GHCiOption -> GHCi Bool
1196 isOptionSet opt
1197  = do st <- getGHCiState
1198       return (opt `elem` options st)
1199
1200 setOption :: GHCiOption -> GHCi ()
1201 setOption opt
1202  = do st <- getGHCiState
1203       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1204
1205 unsetOption :: GHCiOption -> GHCi ()
1206 unsetOption opt
1207  = do st <- getGHCiState
1208       setGHCiState (st{ options = filter (/= opt) (options st) })
1209
1210 io :: IO a -> GHCi a
1211 io m = GHCi { unGHCi = \s -> m >>= return }
1212
1213 -----------------------------------------------------------------------------
1214 -- recursive exception handlers
1215
1216 -- Don't forget to unblock async exceptions in the handler, or if we're
1217 -- in an exception loop (eg. let a = error a in a) the ^C exception
1218 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1219
1220 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1221 ghciHandle h (GHCi m) = GHCi $ \s ->
1222    Exception.catch (m s)
1223         (\e -> unGHCi (ghciUnblock (h e)) s)
1224
1225 ghciUnblock :: GHCi a -> GHCi a
1226 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1227
1228 -----------------------------------------------------------------------------
1229 -- timing & statistics
1230
1231 timeIt :: GHCi a -> GHCi a
1232 timeIt action
1233   = do b <- isOptionSet ShowTiming
1234        if not b
1235           then action
1236           else do allocs1 <- io $ getAllocations
1237                   time1   <- io $ getCPUTime
1238                   a <- action
1239                   allocs2 <- io $ getAllocations
1240                   time2   <- io $ getCPUTime
1241                   io $ printTimes (fromIntegral (allocs2 - allocs1))
1242                                   (time2 - time1)
1243                   return a
1244
1245 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1246         -- defined in ghc/rts/Stats.c
1247
1248 printTimes :: Integer -> Integer -> IO ()
1249 printTimes allocs psecs
1250    = do let secs = (fromIntegral psecs / (10^12)) :: Float
1251             secs_str = showFFloat (Just 2) secs
1252         putStrLn (showSDoc (
1253                  parens (text (secs_str "") <+> text "secs" <> comma <+>
1254                          text (show allocs) <+> text "bytes")))
1255
1256 -----------------------------------------------------------------------------
1257 -- reverting CAFs
1258
1259 revertCAFs :: IO ()
1260 revertCAFs = do
1261   rts_revertCAFs
1262   turnOffBuffering
1263         -- Have to turn off buffering again, because we just
1264         -- reverted stdout, stderr & stdin to their defaults.
1265
1266 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
1267         -- Make it "safe", just in case
1268
1269 -- -----------------------------------------------------------------------------
1270 -- Utils
1271
1272 expandPath :: String -> GHCi String
1273 expandPath path =
1274   case dropWhile isSpace path of
1275    ('~':d) -> do
1276         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1277         return (tilde ++ '/':d)
1278    other ->
1279         return other