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