ghc/compiler/ghci/InteractiveUI.hs

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