ghc/compiler/ghci/InteractiveUI.hs

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