ghc/compiler/ghci/InteractiveUI.hs

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