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