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