ghc/compiler/ghci/InteractiveUI.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: InteractiveUI.hs,v 1.66 2001/05/04 16:36:38 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 "../includes/config.h"
  14 #include "HsVersions.h"
  15
  16 import CompManager
  17 import CmStaticInfo
  18 import ByteCodeLink
  19 import DriverFlags
  20 import DriverState
  21 import DriverUtil
  22 import Linker
  23 import Finder           ( flushPackageCache )
  24 import Util
  25 import Name             ( Name )
  26 import Outputable
  27 import CmdLineOpts      ( DynFlag(..), dopt_unset )
  28 import Panic            ( GhcException(..) )
  29 import Config
  30
  31 import Posix
  32 import Exception
  33 import Dynamic
  34 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
  35 import Readline
  36 #endif
  37 import IOExts
  38
  39 import Numeric
  40 import List
  41 import System
  42 import CPUTime
  43 import Directory
  44 import IO
  45 import Char
  46 import Monad            ( when )
  47
  48 import PrelGHC          ( unsafeCoerce# )
  49 import Foreign          ( nullPtr )
  50 import CString          ( peekCString )
  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 \   <stmt>              evaluate/run <stmt>\n\
  89 \   :cd <dir>           change directory to <dir>\n\
  90 \   :def <cmd> <expr>   define a command :<cmd>\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 \   :undef <name>       undefine user-defined command :<name>\n\
  97 \   :type <expr>        show the type of <expr>\n\
  98 \   :unset <option> ... unset options\n\
  99 \   :quit               exit GHCi\n\
 100 \   :!<command>         run the shell command <command>\n\
 101 \\
 102 \ Options for `:set' and `:unset':\n\
 103 \\
 104 \    +r                 revert top-level expressions after each evaluation\n\
 105 \    +s                 print timing/memory stats after each evaluation\n\
 106 \    +t                 print type after evaluation\n\
 107 \    -<flags>           most GHC command line flags can also be set here\n\
 108 \                         (eg. -v2, -fglasgow-exts, etc.)\n\
 109 \"
 110  --ToDo   :add <filename>     add a module to the current set\n\
 111
 112 interactiveUI :: CmState -> Maybe FilePath -> [LibrarySpec] -> IO ()
 113 interactiveUI cmstate mod cmdline_libs = do
 114    hFlush stdout
 115    hSetBuffering stdout NoBuffering
 116
 117    -- link in the available packages
 118    pkgs <- getPackageInfo
 119    initLinker
 120    linkPackages cmdline_libs pkgs
 121
 122    (cmstate, ok, mods) <-
 123         case mod of
 124              Nothing  -> return (cmstate, True, [])
 125              Just m -> cmLoadModule cmstate m
 126
 127 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 128    Readline.initialize
 129 #endif
 130
 131    dflags <- getDynFlags
 132
 133    (cmstate, maybe_hval)
 134         <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stderr"
 135    case maybe_hval of
 136         Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
 137         _ -> panic "interactiveUI:stderr"
 138
 139    (cmstate, maybe_hval)
 140         <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stdout"
 141    case maybe_hval of
 142         Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
 143         _ -> panic "interactiveUI:stdout"
 144
 145    (unGHCi runGHCi) GHCiState{ target = mod,
 146                                cmstate = cmstate,
 147                                options = [] }
 148    return ()
 149
 150
 151 runGHCi :: GHCi ()
 152 runGHCi = do
 153   -- Read in ./.ghci.
 154   let file = "./.ghci"
 155   exists <- io (doesFileExist file)
 156   when exists $ do
 157      dir_ok  <- io (checkPerms ".")
 158      file_ok <- io (checkPerms file)
 159      when (dir_ok && file_ok) $ do
 160         either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
 161         case either_hdl of
 162            Left e    -> return ()
 163            Right hdl -> fileLoop hdl False
 164
 165   -- Read in $HOME/.ghci
 166   either_dir <- io (IO.try (getEnv "HOME"))
 167   case either_dir of
 168      Left e -> return ()
 169      Right dir -> do
 170         cwd <- io (getCurrentDirectory)
 171         when (dir /= cwd) $ do
 172            let file = dir ++ "/.ghci"
 173            ok <- io (checkPerms file)
 174            either_hdl <- io (IO.try (openFile file ReadMode))
 175            case either_hdl of
 176                 Left e    -> return ()
 177                 Right hdl -> fileLoop hdl False
 178
 179   -- read commands from stdin
 180 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 181   readlineLoop
 182 #else
 183   fileLoop stdin True
 184 #endif
 185
 186   -- and finally, exit
 187   io $ do putStrLn "Leaving GHCi."
 188
 189
 190 -- NOTE: We only read .ghci files if they are owned by the current user,
 191 -- and aren't world writable.  Otherwise, we could be accidentally
 192 -- running code planted by a malicious third party.
 193
 194 -- Furthermore, We only read ./.ghci if both . and ./.ghci are
 195 -- owned by the current user and aren't writable by anyone else.  I
 196 -- think this is sufficient: we don't need to check .. and
 197 -- ../.. etc. because "."  always refers to the same directory while a
 198 -- process is running.
 199
 200 checkPerms :: String -> IO Bool
 201 checkPerms name =
 202   handle (\_ -> return False) $ do
 203      st <- getFileStatus name
 204      me <- getRealUserID
 205      if fileOwner st /= me then do
 206         putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
 207         return False
 208       else do
 209         let mode =  fileMode st
 210         if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
 211            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
 212            then do
 213                putStrLn $ "*** WARNING: " ++ name ++
 214                           " is writable by someone else, IGNORING!"
 215                return False
 216           else return True
 217
 218 fileLoop :: Handle -> Bool -> GHCi ()
 219 fileLoop hdl prompt = do
 220    st <- getGHCiState
 221    mod <- io (cmGetContext (cmstate st))
 222    when prompt (io (putStr (mod ++ "> ")))
 223    l <- io (IO.try (hGetLine hdl))
 224    case l of
 225         Left e | isEOFError e -> return ()
 226                | otherwise    -> throw e
 227         Right l ->
 228           case remove_spaces l of
 229             "" -> fileLoop hdl prompt
 230             l  -> do quit <- runCommand l
 231                      if quit then return () else fileLoop hdl prompt
 232
 233 stringLoop :: [String] -> GHCi ()
 234 stringLoop [] = return ()
 235 stringLoop (s:ss) = do
 236    st <- getGHCiState
 237    case remove_spaces s of
 238         "" -> stringLoop ss
 239         l  -> do quit <- runCommand l
 240                  if quit then return () else stringLoop ss
 241
 242 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 243 readlineLoop :: GHCi ()
 244 readlineLoop = do
 245    st <- getGHCiState
 246    mod <- io (cmGetContext (cmstate st))
 247    l <- io (readline (mod ++ "> "))
 248    case l of
 249         Nothing -> return ()
 250         Just l  ->
 251           case remove_spaces l of
 252             "" -> readlineLoop
 253             l  -> do
 254                   io (addHistory l)
 255                   quit <- runCommand l
 256                   if quit then return () else readlineLoop
 257 #endif
 258
 259 -- Top level exception handler, just prints out the exception
 260 -- and carries on.
 261 runCommand :: String -> GHCi Bool
 262 runCommand c =
 263   ghciHandle ( \exception ->
 264         (case exception of
 265            DynException dyn ->
 266               case fromDynamic dyn of
 267                 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
 268                 Just ghc_ex ->
 269                   case ghc_ex of
 270                     PhaseFailed phase code ->
 271                         io ( putStrLn ("Phase " ++ phase ++ " failed (code "
 272                                         ++ show code ++ ")"))
 273                     Interrupted -> io (putStrLn "Interrupted.")
 274                         -- omit the location for CmdLineError
 275                     CmdLineError s -> io (putStrLn s)
 276                     other -> io (putStrLn (show (ghc_ex :: GhcException)))
 277
 278            other -> io (putStrLn ("*** Exception: " ++ show exception))
 279
 280         ) >> return False
 281      ) $
 282
 283    doCommand c
 284
 285 doCommand (':' : command) = specialCommand command
 286 doCommand stmt
 287    = do timeIt (do stuff <- runStmt stmt; finishEvalExpr stuff)
 288         return False
 289
 290 -- Returns True if the expr was successfully parsed, renamed and
 291 -- typechecked.
 292 runStmt :: String -> GHCi (Maybe [Name])
 293 runStmt stmt
 294  | null (filter (not.isSpace) stmt)
 295  = return Nothing
 296  | otherwise
 297  = do st <- getGHCiState
 298       dflags <- io (getDynFlags)
 299       let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
 300       (new_cmstate, names) <- io (cmRunStmt (cmstate st) dflags' stmt)
 301       setGHCiState st{cmstate = new_cmstate}
 302       return (Just names)
 303
 304 -- possibly print the type and revert CAFs after evaluating an expression
 305 finishEvalExpr Nothing = return False
 306 finishEvalExpr (Just names)
 307  = do b <- isOptionSet ShowType
 308       st <- getGHCiState
 309       when b (mapM_ (showTypeOfName (cmstate st)) names)
 310
 311       b <- isOptionSet RevertCAFs
 312       io (when b revertCAFs)
 313       flushEverything
 314       return True
 315
 316 showTypeOfName :: CmState -> Name -> GHCi ()
 317 showTypeOfName cmstate n
 318    = do maybe_str <- io (cmTypeOfName cmstate n)
 319         case maybe_str of
 320           Nothing  -> return ()
 321           Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
 322
 323 flushEverything :: GHCi ()
 324 flushEverything
 325    = io $ do flush_so <- readIORef flush_stdout
 326              flush_so
 327              flush_se <- readIORef flush_stdout
 328              flush_se
 329              return ()
 330
 331 specialCommand :: String -> GHCi Bool
 332 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 333 specialCommand str = do
 334   let (cmd,rest) = break isSpace str
 335   cmds <- io (readIORef commands)
 336   case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
 337      []      -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
 338                                     ++ shortHelpText) >> return False)
 339      [(_,f)] -> f (dropWhile isSpace rest)
 340      cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++
 341                                       " matches multiple commands (" ++
 342                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
 343                                          ++ ")") >> return False)
 344
 345 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
 346
 347 -----------------------------------------------------------------------------
 348 -- Commands
 349
 350 help :: String -> GHCi ()
 351 help _ = io (putStr helpText)
 352
 353 addModule :: String -> GHCi ()
 354 addModule _ = throwDyn (InstallationError ":add not implemented")
 355
 356 setContext :: String -> GHCi ()
 357 setContext ""
 358   = throwDyn (CmdLineError "syntax: `:m <module>'")
 359 setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
 360   = throwDyn (CmdLineError ("strange looking module name: `" ++ m ++ "'"))
 361 setContext str
 362   = do st <- getGHCiState
 363        new_cmstate <- io (cmSetContext (cmstate st) str)
 364        setGHCiState st{cmstate=new_cmstate}
 365
 366 changeDirectory :: String -> GHCi ()
 367 changeDirectory ('~':d) = do
 368    tilde <- io (getEnv "HOME")  -- will fail if HOME not defined
 369    io (setCurrentDirectory (tilde ++ '/':d))
 370 changeDirectory d = io (setCurrentDirectory d)
 371
 372 defineMacro :: String -> GHCi ()
 373 defineMacro s = do
 374   let (macro_name, definition) = break isSpace s
 375   cmds <- io (readIORef commands)
 376   if (null macro_name)
 377         then throwDyn (CmdLineError "invalid macro name")
 378         else do
 379   if (macro_name `elem` map fst cmds)
 380         then throwDyn (CmdLineError
 381                 ("command `" ++ macro_name ++ "' is already defined"))
 382         else do
 383
 384   -- give the expression a type signature, so we can be sure we're getting
 385   -- something of the right type.
 386   let new_expr = '(' : definition ++ ") :: String -> IO String"
 387
 388   -- compile the expression
 389   st <- getGHCiState
 390   dflags <- io (getDynFlags)
 391   (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
 392   setGHCiState st{cmstate = new_cmstate}
 393   case maybe_hv of
 394      Nothing -> return ()
 395      Just hv -> io (writeIORef commands --
 396                     ((macro_name, keepGoing (runMacro hv)) : cmds))
 397
 398 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
 399 runMacro fun s = do
 400   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 401   stringLoop (lines str)
 402
 403 undefineMacro :: String -> GHCi ()
 404 undefineMacro macro_name = do
 405   cmds <- io (readIORef commands)
 406   if (macro_name `elem` map fst builtin_commands)
 407         then throwDyn (CmdLineError
 408                 ("command `" ++ macro_name ++ "' cannot be undefined"))
 409         else do
 410   if (macro_name `notElem` map fst cmds)
 411         then throwDyn (CmdLineError
 412                 ("command `" ++ macro_name ++ "' not defined"))
 413         else do
 414   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 415
 416 loadModule :: String -> GHCi ()
 417 loadModule path = timeIt (loadModule' path)
 418
 419 loadModule' path = do
 420   state <- getGHCiState
 421   dflags <- io (getDynFlags)
 422   cmstate1 <- io (cmUnload (cmstate state) dflags)
 423   io (revertCAFs)                       -- always revert CAFs on load.
 424   (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
 425   let new_state = state{ cmstate = cmstate2,
 426                          target = Just path
 427                        }
 428   setGHCiState new_state
 429   modulesLoadedMsg ok mods
 430
 431 reloadModule :: String -> GHCi ()
 432 reloadModule "" = do
 433   state <- getGHCiState
 434   case target state of
 435    Nothing -> io (putStr "no current target\n")
 436    Just path
 437       -> do io (revertCAFs)             -- always revert CAFs on reload.
 438             (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
 439             setGHCiState state{ cmstate=new_cmstate }
 440             modulesLoadedMsg ok mods
 441
 442 reloadModule _ = noArgs ":reload"
 443
 444
 445 modulesLoadedMsg ok mods = do
 446   let mod_commas
 447         | null mods = text "none."
 448         | otherwise = hsep (
 449             punctuate comma (map text mods)) <> text "."
 450   case ok of
 451     False ->
 452        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 453     True  ->
 454        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 455
 456
 457 typeOfExpr :: String -> GHCi ()
 458 typeOfExpr str
 459   = do st <- getGHCiState
 460        dflags <- io (getDynFlags)
 461        (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
 462        setGHCiState st{cmstate = new_cmstate}
 463        case maybe_tystr of
 464           Nothing    -> return ()
 465           Just tystr -> io (putStrLn tystr)
 466
 467 quit :: String -> GHCi Bool
 468 quit _ = return True
 469
 470 shellEscape :: String -> GHCi Bool
 471 shellEscape str = io (system str >> return False)
 472
 473 ----------------------------------------------------------------------------
 474 -- Code for `:set'
 475
 476 -- set options in the interpreter.  Syntax is exactly the same as the
 477 -- ghc command line, except that certain options aren't available (-C,
 478 -- -E etc.)
 479 --
 480 -- This is pretty fragile: most options won't work as expected.  ToDo:
 481 -- figure out which ones & disallow them.
 482
 483 setOptions :: String -> GHCi ()
 484 setOptions ""
 485   = do st <- getGHCiState
 486        let opts = options st
 487        io $ putStrLn (showSDoc (
 488               text "options currently set: " <>
 489               if null opts
 490                    then text "none."
 491                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 492            ))
 493 setOptions str
 494   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 495       let (plus_opts, minus_opts)  = partition isPlus (words str)
 496       mapM setOpt plus_opts
 497
 498       -- now, the GHC flags
 499       pkgs_before <- io (readIORef v_Packages)
 500       leftovers   <- io (processArgs static_flags minus_opts [])
 501       pkgs_after  <- io (readIORef v_Packages)
 502
 503       -- update things if the users wants more packages
 504       when (pkgs_before /= pkgs_after) $
 505          newPackages (pkgs_after \\ pkgs_before)
 506
 507       -- then, dynamic flags
 508       io $ do
 509         dyn_flags <- readIORef v_InitDynFlags
 510         writeIORef v_DynFlags dyn_flags
 511         leftovers <- processArgs dynamic_flags leftovers []
 512         dyn_flags <- readIORef v_DynFlags
 513         writeIORef v_InitDynFlags dyn_flags
 514
 515         if (not (null leftovers))
 516                 then throwDyn (CmdLineError ("unrecognised flags: " ++
 517                                                 unwords leftovers))
 518                 else return ()
 519
 520
 521 unsetOptions :: String -> GHCi ()
 522 unsetOptions str
 523   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 524        let opts = words str
 525            (minus_opts, rest1) = partition isMinus opts
 526            (plus_opts, rest2)  = partition isPlus rest1
 527
 528        if (not (null rest2))
 529           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 530           else do
 531
 532        mapM unsetOpt plus_opts
 533
 534        -- can't do GHC flags for now
 535        if (not (null minus_opts))
 536           then throwDyn (CmdLineError "can't unset GHC command-line flags")
 537           else return ()
 538
 539 isMinus ('-':s) = True
 540 isMinus _ = False
 541
 542 isPlus ('+':s) = True
 543 isPlus _ = False
 544
 545 setOpt ('+':str)
 546   = case strToGHCiOpt str of
 547         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 548         Just o  -> setOption o
 549
 550 unsetOpt ('+':str)
 551   = case strToGHCiOpt str of
 552         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 553         Just o  -> unsetOption o
 554
 555 strToGHCiOpt :: String -> (Maybe GHCiOption)
 556 strToGHCiOpt "s" = Just ShowTiming
 557 strToGHCiOpt "t" = Just ShowType
 558 strToGHCiOpt "r" = Just RevertCAFs
 559 strToGHCiOpt _   = Nothing
 560
 561 optToStr :: GHCiOption -> String
 562 optToStr ShowTiming = "s"
 563 optToStr ShowType   = "t"
 564 optToStr RevertCAFs = "r"
 565
 566 newPackages new_pkgs = do
 567   state <- getGHCiState
 568   dflags <- io (getDynFlags)
 569   cmstate1 <- io (cmUnload (cmstate state) dflags)
 570   setGHCiState state{ cmstate = cmstate1, target = Nothing }
 571
 572   io $ do
 573     pkgs <- getPackageInfo
 574     flushPackageCache pkgs
 575
 576     new_pkg_info <- getPackageDetails new_pkgs
 577     mapM_ (linkPackage False) (reverse new_pkg_info)
 578
 579 -----------------------------------------------------------------------------
 580 -- GHCi monad
 581
 582 data GHCiState = GHCiState
 583      {
 584         target         :: Maybe FilePath,
 585         cmstate        :: CmState,
 586         options        :: [GHCiOption]
 587      }
 588
 589 data GHCiOption
 590         = ShowTiming            -- show time/allocs after evaluation
 591         | ShowType              -- show the type of expressions
 592         | RevertCAFs            -- revert CAFs after every evaluation
 593         deriving Eq
 594
 595 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
 596 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
 597
 598 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
 599
 600 instance Monad GHCi where
 601   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
 602   return a  = GHCi $ \s -> return (s,a)
 603
 604 getGHCiState   = GHCi $ \s -> return (s,s)
 605 setGHCiState s = GHCi $ \_ -> return (s,())
 606
 607 isOptionSet :: GHCiOption -> GHCi Bool
 608 isOptionSet opt
 609  = do st <- getGHCiState
 610       return (opt `elem` options st)
 611
 612 setOption :: GHCiOption -> GHCi ()
 613 setOption opt
 614  = do st <- getGHCiState
 615       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 616
 617 unsetOption :: GHCiOption -> GHCi ()
 618 unsetOption opt
 619  = do st <- getGHCiState
 620       setGHCiState (st{ options = filter (/= opt) (options st) })
 621
 622 io m = GHCi $ \s -> m >>= \a -> return (s,a)
 623
 624 -----------------------------------------------------------------------------
 625 -- recursive exception handlers
 626
 627 -- Don't forget to unblock async exceptions in the handler, or if we're
 628 -- in an exception loop (eg. let a = error a in a) the ^C exception
 629 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
 630
 631 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
 632 ghciHandle h (GHCi m) = GHCi $ \s ->
 633    Exception.catch (m s)
 634         (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
 635
 636 ghciUnblock :: GHCi a -> GHCi a
 637 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
 638
 639 -----------------------------------------------------------------------------
 640 -- package loader
 641
 642 -- Left: full path name of a .o file, including trailing .o
 643 -- Right: "unadorned" name of a .DLL/.so
 644 --        e.g.    On unix     "qt"  denotes "libqt.so"
 645 --                On WinDoze  "burble"  denotes "burble.DLL"
 646 --        addDLL is platform-specific and adds the lib/.so/.DLL
 647 --        prefixes plaform-dependently; we don't do that here.
 648 type LibrarySpec
 649    = Either FilePath String
 650
 651 showLS (Left nm)  = "(static) " ++ nm
 652 showLS (Right nm) = "(dynamic) " ++ nm
 653
 654 linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO ()
 655 linkPackages cmdline_lib_specs pkgs
 656    = do sequence_ [ linkPackage (name p `elem` loaded) p | p <- reverse pkgs ]
 657         mapM_ preloadLib cmdline_lib_specs
 658      where
 659         -- packages that are already linked into GHCi
 660         loaded = [ "concurrent", "posix", "text", "util" ]
 661
 662         preloadLib lib_spec
 663            = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
 664                 case lib_spec of
 665                    Left static_ish
 666                       -> do b <- doesFileExist static_ish
 667                             if    not b
 668                              then do putStr "not found.\n"
 669                                      croak
 670                              else do loadObj static_ish
 671                                      putStr "done.\n"
 672                    Right dll_unadorned
 673                       -> do maybe_errmsg <- addDLL dll_unadorned
 674                             if    maybe_errmsg == nullPtr
 675                              then putStr "done.\n"
 676                              else do str <- peekCString maybe_errmsg
 677                                      putStr ("failed (" ++ str ++ ")\n")
 678                                      croak
 679
 680         croak = throwDyn (CmdLineError "user specified .o/.so/.DLL could not be loaded.")
 681
 682
 683 linkPackage :: Bool -> PackageConfig -> IO ()
 684 -- ignore rts and gmp for now (ToDo; better?)
 685 linkPackage loaded_in_ghci pkg
 686    | name pkg `elem` ["rts", "gmp"]
 687    = return ()
 688    | otherwise
 689    = do putStr ("Loading package " ++ name pkg ++ " ... ")
 690         -- For each obj, try obj.o and if that fails, obj.so.
 691         -- Complication: all the .so's must be loaded before any of the .o's.
 692         let dirs      =  library_dirs pkg
 693         let objs      =  hs_libraries pkg ++ extra_libraries pkg
 694         classifieds   <- mapM (locateOneObj dirs) objs
 695
 696         -- Don't load the .so libs if this is a package GHCi is already
 697         -- linked against, because we'll already have the .so linked in.
 698         let (so_libs, obj_libs) = partition isRight classifieds
 699         let sos_first | loaded_in_ghci = obj_libs
 700                       | otherwise      = so_libs ++ obj_libs
 701
 702         mapM loadClassified sos_first
 703         putStr "linking ... "
 704         resolveObjs
 705         putStrLn "done."
 706      where
 707         isRight (Right _) = True
 708         isRight (Left _)  = False
 709
 710 loadClassified :: LibrarySpec -> IO ()
 711 loadClassified (Left obj_absolute_filename)
 712    = do loadObj obj_absolute_filename
 713 loadClassified (Right dll_unadorned)
 714    = do maybe_errmsg <- addDLL dll_unadorned
 715         if    maybe_errmsg == nullPtr
 716          then return ()
 717          else do str <- peekCString maybe_errmsg
 718                  throwDyn (CmdLineError ("can't find .o or .so/.DLL for: "
 719                                        ++ dll_unadorned ++ " (" ++ str ++ ")" ))
 720
 721 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
 722 locateOneObj []     obj
 723    = return (Right obj) -- we assume
 724 locateOneObj (d:ds) obj
 725    = do let path = d ++ '/':obj ++ ".o"
 726         b <- doesFileExist path
 727         if b then return (Left path) else locateOneObj ds obj
 728
 729 -----------------------------------------------------------------------------
 730 -- timing & statistics
 731
 732 timeIt :: GHCi a -> GHCi a
 733 timeIt action
 734   = do b <- isOptionSet ShowTiming
 735        if not b
 736           then action
 737           else do allocs1 <- io $ getAllocations
 738                   time1   <- io $ getCPUTime
 739                   a <- action
 740                   allocs2 <- io $ getAllocations
 741                   time2   <- io $ getCPUTime
 742                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
 743                   return a
 744
 745 foreign import "getAllocations" getAllocations :: IO Int
 746
 747 printTimes :: Int -> Integer -> IO ()
 748 printTimes allocs psecs
 749    = do let secs = (fromIntegral psecs / (10^12)) :: Float
 750             secs_str = showFFloat (Just 2) secs
 751         putStrLn (showSDoc (
 752                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 753                          int allocs <+> text "bytes")))
 754
 755 -----------------------------------------------------------------------------
 756 -- reverting CAFs
 757
 758 foreign import revertCAFs :: IO ()      -- make it "safe", just in case