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