ghc/compiler/ghci/InteractiveUI.hs

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