ghc/compiler/ghci/InteractiveUI.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: InteractiveUI.hs,v 1.42 2001/02/12 11:38:49 sewardj Exp $
   3 --
   4 -- GHC Interactive User Interface
   5 --
   6 -- (c) The GHC Team 2000
   7 --
   8 -----------------------------------------------------------------------------
   9
  10 module InteractiveUI (interactiveUI) where
  11
  12 #include "HsVersions.h"
  13
  14 import CompManager
  15 import CmStaticInfo
  16 import ByteCodeLink
  17 import DriverFlags
  18 import DriverState
  19 import DriverUtil
  20 import Type
  21 import Linker
  22 import Finder
  23 import Module
  24 import Outputable
  25 import Util
  26 import PprType          {- instance Outputable Type; do not delete -}
  27 import Panic            ( GhcException(..) )
  28 import Config
  29
  30 import Exception
  31 import Dynamic
  32 #ifndef NO_READLINE
  33 import Readline
  34 #endif
  35 import IOExts
  36
  37 import Numeric
  38 import List
  39 import System
  40 import CPUTime
  41 import Directory
  42 import IO
  43 import Char
  44 import Monad ( when )
  45
  46 import PrelGHC          ( unsafeCoerce# )
  47
  48 -----------------------------------------------------------------------------
  49
  50 ghciWelcomeMsg = "\
  51 \   ___         ___ _\n\
  52 \  / _ \\ /\\  /\\/ __(_)\n\
  53 \ / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", For Haskell 98.\n\
  54 \/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n\
  55 \\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
  56
  57 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
  58
  59 builtin_commands :: [(String, String -> GHCi Bool)]
  60 builtin_commands = [
  61   ("add",       keepGoing addModule),
  62   ("cd",        keepGoing changeDirectory),
  63   ("def",       keepGoing defineMacro),
  64   ("help",      keepGoing help),
  65   ("?",         keepGoing help),
  66   ("load",      keepGoing loadModule),
  67   ("module",    keepGoing setContext),
  68   ("reload",    keepGoing reloadModule),
  69   ("set",       keepGoing setOptions),
  70   ("type",      keepGoing typeOfExpr),
  71   ("unset",     keepGoing unsetOptions),
  72   ("undef",     keepGoing undefineMacro),
  73   ("quit",      quit)
  74   ]
  75
  76 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
  77 keepGoing a str = a str >> return False
  78
  79 shortHelpText = "use :? for help.\n"
  80
  81 helpText = "\
  82 \ Commands available from the prompt:\n\
  83 \\
  84 \   <expr>              evaluate <expr>\n\
  85 \   :add <filename>     add a module to the current set\n\
  86 \   :cd <dir>           change directory to <dir>\n\
  87 \   :help, :?           display this list of commands\n\
  88 \   :load <filename>    load a module (and it dependents)\n\
  89 \   :module <mod>       set the context for expression evaluation to <mod>\n\
  90 \   :reload             reload the current module set\n\
  91 \   :set <option> ...   set options\n\
  92 \   :unset <option> ... unset options\n\
  93 \   :type <expr>        show the type of <expr>\n\
  94 \   :quit               exit GHCi\n\
  95 \   :!<command>         run the shell command <command>\n\
  96 \\
  97 \ Options for `:set' and `:unset':\n\
  98 \\
  99 \    +s                 print timing/memory stats after each evaluation\n\
 100 \    +t                 print type after evaluation\n\
 101 \    +r                 revert top-level expressions after each evaluation\n\
 102 \    -<flags>           most GHC command line flags can also be set here\n\
 103 \                         (eg. -v2, -fglasgow-exts, etc.)\n\
 104 \"
 105
 106 interactiveUI :: CmState -> Maybe FilePath -> IO ()
 107 interactiveUI cmstate mod = do
 108    hPutStrLn stdout ghciWelcomeMsg
 109    hFlush stdout
 110    hSetBuffering stdout NoBuffering
 111
 112    -- link in the available packages
 113    pkgs <- getPackageInfo
 114    initLinker
 115    linkPackages (reverse pkgs)
 116
 117    (cmstate, ok, mods) <-
 118         case mod of
 119              Nothing  -> return (cmstate, True, [])
 120              Just m -> cmLoadModule cmstate m
 121
 122 #ifndef NO_READLINE
 123    Readline.initialize
 124 #endif
 125
 126    prel <- moduleNameToModule defaultCurrentModuleName
 127    writeIORef defaultCurrentModule prel
 128
 129    dflags <- getDynFlags
 130
 131    (cmstate, maybe_stuff) <- cmGetExpr cmstate dflags False prel
 132                                 "PrelHandle.hFlush PrelHandle.stdout"
 133    case maybe_stuff of
 134         Nothing -> return ()
 135         Just (hv,_,_) -> writeIORef flush_stdout hv
 136
 137    (cmstate, maybe_stuff) <- cmGetExpr cmstate dflags False prel
 138                                 "PrelHandle.hFlush PrelHandle.stdout"
 139    case maybe_stuff of
 140         Nothing -> return ()
 141         Just (hv,_,_) -> writeIORef flush_stderr hv
 142
 143    let this_mod = case mods of
 144                       []   -> prel
 145                       m:ms -> m
 146
 147    (unGHCi runGHCi) GHCiState{ modules = mods,
 148                               current_module = this_mod,
 149                               target = mod,
 150                               cmstate = cmstate,
 151                               options = [ShowTiming],
 152                               last_expr = Nothing}
 153    return ()
 154
 155
 156 runGHCi :: GHCi ()
 157 runGHCi = do
 158   -- read in ./.ghci
 159   dot_ghci <- io (IO.try (openFile "./.ghci" ReadMode))
 160   case dot_ghci of
 161         Left e -> return ()
 162         Right hdl -> fileLoop hdl False
 163
 164   -- read in ~/.ghci
 165   home <- io (IO.try (getEnv "HOME"))
 166   case home of
 167    Left e  -> return ()
 168    Right dir -> do
 169         dot_ghci <- io (IO.try (openFile (dir ++ "/.ghci") ReadMode))
 170         case dot_ghci of
 171            Left e -> return ()
 172            Right hdl -> fileLoop hdl False
 173
 174   -- read commands from stdin
 175 #ifndef NO_READLINE
 176   readlineLoop
 177 #else
 178   fileLoop stdin True
 179 #endif
 180
 181   -- and finally, exit
 182   io $ do putStrLn "Leaving GHCi."
 183
 184
 185 fileLoop :: Handle -> Bool -> GHCi ()
 186 fileLoop hdl prompt = do
 187    st <- getGHCiState
 188    when prompt (io (hPutStr hdl (moduleUserString (current_module st) ++ "> ")))
 189    l <- io (IO.try (hGetLine hdl))
 190    case l of
 191         Left e | isEOFError e -> return ()
 192                | otherwise    -> throw e
 193         Right l ->
 194           case remove_spaces l of
 195             "" -> fileLoop hdl prompt
 196             l  -> do quit <- runCommand l
 197                      if quit then return () else fileLoop hdl prompt
 198
 199 stringLoop :: [String] -> GHCi ()
 200 stringLoop [] = return ()
 201 stringLoop (s:ss) = do
 202    st <- getGHCiState
 203    case remove_spaces s of
 204         "" -> stringLoop ss
 205         l  -> do quit <- runCommand l
 206                  if quit then return () else stringLoop ss
 207
 208 #ifndef NO_READLINE
 209 readlineLoop :: GHCi ()
 210 readlineLoop = do
 211    st <- getGHCiState
 212    l <- io (readline (moduleUserString (current_module st) ++ "> "))
 213    case l of
 214         Nothing -> return ()
 215         Just l  ->
 216           case remove_spaces l of
 217             "" -> readlineLoop
 218             l  -> do
 219                   io (addHistory l)
 220                   quit <- runCommand l
 221                   if quit then return () else readlineLoop
 222 #endif
 223
 224 -- Top level exception handler, just prints out the exception
 225 -- and carries on.
 226 runCommand :: String -> GHCi Bool
 227 runCommand c =
 228   ghciHandle ( \exception ->
 229         (case exception of
 230            DynException dyn ->
 231               case fromDynamic dyn of
 232                 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
 233                 Just ghc_ex ->
 234                   case ghc_ex of
 235                     PhaseFailed phase code ->
 236                         io ( putStrLn ("Phase " ++ phase ++ " failed (code "
 237                                         ++ show code ++ ")"))
 238                     Interrupted -> io (putStrLn "Interrupted.")
 239                     other -> io (putStrLn (show (ghc_ex :: GhcException)))
 240
 241            other -> io (putStrLn ("*** Exception: " ++ show exception))
 242
 243         ) >> return False
 244      ) $
 245
 246    doCommand c
 247
 248 doCommand (':' : command) = specialCommand command
 249 doCommand ('-':'-':_) = return False    -- comments, useful in scripts
 250 doCommand expr
 251    = do expr_expanded <- expandExpr expr
 252         -- io (putStrLn ( "Before: " ++ expr ++ "\nAfter:  " ++ expr_expanded))
 253         expr_ok <- timeIt (do stuff <- evalExpr expr_expanded
 254                               finishEvalExpr stuff)
 255         when expr_ok (rememberExpr expr_expanded)
 256         return False
 257
 258 -- possibly print the type and revert CAFs after evaluating an expression
 259 finishEvalExpr Nothing = return False
 260 finishEvalExpr (Just (unqual,ty))
 261  = do b <- isOptionSet ShowType
 262       io (when b (printForUser stdout unqual (text "::" <+> ppr ty)))
 263       b <- isOptionSet RevertCAFs
 264       io (when b revertCAFs)
 265       return True
 266
 267 -- Returned Bool indicates whether or not the expr was successfully
 268 -- parsed, renamed and typechecked.
 269 evalExpr :: String -> GHCi (Maybe (PrintUnqualified,Type))
 270 evalExpr expr
 271  | null (filter (not.isSpace) expr)
 272  = return Nothing
 273  | otherwise
 274  = do st <- getGHCiState
 275       dflags <- io (getDynFlags)
 276       (new_cmstate, maybe_stuff) <-
 277          io (cmGetExpr (cmstate st) dflags True (current_module st) expr)
 278       setGHCiState st{cmstate = new_cmstate}
 279       case maybe_stuff of
 280          Nothing -> return Nothing
 281          Just (hv, unqual, ty) -> do io (cmRunExpr hv)
 282                                      flushEverything
 283                                      return (Just (unqual,ty))
 284
 285 flushEverything :: GHCi ()
 286 flushEverything
 287    = io $ do flush_so <- readIORef flush_stdout
 288              cmRunExpr flush_so
 289              flush_se <- readIORef flush_stdout
 290              cmRunExpr flush_se
 291
 292 specialCommand :: String -> GHCi Bool
 293 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 294 specialCommand str = do
 295   let (cmd,rest) = break isSpace str
 296   cmds <- io (readIORef commands)
 297   case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
 298      []      -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
 299                                     ++ shortHelpText) >> return False)
 300      [(_,f)] -> f (dropWhile isSpace rest)
 301      cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++
 302                                       " matches multiple commands (" ++
 303                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
 304                                          ++ ")") >> return False)
 305
 306 noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments"))
 307
 308 -----------------------------------------------------------------------------
 309 -- Commands
 310
 311 help :: String -> GHCi ()
 312 help _ = io (putStr helpText)
 313
 314 addModule :: String -> GHCi ()
 315 addModule _ = throwDyn (OtherError ":add not implemented")
 316
 317 setContext :: String -> GHCi ()
 318 setContext ""
 319   = throwDyn (OtherError "syntax: `:m <module>'")
 320 setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
 321   = throwDyn (OtherError ("strange looking module name: `" ++ m ++ "'"))
 322 setContext mn
 323   = do m <- io (moduleNameToModule (mkModuleName mn))
 324        st <- getGHCiState
 325        if (isHomeModule m && m `notElem` modules st)
 326           then throwDyn (OtherError (showSDoc (quotes (ppr (moduleName m))
 327                                 <+> text "is not currently loaded, use :load")))
 328           else setGHCiState st{current_module = m}
 329
 330 moduleNameToModule :: ModuleName -> IO Module
 331 moduleNameToModule mn
 332  = do maybe_stuff <- findModule mn
 333       case maybe_stuff of
 334          Nothing -> throwDyn (OtherError ("can't find module `"
 335                                             ++ moduleNameUserString mn ++ "'"))
 336          Just (m,_) -> return m
 337
 338 changeDirectory :: String -> GHCi ()
 339 changeDirectory d = io (setCurrentDirectory d)
 340
 341 defineMacro :: String -> GHCi ()
 342 defineMacro s = do
 343   let (macro_name, definition) = break isSpace s
 344   cmds <- io (readIORef commands)
 345   if (null macro_name)
 346         then throwDyn (OtherError "invalid macro name")
 347         else do
 348   if (macro_name `elem` map fst cmds)
 349         then throwDyn (OtherError
 350                 ("command `" ++ macro_name ++ "' already defined"))
 351         else do
 352
 353   -- give the expression a type signature, so we can be sure we're getting
 354   -- something of the right type.
 355   let new_expr = '(' : definition ++ ") :: String -> IO String"
 356
 357   -- compile the expression
 358   st <- getGHCiState
 359   dflags <- io (getDynFlags)
 360   (new_cmstate, maybe_stuff) <-
 361          io (cmGetExpr (cmstate st) dflags False (current_module st) new_expr)
 362   setGHCiState st{cmstate = new_cmstate}
 363   case maybe_stuff of
 364      Nothing -> return ()
 365      Just (hv, unqual, ty)
 366         -> io (writeIORef commands
 367                  ((macro_name, keepGoing (runMacro hv)) : cmds))
 368
 369 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
 370 runMacro fun s = do
 371   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 372   stringLoop (lines str)
 373
 374 undefineMacro :: String -> GHCi ()
 375 undefineMacro macro_name = do
 376   cmds <- io (readIORef commands)
 377   if (macro_name `elem` map fst builtin_commands)
 378         then throwDyn (OtherError
 379                 ("command `" ++ macro_name ++ "' cannot be undefined"))
 380         else do
 381   if (macro_name `notElem` map fst cmds)
 382         then throwDyn (OtherError
 383                 ("command `" ++ macro_name ++ "' not defined"))
 384         else do
 385   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 386
 387 loadModule :: String -> GHCi ()
 388 loadModule path = timeIt (loadModule' path)
 389
 390 loadModule' path = do
 391   state <- getGHCiState
 392   cmstate1 <- io (cmUnload (cmstate state))
 393   io (revertCAFs)                       -- always revert CAFs on load.
 394   (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
 395
 396   def_mod <- io (readIORef defaultCurrentModule)
 397
 398   let new_state = state{
 399                         cmstate = cmstate2,
 400                         modules = mods,
 401                         current_module = case mods of
 402                                            [] -> def_mod
 403                                            xs -> head xs,
 404                         target = Just path
 405                    }
 406   setGHCiState new_state
 407
 408   let mod_commas
 409         | null mods = text "none."
 410         | otherwise = hsep (
 411             punctuate comma (map (text.moduleUserString) mods)) <> text "."
 412   case ok of
 413     False ->
 414        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 415     True  ->
 416        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 417
 418 reloadModule :: String -> GHCi ()
 419 reloadModule "" = do
 420   state <- getGHCiState
 421   case target state of
 422    Nothing -> io (putStr "no current target\n")
 423    Just path
 424       -> do io (revertCAFs)             -- always revert CAFs on reload.
 425             (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
 426             def_mod <- io (readIORef defaultCurrentModule)
 427             setGHCiState
 428                state{cmstate=new_cmstate,
 429                      modules = mods,
 430                      current_module = case mods of
 431                                          [] -> def_mod
 432                                          xs -> head xs
 433                     }
 434
 435 reloadModule _ = noArgs ":reload"
 436
 437 typeOfExpr :: String -> GHCi ()
 438 typeOfExpr str
 439   = do st <- getGHCiState
 440        dflags <- io (getDynFlags)
 441        (new_cmstate, maybe_ty) <- io (cmGetExpr (cmstate st) dflags False
 442                                          (current_module st) str)
 443        setGHCiState st{cmstate = new_cmstate}
 444        case maybe_ty of
 445          Nothing -> return ()
 446          Just (_, unqual, ty) -> io (printForUser stdout unqual (ppr ty))
 447
 448 quit :: String -> GHCi Bool
 449 quit _ = return True
 450
 451 shellEscape :: String -> GHCi Bool
 452 shellEscape str = io (system str >> return False)
 453
 454 ----------------------------------------------------------------------------
 455 -- Code for `:set'
 456
 457 -- set options in the interpreter.  Syntax is exactly the same as the
 458 -- ghc command line, except that certain options aren't available (-C,
 459 -- -E etc.)
 460 --
 461 -- This is pretty fragile: most options won't work as expected.  ToDo:
 462 -- figure out which ones & disallow them.
 463
 464 setOptions :: String -> GHCi ()
 465 setOptions ""
 466   = do st <- getGHCiState
 467        let opts = options st
 468        io $ putStrLn (showSDoc (
 469               text "options currently set: " <>
 470               if null opts
 471                    then text "none."
 472                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 473            ))
 474 setOptions str
 475   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 476        let opts = words str
 477            (minus_opts, rest1) = partition isMinus opts
 478            (plus_opts, rest2)  = partition isPlus rest1
 479
 480        if (not (null rest2))
 481           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 482           else do
 483
 484        mapM setOpt plus_opts
 485
 486        -- now, the GHC flags
 487        io (do -- first, static flags
 488               leftovers <- processArgs static_flags minus_opts []
 489
 490               -- then, dynamic flags
 491               dyn_flags <- readIORef v_InitDynFlags
 492               writeIORef v_DynFlags dyn_flags
 493               leftovers <- processArgs dynamic_flags leftovers []
 494               dyn_flags <- readIORef v_DynFlags
 495               writeIORef v_InitDynFlags dyn_flags
 496
 497               if (not (null leftovers))
 498                  then throwDyn (OtherError ("unrecognised flags: " ++
 499                                                 unwords leftovers))
 500                  else return ()
 501          )
 502
 503 unsetOptions :: String -> GHCi ()
 504 unsetOptions str
 505   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 506        let opts = words str
 507            (minus_opts, rest1) = partition isMinus opts
 508            (plus_opts, rest2)  = partition isPlus rest1
 509
 510        if (not (null rest2))
 511           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 512           else do
 513
 514        mapM unsetOpt plus_opts
 515
 516        -- can't do GHC flags for now
 517        if (not (null minus_opts))
 518           then throwDyn (OtherError "can't unset GHC command-line flags")
 519           else return ()
 520
 521 isMinus ('-':s) = True
 522 isMinus _ = False
 523
 524 isPlus ('+':s) = True
 525 isPlus _ = False
 526
 527 setOpt ('+':str)
 528   = case strToGHCiOpt str of
 529         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 530         Just o  -> setOption o
 531
 532 unsetOpt ('+':str)
 533   = case strToGHCiOpt str of
 534         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 535         Just o  -> unsetOption o
 536
 537 strToGHCiOpt :: String -> (Maybe GHCiOption)
 538 strToGHCiOpt "s" = Just ShowTiming
 539 strToGHCiOpt "t" = Just ShowType
 540 strToGHCiOpt "r" = Just RevertCAFs
 541 strToGHCiOpt _   = Nothing
 542
 543 optToStr :: GHCiOption -> String
 544 optToStr ShowTiming = "s"
 545 optToStr ShowType   = "t"
 546 optToStr RevertCAFs = "r"
 547
 548 -----------------------------------------------------------------------------
 549 -- Code to do last-expression-entered stuff.  (a.k.a the $$ facility)
 550
 551 -- Take a string and replace $$s in it with the last expr, if any.
 552 expandExpr :: String -> GHCi String
 553 expandExpr str
 554    = do mle <- getLastExpr
 555         return (outside mle str)
 556      where
 557         outside mle ('$':'$':cs)
 558            = case mle of
 559                 Just le -> " (" ++ le ++ ") " ++ outside mle cs
 560                 Nothing -> outside mle cs
 561
 562         outside mle []           = []
 563         outside mle ('"':str)    = '"' : inside2 mle str   -- "
 564         outside mle ('\'':str)   = '\'' : inside1 mle str   -- '
 565         outside mle (c:cs)       = c : outside mle cs
 566
 567         inside2 mle ('"':cs)  = '"' : outside mle cs   -- "
 568         inside2 mle (c:cs)    = c : inside2 mle cs
 569         inside2 mle []        = []
 570
 571         inside1 mle ('\'':cs) = '\'': outside mle cs
 572         inside1 mle (c:cs)    = c : inside1 mle cs
 573         inside1 mle []        = []
 574
 575
 576 rememberExpr :: String -> GHCi ()
 577 rememberExpr str
 578    = do let cleaned = (clean . reverse . clean . reverse) str
 579         let forget_me_not | null cleaned = Nothing
 580                           | otherwise    = Just cleaned
 581         setLastExpr forget_me_not
 582      where
 583         clean = dropWhile isSpace
 584
 585
 586 -----------------------------------------------------------------------------
 587 -- GHCi monad
 588
 589 data GHCiState = GHCiState
 590      {
 591         modules        :: [Module],
 592         current_module :: Module,
 593         target         :: Maybe FilePath,
 594         cmstate        :: CmState,
 595         options        :: [GHCiOption],
 596         last_expr      :: Maybe String
 597      }
 598
 599 data GHCiOption
 600         = ShowTiming            -- show time/allocs after evaluation
 601         | ShowType              -- show the type of expressions
 602         | RevertCAFs            -- revert CAFs after every evaluation
 603         deriving Eq
 604
 605 defaultCurrentModuleName = mkModuleName "Prelude"
 606 GLOBAL_VAR(defaultCurrentModule, error "no defaultCurrentModule", Module)
 607
 608 GLOBAL_VAR(flush_stdout, error "no flush_stdout", HValue)
 609 GLOBAL_VAR(flush_stderr, error "no flush_stdout", HValue)
 610
 611 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
 612
 613 instance Monad GHCi where
 614   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
 615   return a  = GHCi $ \s -> return (s,a)
 616
 617 getGHCiState   = GHCi $ \s -> return (s,s)
 618 setGHCiState s = GHCi $ \_ -> return (s,())
 619
 620 isOptionSet :: GHCiOption -> GHCi Bool
 621 isOptionSet opt
 622  = do st <- getGHCiState
 623       return (opt `elem` options st)
 624
 625 setOption :: GHCiOption -> GHCi ()
 626 setOption opt
 627  = do st <- getGHCiState
 628       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 629
 630 unsetOption :: GHCiOption -> GHCi ()
 631 unsetOption opt
 632  = do st <- getGHCiState
 633       setGHCiState (st{ options = filter (/= opt) (options st) })
 634
 635 getLastExpr :: GHCi (Maybe String)
 636 getLastExpr
 637  = do st <- getGHCiState ; return (last_expr st)
 638
 639 setLastExpr :: Maybe String -> GHCi ()
 640 setLastExpr last_expr
 641  = do st <- getGHCiState ; setGHCiState (st{last_expr = last_expr})
 642
 643 io m = GHCi $ \s -> m >>= \a -> return (s,a)
 644
 645 -----------------------------------------------------------------------------
 646 -- recursive exception handlers
 647
 648 -- Don't forget to unblock async exceptions in the handler, or if we're
 649 -- in an exception loop (eg. let a = error a in a) the ^C exception
 650 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
 651
 652 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
 653 ghciHandle h (GHCi m) = GHCi $ \s ->
 654    Exception.catch (m s)
 655         (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
 656
 657 ghciUnblock :: GHCi a -> GHCi a
 658 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
 659
 660 -----------------------------------------------------------------------------
 661 -- package loader
 662
 663 linkPackages :: [Package] -> IO ()
 664 linkPackages pkgs = mapM_ linkPackage pkgs
 665
 666 linkPackage :: Package -> IO ()
 667 -- ignore rts and gmp for now (ToDo; better?)
 668 linkPackage pkg | name pkg `elem` ["rts", "gmp"] = return ()
 669 linkPackage pkg = do
 670   putStr ("Loading package " ++ name pkg ++ " ... ")
 671   let dirs = library_dirs pkg
 672   let objs = map (++".o") (hs_libraries pkg ++ extra_libraries pkg)
 673   mapM (linkOneObj dirs) objs
 674   putStr "resolving ... "
 675   resolveObjs
 676   putStrLn "done."
 677
 678 linkOneObj dirs obj = do
 679   filename <- findFile dirs obj
 680   loadObj filename
 681
 682 findFile [] obj = throwDyn (OtherError ("can't find " ++ obj))
 683 findFile (d:ds) obj = do
 684   let path = d ++ '/':obj
 685   b <- doesFileExist path
 686   if b then return path else findFile ds obj
 687
 688 -----------------------------------------------------------------------------
 689 -- timing & statistics
 690
 691 timeIt :: GHCi a -> GHCi a
 692 timeIt action
 693   = do b <- isOptionSet ShowTiming
 694        if not b
 695           then action
 696           else do allocs1 <- io $ getAllocations
 697                   time1   <- io $ getCPUTime
 698                   a <- action
 699                   allocs2 <- io $ getAllocations
 700                   time2   <- io $ getCPUTime
 701                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
 702                   return a
 703
 704 foreign import "getAllocations" getAllocations :: IO Int
 705
 706 printTimes :: Int -> Integer -> IO ()
 707 printTimes allocs psecs
 708    = do let secs = (fromIntegral psecs / (10^12)) :: Float
 709             secs_str = showFFloat (Just 2) secs
 710         putStrLn (showSDoc (
 711                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 712                          int allocs <+> text "bytes")))
 713
 714 -----------------------------------------------------------------------------
 715 -- reverting CAFs
 716
 717 foreign import revertCAFs :: IO ()      -- make it "safe", just in case