ghc/compiler/ghci/InteractiveUI.hs

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