ghc/compiler/ghci/InteractiveUI.hs

   1 {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: InteractiveUI.hs,v 1.128 2002/07/02 16:27:38 simonmar Exp $
   4 --
   5 -- GHC Interactive User Interface
   6 --
   7 -- (c) The GHC Team 2000
   8 --
   9 -----------------------------------------------------------------------------
  10 module InteractiveUI (
  11         interactiveUI,  -- :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
  12         LibrarySpec(..),
  13         ghciWelcomeMsg
  14    ) where
  15
  16 #include "../includes/config.h"
  17 #include "HsVersions.h"
  18
  19 import Packages
  20
  21 import CompManager
  22 import CmTypes          ( Linkable, isObjectLinkable, ModSummary(..) )
  23 import CmLink           ( findModuleLinkable_maybe )
  24
  25 import HscTypes         ( TyThing(..), showModMsg, InteractiveContext(..) )
  26 import HsSyn            ( TyClDecl(..), ConDecl(..), Sig(..) )
  27 import MkIface          ( ifaceTyThing )
  28 import DriverFlags
  29 import DriverState
  30 import DriverUtil       ( handle, remove_spaces )
  31 import Linker
  32 import Finder           ( flushPackageCache )
  33 import Util
  34 import Id               ( isRecordSelector, recordSelectorFieldLabel,
  35                           isDataConWrapId, isDataConId, idName )
  36 import Class            ( className )
  37 import TyCon            ( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) )
  38 import FieldLabel       ( fieldLabelTyCon )
  39 import SrcLoc           ( isGoodSrcLoc )
  40 import Module           ( moduleName )
  41 import NameEnv          ( nameEnvElts )
  42 import Name             ( Name, isHomePackageName, nameSrcLoc, nameOccName,
  43                           NamedThing(..) )
  44 import OccName          ( isSymOcc )
  45 import BasicTypes       ( defaultFixity )
  46 import Outputable
  47 import CmdLineOpts      ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags,
  48                           restoreDynFlags, dopt_unset )
  49 import Panic            ( GhcException(..), showGhcException )
  50 import Config
  51
  52 #ifndef mingw32_TARGET_OS
  53 import Posix
  54 #endif
  55
  56 import Exception
  57 import Dynamic
  58 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
  59 import Readline
  60 #endif
  61 import Concurrent
  62 import IOExts
  63 import SystemExts
  64
  65 import Numeric
  66 import List
  67 import System
  68 import CPUTime
  69 import Directory
  70 import IO
  71 import Char
  72 import Monad
  73
  74 import GlaExts          ( unsafeCoerce# )
  75
  76 import Foreign          ( nullPtr )
  77 import CString          ( CString, peekCString, withCString )
  78
  79 -----------------------------------------------------------------------------
  80
  81 ghciWelcomeMsg = "\
  82 \   ___         ___ _\n\
  83 \  / _ \\ /\\  /\\/ __(_)\n\
  84 \ / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
  85 \/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n\
  86 \\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
  87
  88 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
  89
  90 builtin_commands :: [(String, String -> GHCi Bool)]
  91 builtin_commands = [
  92   ("add",       keepGoing addModule),
  93   ("browse",    keepGoing browseCmd),
  94   ("cd",        keepGoing changeDirectory),
  95   ("def",       keepGoing defineMacro),
  96   ("help",      keepGoing help),
  97   ("?",         keepGoing help),
  98   ("info",      keepGoing info),
  99   ("load",      keepGoing loadModule),
 100   ("module",    keepGoing setContext),
 101   ("reload",    keepGoing reloadModule),
 102   ("set",       keepGoing setCmd),
 103   ("show",      keepGoing showCmd),
 104   ("type",      keepGoing typeOfExpr),
 105   ("unset",     keepGoing unsetOptions),
 106   ("undef",     keepGoing undefineMacro),
 107   ("quit",      quit)
 108   ]
 109
 110 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 111 keepGoing a str = a str >> return False
 112
 113 shortHelpText = "use :? for help.\n"
 114
 115 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
 116 helpText = "\
 117 \ Commands available from the prompt:\n\
 118 \\n\
 119 \   <stmt>                     evaluate/run <stmt>\n\
 120 \   :add <filename> ...        add module(s) to the current target set\n\
 121 \   :browse [*]<module>        display the names defined by <module>\n\
 122 \   :cd <dir>                  change directory to <dir>\n\
 123 \   :def <cmd> <expr>          define a command :<cmd>\n\
 124 \   :help, :?                  display this list of commands\n\
 125 \   :info [<name> ...]         display information about the given names\n\
 126 \   :load <filename> ...       load module(s) and their dependents\n\
 127 \   :module [+/-] [*]<mod> ... set the context for expression evaluation\n\
 128 \   :reload                    reload the current module set\n\
 129 \\n\
 130 \   :set <option> ...          set options\n\
 131 \   :set args <arg> ...        set the arguments returned by System.getArgs\n\
 132 \   :set prog <progname>       set the value returned by System.getProgName\n\
 133 \\n\
 134 \   :show modules              show the currently loaded modules\n\
 135 \   :show bindings             show the current bindings made at the prompt\n\
 136 \\n\
 137 \   :type <expr>               show the type of <expr>\n\
 138 \   :undef <cmd>               undefine user-defined command :<cmd>\n\
 139 \   :unset <option> ...        unset options\n\
 140 \   :quit                      exit GHCi\n\
 141 \   :!<command>                run the shell command <command>\n\
 142 \\n\
 143 \ Options for `:set' and `:unset':\n\
 144 \\n\
 145 \    +r                 revert top-level expressions after each evaluation\n\
 146 \    +s                 print timing/memory stats after each evaluation\n\
 147 \    +t                 print type after evaluation\n\
 148 \    -<flags>           most GHC command line flags can also be set here\n\
 149 \                         (eg. -v2, -fglasgow-exts, etc.)\n\
 150 \"
 151
 152 interactiveUI :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
 153 interactiveUI cmstate paths cmdline_libs = do
 154    hFlush stdout
 155    hSetBuffering stdout NoBuffering
 156
 157    dflags <- getDynFlags
 158
 159    -- link in the available packages
 160    pkgs <- getPackageInfo
 161    initLinker
 162    linkPackages dflags cmdline_libs pkgs
 163
 164    (cmstate, maybe_hval)
 165         <- cmCompileExpr cmstate dflags "IO.hSetBuffering IO.stdout IO.NoBuffering Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
 166    case maybe_hval of
 167         Just hval -> unsafeCoerce# hval :: IO ()
 168         _ -> panic "interactiveUI:buffering"
 169
 170    (cmstate, maybe_hval)
 171         <- cmCompileExpr cmstate dflags "IO.hFlush IO.stderr"
 172    case maybe_hval of
 173         Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
 174         _ -> panic "interactiveUI:stderr"
 175
 176    (cmstate, maybe_hval)
 177         <- cmCompileExpr cmstate dflags "IO.hFlush IO.stdout"
 178    case maybe_hval of
 179         Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
 180         _ -> panic "interactiveUI:stdout"
 181
 182         -- We don't want the cmd line to buffer any input that might be
 183         -- intended for the program, so unbuffer stdin.
 184    hSetBuffering stdin  NoBuffering
 185
 186         -- initial context is just the Prelude
 187    cmstate <- cmSetContext cmstate dflags [] ["Prelude"]
 188
 189 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 190    Readline.initialize
 191 #endif
 192
 193    startGHCi (runGHCi paths dflags)
 194         GHCiState{ progname = "<interactive>",
 195                    args = [],
 196                    targets = paths,
 197                    cmstate = cmstate,
 198                    options = [] }
 199
 200 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 201    Readline.resetTerminal Nothing
 202 #endif
 203
 204    return ()
 205
 206
 207 runGHCi :: [FilePath] -> DynFlags -> GHCi ()
 208 runGHCi paths dflags = do
 209   read_dot_files <- io (readIORef v_Read_DotGHCi)
 210
 211   when (read_dot_files) $ do
 212     -- Read in ./.ghci.
 213     let file = "./.ghci"
 214     exists <- io (doesFileExist file)
 215     when exists $ do
 216        dir_ok  <- io (checkPerms ".")
 217        file_ok <- io (checkPerms file)
 218        when (dir_ok && file_ok) $ do
 219           either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
 220           case either_hdl of
 221              Left e    -> return ()
 222              Right hdl -> fileLoop hdl False
 223
 224   when (read_dot_files) $ do
 225     -- Read in $HOME/.ghci
 226     either_dir <- io (IO.try (getEnv "HOME"))
 227     case either_dir of
 228        Left e -> return ()
 229        Right dir -> do
 230           cwd <- io (getCurrentDirectory)
 231           when (dir /= cwd) $ do
 232              let file = dir ++ "/.ghci"
 233              ok <- io (checkPerms file)
 234              when ok $ do
 235                either_hdl <- io (IO.try (openFile file ReadMode))
 236                case either_hdl of
 237                   Left e    -> return ()
 238                   Right hdl -> fileLoop hdl False
 239
 240   -- perform a :load for files given on the GHCi command line
 241   when (not (null paths)) $
 242      ghciHandle showException $
 243         loadModule (unwords paths)
 244
 245   -- enter the interactive loop
 246   is_tty <- io (hIsTerminalDevice stdin)
 247   interactiveLoop is_tty
 248
 249   -- and finally, exit
 250   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
 251
 252
 253 interactiveLoop is_tty = do
 254   -- ignore ^C exceptions caught here
 255   ghciHandleDyn (\e -> case e of
 256                         Interrupted -> ghciUnblock (interactiveLoop is_tty)
 257                         _other      -> return ()) $ do
 258
 259   -- read commands from stdin
 260 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 261   if (is_tty)
 262         then readlineLoop
 263         else fileLoop stdin False  -- turn off prompt for non-TTY input
 264 #else
 265   fileLoop stdin True
 266 #endif
 267
 268
 269 -- NOTE: We only read .ghci files if they are owned by the current user,
 270 -- and aren't world writable.  Otherwise, we could be accidentally
 271 -- running code planted by a malicious third party.
 272
 273 -- Furthermore, We only read ./.ghci if . is owned by the current user
 274 -- and isn't writable by anyone else.  I think this is sufficient: we
 275 -- don't need to check .. and ../.. etc. because "."  always refers to
 276 -- the same directory while a process is running.
 277
 278 checkPerms :: String -> IO Bool
 279 checkPerms name =
 280 #ifdef mingw32_TARGET_OS
 281   return True
 282 #else
 283   DriverUtil.handle (\_ -> return False) $ do
 284      st <- getFileStatus name
 285      me <- getRealUserID
 286      if fileOwner st /= me then do
 287         putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
 288         return False
 289       else do
 290         let mode =  fileMode st
 291         if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
 292            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
 293            then do
 294                putStrLn $ "*** WARNING: " ++ name ++
 295                           " is writable by someone else, IGNORING!"
 296                return False
 297           else return True
 298 #endif
 299
 300 fileLoop :: Handle -> Bool -> GHCi ()
 301 fileLoop hdl prompt = do
 302    cmstate <- getCmState
 303    (mod,imports) <- io (cmGetContext cmstate)
 304    when prompt (io (putStr (mkPrompt mod imports)))
 305    l <- io (IO.try (hGetLine hdl))
 306    case l of
 307         Left e | isEOFError e -> return ()
 308                | otherwise    -> throw e
 309         Right l ->
 310           case remove_spaces l of
 311             "" -> fileLoop hdl prompt
 312             l  -> do quit <- runCommand l
 313                      if quit then return () else fileLoop hdl prompt
 314
 315 stringLoop :: [String] -> GHCi ()
 316 stringLoop [] = return ()
 317 stringLoop (s:ss) = do
 318    case remove_spaces s of
 319         "" -> stringLoop ss
 320         l  -> do quit <- runCommand l
 321                  if quit then return () else stringLoop ss
 322
 323 mkPrompt toplevs exports
 324    = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
 325
 326 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 327 readlineLoop :: GHCi ()
 328 readlineLoop = do
 329    cmstate <- getCmState
 330    (mod,imports) <- io (cmGetContext cmstate)
 331    io yield
 332    l <- io (readline (mkPrompt mod imports))
 333    case l of
 334         Nothing -> return ()
 335         Just l  ->
 336           case remove_spaces l of
 337             "" -> readlineLoop
 338             l  -> do
 339                   io (addHistory l)
 340                   quit <- runCommand l
 341                   if quit then return () else readlineLoop
 342 #endif
 343
 344 -- Top level exception handler, just prints out the exception
 345 -- and carries on.
 346 runCommand :: String -> GHCi Bool
 347 runCommand c =
 348   ghciHandle ( \exception -> do
 349                 flushEverything
 350                 showException exception
 351                 return False
 352              ) $
 353   doCommand c
 354
 355 showException (DynException dyn) =
 356   case fromDynamic dyn of
 357     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
 358     Just Interrupted      -> io (putStrLn "Interrupted.")
 359     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
 360     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
 361     Just other_ghc_ex     -> io (print other_ghc_ex)
 362
 363 showException other_exception
 364   = io (putStrLn ("*** Exception: " ++ show other_exception))
 365
 366 doCommand (':' : command) = specialCommand command
 367 doCommand stmt
 368    = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
 369         return False
 370
 371 runStmt :: String -> GHCi [Name]
 372 runStmt stmt
 373  | null (filter (not.isSpace) stmt) = return []
 374  | otherwise
 375  = do st <- getGHCiState
 376       dflags <- io getDynFlags
 377       let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
 378       (new_cmstate, result) <-
 379         io $ withProgName (progname st) $ withArgs (args st) $
 380         cmRunStmt (cmstate st) dflags' stmt
 381       setGHCiState st{cmstate = new_cmstate}
 382       case result of
 383         CmRunFailed      -> return []
 384         CmRunException e -> showException e >> return []
 385         CmRunOk names    -> return names
 386
 387 -- possibly print the type and revert CAFs after evaluating an expression
 388 finishEvalExpr names
 389  = do b <- isOptionSet ShowType
 390       cmstate <- getCmState
 391       when b (mapM_ (showTypeOfName cmstate) names)
 392
 393       b <- isOptionSet RevertCAFs
 394       io (when b revertCAFs)
 395       flushEverything
 396       return True
 397
 398 showTypeOfName :: CmState -> Name -> GHCi ()
 399 showTypeOfName cmstate n
 400    = do maybe_str <- io (cmTypeOfName cmstate n)
 401         case maybe_str of
 402           Nothing  -> return ()
 403           Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
 404
 405 flushEverything :: GHCi ()
 406 flushEverything
 407    = io $ do Monad.join (readIORef flush_stdout)
 408              Monad.join (readIORef flush_stderr)
 409              return ()
 410
 411 specialCommand :: String -> GHCi Bool
 412 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 413 specialCommand str = do
 414   let (cmd,rest) = break isSpace str
 415   cmds <- io (readIORef commands)
 416   case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
 417      []      -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
 418                                     ++ shortHelpText) >> return False)
 419      [(_,f)] -> f (dropWhile isSpace rest)
 420      cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++
 421                                       " matches multiple commands (" ++
 422                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
 423                                          ++ ")") >> return False)
 424
 425 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
 426
 427 -----------------------------------------------------------------------------
 428 -- Commands
 429
 430 help :: String -> GHCi ()
 431 help _ = io (putStr helpText)
 432
 433 info :: String -> GHCi ()
 434 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
 435 info s = do
 436   let names = words s
 437   init_cms <- getCmState
 438   dflags <- io getDynFlags
 439   let
 440     infoThings cms [] = return cms
 441     infoThings cms (name:names) = do
 442       (cms, stuff) <- io (cmInfoThing cms dflags name)
 443       io (putStrLn (showSDocForUser unqual (
 444             vcat (intersperse (text "") (map showThing stuff))))
 445          )
 446       infoThings cms names
 447
 448     unqual = cmGetPrintUnqual init_cms
 449
 450     showThing (ty_thing, fixity)
 451         = vcat [ text "-- " <> showTyThing ty_thing,
 452                  showFixity fixity (getName ty_thing),
 453                  ppr (ifaceTyThing ty_thing) ]
 454
 455     showFixity fix name
 456         | fix == defaultFixity = empty
 457         | otherwise            = ppr fix <+>
 458                                  (if isSymOcc (nameOccName name)
 459                                         then ppr name
 460                                         else char '`' <> ppr name <> char '`')
 461
 462     showTyThing (AClass cl)
 463        = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
 464     showTyThing (ATyCon ty)
 465        | isPrimTyCon ty
 466        = hcat [ppr ty, text " is a primitive type constructor"]
 467        | otherwise
 468        = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
 469     showTyThing (AnId   id)
 470        = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
 471
 472     idDescr id
 473        | isRecordSelector id =
 474                 case tyConClass_maybe (fieldLabelTyCon (
 475                                 recordSelectorFieldLabel id)) of
 476                         Nothing -> text "record selector"
 477                         Just c  -> text "method in class " <> ppr c
 478        | isDataConWrapId id  = text "data constructor"
 479        | otherwise           = text "variable"
 480
 481         -- also print out the source location for home things
 482     showSrcLoc name
 483         | isHomePackageName name && isGoodSrcLoc loc
 484         = hsep [ text ", defined at", ppr loc ]
 485         | otherwise
 486         = empty
 487         where loc = nameSrcLoc name
 488
 489   cms <- infoThings init_cms names
 490   setCmState cms
 491   return ()
 492
 493 addModule :: String -> GHCi ()
 494 addModule str = do
 495   let files = words str
 496   state <- getGHCiState
 497   dflags <- io (getDynFlags)
 498   io (revertCAFs)                       -- always revert CAFs on load/add.
 499   let new_targets = files ++ targets state
 500   graph <- io (cmDepAnal (cmstate state) dflags new_targets)
 501   (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
 502   setGHCiState state{ cmstate = cmstate1, targets = new_targets }
 503   setContextAfterLoad mods
 504   modulesLoadedMsg ok mods dflags
 505
 506 changeDirectory :: String -> GHCi ()
 507 changeDirectory ('~':d) = do
 508    tilde <- io (getEnv "HOME")  -- will fail if HOME not defined
 509    io (setCurrentDirectory (tilde ++ '/':d))
 510 changeDirectory d = io (setCurrentDirectory d)
 511
 512 defineMacro :: String -> GHCi ()
 513 defineMacro s = do
 514   let (macro_name, definition) = break isSpace s
 515   cmds <- io (readIORef commands)
 516   if (null macro_name)
 517         then throwDyn (CmdLineError "invalid macro name")
 518         else do
 519   if (macro_name `elem` map fst cmds)
 520         then throwDyn (CmdLineError
 521                 ("command `" ++ macro_name ++ "' is already defined"))
 522         else do
 523
 524   -- give the expression a type signature, so we can be sure we're getting
 525   -- something of the right type.
 526   let new_expr = '(' : definition ++ ") :: String -> IO String"
 527
 528   -- compile the expression
 529   cms <- getCmState
 530   dflags <- io getDynFlags
 531   (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
 532   setCmState new_cmstate
 533   case maybe_hv of
 534      Nothing -> return ()
 535      Just hv -> io (writeIORef commands --
 536                     ((macro_name, keepGoing (runMacro hv)) : cmds))
 537
 538 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
 539 runMacro fun s = do
 540   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 541   stringLoop (lines str)
 542
 543 undefineMacro :: String -> GHCi ()
 544 undefineMacro macro_name = do
 545   cmds <- io (readIORef commands)
 546   if (macro_name `elem` map fst builtin_commands)
 547         then throwDyn (CmdLineError
 548                 ("command `" ++ macro_name ++ "' cannot be undefined"))
 549         else do
 550   if (macro_name `notElem` map fst cmds)
 551         then throwDyn (CmdLineError
 552                 ("command `" ++ macro_name ++ "' not defined"))
 553         else do
 554   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 555
 556
 557 loadModule :: String -> GHCi ()
 558 loadModule str = timeIt (loadModule' str)
 559
 560 loadModule' str = do
 561   let files = words str
 562   state <- getGHCiState
 563   dflags <- io getDynFlags
 564
 565   -- do the dependency anal first, so that if it fails we don't throw
 566   -- away the current set of modules.
 567   graph <- io (cmDepAnal (cmstate state) dflags files)
 568
 569   -- Dependency anal ok, now unload everything
 570   cmstate1 <- io (cmUnload (cmstate state) dflags)
 571   setGHCiState state{ cmstate = cmstate1, targets = [] }
 572
 573   io (revertCAFs)  -- always revert CAFs on load.
 574   (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
 575   setGHCiState state{ cmstate = cmstate2, targets = files }
 576
 577   setContextAfterLoad mods
 578   modulesLoadedMsg ok mods dflags
 579
 580
 581 reloadModule :: String -> GHCi ()
 582 reloadModule "" = do
 583   state <- getGHCiState
 584   dflags <- io getDynFlags
 585   case targets state of
 586    [] -> io (putStr "no current target\n")
 587    paths -> do
 588         -- do the dependency anal first, so that if it fails we don't throw
 589         -- away the current set of modules.
 590         graph <- io (cmDepAnal (cmstate state) dflags paths)
 591
 592         io (revertCAFs)         -- always revert CAFs on reload.
 593         (cmstate1, ok, mods)
 594                 <- io (cmLoadModules (cmstate state) dflags graph)
 595         setGHCiState state{ cmstate=cmstate1 }
 596         setContextAfterLoad mods
 597         modulesLoadedMsg ok mods dflags
 598
 599 reloadModule _ = noArgs ":reload"
 600
 601 setContextAfterLoad [] = setContext prel
 602 setContextAfterLoad (m:_) = do
 603   cmstate <- getCmState
 604   b <- io (cmModuleIsInterpreted cmstate m)
 605   if b then setContext ('*':m) else setContext m
 606
 607 modulesLoadedMsg ok mods dflags =
 608   when (verbosity dflags > 0) $ do
 609    let mod_commas
 610         | null mods = text "none."
 611         | otherwise = hsep (
 612             punctuate comma (map text mods)) <> text "."
 613    case ok of
 614     False ->
 615        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 616     True  ->
 617        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 618
 619
 620 typeOfExpr :: String -> GHCi ()
 621 typeOfExpr str
 622   = do cms <- getCmState
 623        dflags <- io getDynFlags
 624        (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
 625        setCmState new_cmstate
 626        case maybe_tystr of
 627           Nothing    -> return ()
 628           Just tystr -> io (putStrLn tystr)
 629
 630 quit :: String -> GHCi Bool
 631 quit _ = return True
 632
 633 shellEscape :: String -> GHCi Bool
 634 shellEscape str = io (system str >> return False)
 635
 636 -----------------------------------------------------------------------------
 637 -- Browing a module's contents
 638
 639 browseCmd :: String -> GHCi ()
 640 browseCmd m =
 641   case words m of
 642     ['*':m] | looksLikeModuleName m -> browseModule m False
 643     [m]     | looksLikeModuleName m -> browseModule m True
 644     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 645
 646 browseModule m exports_only = do
 647   cms <- getCmState
 648   dflags <- io getDynFlags
 649
 650   is_interpreted <- io (cmModuleIsInterpreted cms m)
 651   when (not is_interpreted && not exports_only) $
 652         throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
 653
 654   -- temporarily set the context to the module we're interested in,
 655   -- just so we can get an appropriate PrintUnqualified
 656   (as,bs) <- io (cmGetContext cms)
 657   cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m]
 658                               else cmSetContext cms dflags [m] [])
 659   cms2 <- io (cmSetContext cms1 dflags as bs)
 660
 661   (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)
 662
 663   setCmState cms3
 664
 665   let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
 666
 667       things' = filter wantToSee things
 668
 669       wantToSee (AnId id) = not (isDataConId id || isDataConWrapId id)
 670       wantToSee _ = True
 671
 672       thing_names = map getName things
 673
 674       thingDecl thing@(AnId id)  = ifaceTyThing thing
 675
 676       thingDecl thing@(AClass c) =
 677         let rn_decl = ifaceTyThing thing in
 678         case rn_decl of
 679           ClassDecl { tcdSigs = cons } ->
 680                 rn_decl{ tcdSigs = filter methodIsVisible cons }
 681           other -> other
 682         where
 683            methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
 684
 685       thingDecl thing@(ATyCon t) =
 686         let rn_decl = ifaceTyThing thing in
 687         case rn_decl of
 688           TyData { tcdCons = DataCons cons } ->
 689                 rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
 690           other -> other
 691         where
 692           conIsVisible (ConDecl n _ _ _ _ _) = n `elem` thing_names
 693
 694   io (putStrLn (showSDocForUser unqual (
 695          vcat (map (ppr . thingDecl) things')))
 696    )
 697
 698   where
 699
 700 -----------------------------------------------------------------------------
 701 -- Setting the module context
 702
 703 setContext str
 704   | all sensible mods = fn mods
 705   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
 706   where
 707     (fn, mods) = case str of
 708                         '+':stuff -> (addToContext,      words stuff)
 709                         '-':stuff -> (removeFromContext, words stuff)
 710                         stuff     -> (newContext,        words stuff)
 711
 712     sensible ('*':m) = looksLikeModuleName m
 713     sensible m       = looksLikeModuleName m
 714
 715 newContext mods = do
 716   cms <- getCmState
 717   dflags <- io getDynFlags
 718   (as,bs) <- separate cms mods [] []
 719   let bs' = if null as && prel `notElem` bs then prel:bs else bs
 720   cms' <- io (cmSetContext cms dflags as bs')
 721   setCmState cms'
 722
 723 separate cmstate []           as bs = return (as,bs)
 724 separate cmstate (('*':m):ms) as bs = do
 725    b <- io (cmModuleIsInterpreted cmstate m)
 726    if b then separate cmstate ms (m:as) bs
 727         else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
 728 separate cmstate (m:ms)       as bs = separate cmstate ms as (m:bs)
 729
 730 prel = "Prelude"
 731
 732
 733 addToContext mods = do
 734   cms <- getCmState
 735   dflags <- io getDynFlags
 736   (as,bs) <- io (cmGetContext cms)
 737
 738   (as',bs') <- separate cms mods [] []
 739
 740   let as_to_add = as' \\ (as ++ bs)
 741       bs_to_add = bs' \\ (as ++ bs)
 742
 743   cms' <- io (cmSetContext cms dflags
 744                         (as ++ as_to_add) (bs ++ bs_to_add))
 745   setCmState cms'
 746
 747
 748 removeFromContext mods = do
 749   cms <- getCmState
 750   dflags <- io getDynFlags
 751   (as,bs) <- io (cmGetContext cms)
 752
 753   (as_to_remove,bs_to_remove) <- separate cms mods [] []
 754
 755   let as' = as \\ (as_to_remove ++ bs_to_remove)
 756       bs' = bs \\ (as_to_remove ++ bs_to_remove)
 757
 758   cms' <- io (cmSetContext cms dflags as' bs')
 759   setCmState cms'
 760
 761 ----------------------------------------------------------------------------
 762 -- Code for `:set'
 763
 764 -- set options in the interpreter.  Syntax is exactly the same as the
 765 -- ghc command line, except that certain options aren't available (-C,
 766 -- -E etc.)
 767 --
 768 -- This is pretty fragile: most options won't work as expected.  ToDo:
 769 -- figure out which ones & disallow them.
 770
 771 setCmd :: String -> GHCi ()
 772 setCmd ""
 773   = do st <- getGHCiState
 774        let opts = options st
 775        io $ putStrLn (showSDoc (
 776               text "options currently set: " <>
 777               if null opts
 778                    then text "none."
 779                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 780            ))
 781 setCmd str
 782   = case words str of
 783         ("args":args) -> setArgs args
 784         ("prog":prog) -> setProg prog
 785         wds -> setOptions wds
 786
 787 setArgs args = do
 788   st <- getGHCiState
 789   setGHCiState st{ args = args }
 790
 791 setProg [prog] = do
 792   st <- getGHCiState
 793   setGHCiState st{ progname = prog }
 794 setProg _ = do
 795   io (hPutStrLn stderr "syntax: :set prog <progname>")
 796
 797 setOptions wds =
 798    do -- first, deal with the GHCi opts (+s, +t, etc.)
 799       let (plus_opts, minus_opts)  = partition isPlus wds
 800       mapM_ setOpt plus_opts
 801
 802       -- now, the GHC flags
 803       pkgs_before <- io (readIORef v_Packages)
 804       leftovers   <- io (processArgs static_flags minus_opts [])
 805       pkgs_after  <- io (readIORef v_Packages)
 806
 807       -- update things if the users wants more packages
 808       when (pkgs_before /= pkgs_after) $
 809          newPackages (pkgs_after \\ pkgs_before)
 810
 811       -- then, dynamic flags
 812       io $ do
 813         restoreDynFlags
 814         leftovers <- processArgs dynamic_flags leftovers []
 815         saveDynFlags
 816
 817         if (not (null leftovers))
 818                 then throwDyn (CmdLineError ("unrecognised flags: " ++
 819                                                 unwords leftovers))
 820                 else return ()
 821
 822
 823 unsetOptions :: String -> GHCi ()
 824 unsetOptions str
 825   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 826        let opts = words str
 827            (minus_opts, rest1) = partition isMinus opts
 828            (plus_opts, rest2)  = partition isPlus rest1
 829
 830        if (not (null rest2))
 831           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 832           else do
 833
 834        mapM_ unsetOpt plus_opts
 835
 836        -- can't do GHC flags for now
 837        if (not (null minus_opts))
 838           then throwDyn (CmdLineError "can't unset GHC command-line flags")
 839           else return ()
 840
 841 isMinus ('-':s) = True
 842 isMinus _ = False
 843
 844 isPlus ('+':s) = True
 845 isPlus _ = False
 846
 847 setOpt ('+':str)
 848   = case strToGHCiOpt str of
 849         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 850         Just o  -> setOption o
 851
 852 unsetOpt ('+':str)
 853   = case strToGHCiOpt str of
 854         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 855         Just o  -> unsetOption o
 856
 857 strToGHCiOpt :: String -> (Maybe GHCiOption)
 858 strToGHCiOpt "s" = Just ShowTiming
 859 strToGHCiOpt "t" = Just ShowType
 860 strToGHCiOpt "r" = Just RevertCAFs
 861 strToGHCiOpt _   = Nothing
 862
 863 optToStr :: GHCiOption -> String
 864 optToStr ShowTiming = "s"
 865 optToStr ShowType   = "t"
 866 optToStr RevertCAFs = "r"
 867
 868 newPackages new_pkgs = do
 869   state <- getGHCiState
 870   dflags <- io getDynFlags
 871   cmstate1 <- io (cmUnload (cmstate state) dflags)
 872   setGHCiState state{ cmstate = cmstate1, targets = [] }
 873
 874   io $ do
 875     pkgs <- getPackageInfo
 876     flushPackageCache pkgs
 877
 878     new_pkg_info <- getPackageDetails new_pkgs
 879     mapM_ (linkPackage dflags) (reverse new_pkg_info)
 880
 881   setContextAfterLoad []
 882
 883 -----------------------------------------------------------------------------
 884 -- code for `:show'
 885
 886 showCmd str =
 887   case words str of
 888         ["modules" ] -> showModules
 889         ["bindings"] -> showBindings
 890         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
 891
 892 showModules = do
 893   cms <- getCmState
 894   let mg = cmGetModuleGraph cms
 895       ls = cmGetLinkables   cms
 896       maybe_linkables = map (findModuleLinkable_maybe ls)
 897                                 (map (moduleName.ms_mod) mg)
 898   zipWithM showModule mg maybe_linkables
 899   return ()
 900
 901 showModule :: ModSummary -> Maybe Linkable -> GHCi ()
 902 showModule m (Just l) = do
 903   io (putStrLn (showModMsg (isObjectLinkable l) (ms_mod m) (ms_location m)))
 904 showModule _ Nothing = panic "missing linkable"
 905
 906 showBindings = do
 907   cms <- getCmState
 908   let
 909         unqual = cmGetPrintUnqual cms
 910         showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
 911
 912   io (mapM_ showBinding (cmGetBindings cms))
 913   return ()
 914
 915 -----------------------------------------------------------------------------
 916 -- GHCi monad
 917
 918 data GHCiState = GHCiState
 919      {
 920         progname       :: String,
 921         args           :: [String],
 922         targets        :: [FilePath],
 923         cmstate        :: CmState,
 924         options        :: [GHCiOption]
 925      }
 926
 927 data GHCiOption
 928         = ShowTiming            -- show time/allocs after evaluation
 929         | ShowType              -- show the type of expressions
 930         | RevertCAFs            -- revert CAFs after every evaluation
 931         deriving Eq
 932
 933 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
 934 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
 935
 936 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
 937
 938 startGHCi :: GHCi a -> GHCiState -> IO a
 939 startGHCi g state = do ref <- newIORef state; unGHCi g ref
 940
 941 instance Monad GHCi where
 942   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
 943   return a  = GHCi $ \s -> return a
 944
 945 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
 946 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 947    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 948
 949 getGHCiState   = GHCi $ \r -> readIORef r
 950 setGHCiState s = GHCi $ \r -> writeIORef r s
 951
 952 -- for convenience...
 953 getCmState = getGHCiState >>= return . cmstate
 954 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
 955
 956 isOptionSet :: GHCiOption -> GHCi Bool
 957 isOptionSet opt
 958  = do st <- getGHCiState
 959       return (opt `elem` options st)
 960
 961 setOption :: GHCiOption -> GHCi ()
 962 setOption opt
 963  = do st <- getGHCiState
 964       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 965
 966 unsetOption :: GHCiOption -> GHCi ()
 967 unsetOption opt
 968  = do st <- getGHCiState
 969       setGHCiState (st{ options = filter (/= opt) (options st) })
 970
 971 io :: IO a -> GHCi a
 972 io m = GHCi { unGHCi = \s -> m >>= return }
 973
 974 -----------------------------------------------------------------------------
 975 -- recursive exception handlers
 976
 977 -- Don't forget to unblock async exceptions in the handler, or if we're
 978 -- in an exception loop (eg. let a = error a in a) the ^C exception
 979 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
 980
 981 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
 982 ghciHandle h (GHCi m) = GHCi $ \s ->
 983    Exception.catch (m s)
 984         (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
 985
 986 ghciUnblock :: GHCi a -> GHCi a
 987 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
 988
 989 -----------------------------------------------------------------------------
 990 -- package loader
 991
 992 -- Left: full path name of a .o file, including trailing .o
 993 -- Right: "unadorned" name of a .DLL/.so
 994 --        e.g.    On unix     "qt"  denotes "libqt.so"
 995 --                On WinDoze  "burble"  denotes "burble.DLL"
 996 --        addDLL is platform-specific and adds the lib/.so/.DLL
 997 --        suffixes platform-dependently; we don't do that here.
 998 --
 999 -- For dynamic objects only, try to find the object file in all the
1000 -- directories specified in v_Library_Paths before giving up.
1001
1002 data LibrarySpec = Object FilePath | DLL String
1003 #ifdef darwin_TARGET_OS
1004                     | Framework String
1005 #endif
1006
1007 -- Packages that don't need loading, because the compiler shares them with
1008 -- the interpreted program.
1009 dont_load_these = [ "rts" ]
1010
1011 -- Packages that are already linked into GHCi.  For mingw32, we only
1012 -- skip gmp and rts, since std and after need to load the msvcrt.dll
1013 -- library which std depends on.
1014 loaded_in_ghci
1015 #          ifndef mingw32_TARGET_OS
1016            = [ "std", "concurrent", "posix", "text", "util" ]
1017 #          else
1018            = [ ]
1019 #          endif
1020
1021 showLS (Object nm)  = "(static) " ++ nm
1022 showLS (DLL nm) = "(dynamic) " ++ nm
1023 #ifdef darwin_TARGET_OS
1024 showLS (Framework nm) = "(framework) " ++ nm
1025 #endif
1026
1027 linkPackages :: DynFlags -> [LibrarySpec] -> [PackageConfig] -> IO ()
1028 linkPackages dflags cmdline_lib_specs pkgs
1029    = do mapM_ (linkPackage dflags) (reverse pkgs)
1030         lib_paths <- readIORef v_Library_paths
1031         mapM_ (preloadLib dflags lib_paths) cmdline_lib_specs
1032         if (null cmdline_lib_specs)
1033            then return ()
1034            else do maybePutStr dflags "final link ... "
1035
1036                    ok <- resolveObjs
1037                    if ok then maybePutStrLn dflags "done."
1038                          else throwDyn (InstallationError
1039                                           "linking extra libraries/objects failed")
1040      where
1041         preloadLib :: DynFlags -> [String] -> LibrarySpec -> IO ()
1042         preloadLib dflags lib_paths lib_spec
1043            = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
1044                 case lib_spec of
1045                    Object static_ish
1046                       -> do b <- preload_static lib_paths static_ish
1047                             maybePutStrLn dflags (if b  then "done."
1048                                                         else "not found")
1049                    DLL dll_unadorned
1050                       -> -- We add "" to the set of paths to try, so that
1051                          -- if none of the real paths match, we force addDLL
1052                          -- to look in the default dynamic-link search paths.
1053                          do maybe_errstr <- loadDynamic (lib_paths++[""])
1054                                                             dll_unadorned
1055                             case maybe_errstr of
1056                                Nothing -> return ()
1057                                Just mm -> preloadFailed mm lib_paths lib_spec
1058                             maybePutStrLn dflags "done"
1059
1060         preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
1061         preloadFailed sys_errmsg paths spec
1062            = do maybePutStr dflags
1063                        ("failed.\nDynamic linker error message was:\n   "
1064                         ++ sys_errmsg  ++ "\nWhilst trying to load:  "
1065                         ++ showLS spec ++ "\nDirectories to search are:\n"
1066                         ++ unlines (map ("   "++) paths) )
1067                 give_up
1068
1069         -- not interested in the paths in the static case.
1070         preload_static paths name
1071            = do b <- doesFileExist name
1072                 if not b then return False
1073                          else loadObj name >> return True
1074
1075         give_up
1076            = (throwDyn . CmdLineError)
1077                 "user specified .o/.so/.DLL could not be loaded."
1078
1079 linkPackage :: DynFlags -> PackageConfig -> IO ()
1080 linkPackage dflags pkg
1081    | name pkg `elem` dont_load_these = return ()
1082    | otherwise
1083    = do
1084         let dirs      =  library_dirs pkg
1085         let libs      =  hs_libraries pkg ++ extra_libraries pkg
1086         classifieds   <- mapM (locateOneObj dirs) libs
1087 #ifdef darwin_TARGET_OS
1088         let fwDirs    =  framework_dirs pkg
1089         let frameworks=  extra_frameworks pkg
1090 #endif
1091
1092         -- Complication: all the .so's must be loaded before any of the .o's.
1093         let dlls = [ dll | DLL dll <- classifieds ]
1094             objs = [ obj | Object obj <- classifieds ]
1095
1096         maybePutStr dflags ("Loading package " ++ name pkg ++ " ... ")
1097
1098         -- If this package is already part of the GHCi binary, we'll already
1099         -- have the right DLLs for this package loaded, so don't try to
1100         -- load them again.
1101         when (name pkg `notElem` loaded_in_ghci) $ do
1102 #ifdef darwin_TARGET_OS
1103             loadFrameworks fwDirs frameworks
1104 #endif
1105             loadDynamics dirs dlls
1106
1107         -- After loading all the DLLs, we can load the static objects.
1108         mapM_ loadObj objs
1109
1110         maybePutStr dflags "linking ... "
1111         ok <- resolveObjs
1112         if ok then maybePutStrLn dflags "done."
1113               else panic ("can't load package `" ++ name pkg ++ "'")
1114
1115 loadDynamics dirs [] = return ()
1116 loadDynamics dirs (dll:dlls) = do
1117   r <- loadDynamic dirs dll
1118   case r of
1119     Nothing  -> loadDynamics dirs dlls
1120     Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: "
1121                                        ++ dll ++ " (" ++ err ++ ")" ))
1122 #ifdef darwin_TARGET_OS
1123 loadFrameworks dirs [] = return ()
1124 loadFrameworks dirs (fw:fws) = do
1125   r <- loadFramework dirs fw
1126   case r of
1127     Nothing  -> loadFrameworks dirs fws
1128     Just err -> throwDyn (CmdLineError ("can't load framework: "
1129                                        ++ fw ++ " (" ++ err ++ ")" ))
1130 #endif
1131
1132 -- Try to find an object file for a given library in the given paths.
1133 -- If it isn't present, we assume it's a dynamic library.
1134 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1135 locateOneObj [] lib
1136    = return (DLL lib) -- we assume
1137 locateOneObj (d:ds) lib
1138    = do let path = d ++ '/':lib ++ ".o"
1139         b <- doesFileExist path
1140         if b then return (Object path) else locateOneObj ds lib
1141
1142 -- ----------------------------------------------------------------------------
1143 -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
1144
1145 #if defined(mingw32_TARGET_OS) || defined(cygwin32_TARGET_OS)
1146 loadDynamic paths rootname = addDLL rootname
1147   -- ignore paths on windows (why? --SDM)
1148
1149 #else
1150
1151 -- return Nothing == success, else Just error message from dlopen
1152 loadDynamic (path:paths) rootname = do
1153   let dll = path ++ '/':mkSOName rootname
1154   b <- doesFileExist dll
1155   if not b
1156      then loadDynamic paths rootname
1157      else addDLL dll
1158 loadDynamic [] rootname = do
1159         -- tried all our known library paths, let dlopen() search its
1160         -- own builtin paths now.
1161    addDLL (mkSOName rootname)
1162
1163 #ifdef darwin_TARGET_OS
1164 mkSOName root = "lib" ++ root ++ ".dylib"
1165 #else
1166 mkSOName root = "lib" ++ root ++ ".so"
1167 #endif
1168
1169 #endif
1170
1171 -- Darwin / MacOS X only: load a framework
1172 -- a framework is a dynamic library packaged inside a directory of the same
1173 -- name. They are searched for in different paths than normal libraries.
1174 #ifdef darwin_TARGET_OS
1175 loadFramework extraPaths rootname
1176    = loadFramework' (extraPaths ++ defaultFrameworkPaths) where
1177    defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
1178
1179    loadFramework' (path:paths) = do
1180       let dll = path ++ '/' : rootname ++ ".framework/" ++ rootname
1181       b <- doesFileExist dll
1182       if not b
1183          then loadFramework' paths
1184          else addDLL dll
1185    loadFramework' [] = do
1186         -- tried all our known library paths, but dlopen()
1187         -- has no built-in paths for frameworks: give up
1188       return $ Just $ "not found"
1189 #endif
1190
1191 addDLL :: String -> IO (Maybe String)
1192 addDLL str = do
1193   maybe_errmsg <- withCString str $ \dll -> c_addDLL dll
1194   if maybe_errmsg == nullPtr
1195         then return Nothing
1196         else do str <- peekCString maybe_errmsg
1197                 return (Just str)
1198
1199 foreign import ccall "addDLL" unsafe
1200   c_addDLL :: CString -> IO CString
1201
1202 -----------------------------------------------------------------------------
1203 -- timing & statistics
1204
1205 timeIt :: GHCi a -> GHCi a
1206 timeIt action
1207   = do b <- isOptionSet ShowTiming
1208        if not b
1209           then action
1210           else do allocs1 <- io $ getAllocations
1211                   time1   <- io $ getCPUTime
1212                   a <- action
1213                   allocs2 <- io $ getAllocations
1214                   time2   <- io $ getCPUTime
1215                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
1216                   return a
1217
1218 foreign import "getAllocations" getAllocations :: IO Int
1219
1220 printTimes :: Int -> Integer -> IO ()
1221 printTimes allocs psecs
1222    = do let secs = (fromIntegral psecs / (10^12)) :: Float
1223             secs_str = showFFloat (Just 2) secs
1224         putStrLn (showSDoc (
1225                  parens (text (secs_str "") <+> text "secs" <> comma <+>
1226                          int allocs <+> text "bytes")))
1227
1228 -----------------------------------------------------------------------------
1229 -- utils
1230
1231 looksLikeModuleName [] = False
1232 looksLikeModuleName (c:cs) = isUpper c && all isAlphaNumEx cs
1233
1234 isAlphaNumEx c = isAlphaNum c || c == '_' || c == '.'
1235
1236 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1237                      | otherwise            = return ()
1238
1239 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1240                        | otherwise            = return ()
1241
1242 -----------------------------------------------------------------------------
1243 -- reverting CAFs
1244
1245 foreign import revertCAFs :: IO ()      -- make it "safe", just in case