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