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