ghc/compiler/ghci/InteractiveUI.hs

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