ghc/compiler/ghci/InteractiveUI.hs

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