ghc/compiler/ghci/InteractiveUI.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: InteractiveUI.hs,v 1.78 2001/06/27 11:17:47 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 -> [FilePath] -> [LibrarySpec] -> IO ()
 117 interactiveUI cmstate paths 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 paths of
 128              [] -> return (cmstate, True, [])
 129              _  -> cmLoadModule cmstate paths
 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{ targets = paths,
 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 path = do
 364   state <- getGHCiState
 365   dflags <- io (getDynFlags)
 366   io (revertCAFs)                       -- always revert CAFs on load/add.
 367   let new_targets = path : targets state
 368   (cmstate1, ok, mods) <- io (cmLoadModule (cmstate state) new_targets)
 369   setGHCiState state{ cmstate = cmstate1, targets = new_targets }
 370   modulesLoadedMsg ok mods
 371
 372 setContext :: String -> GHCi ()
 373 setContext ""
 374   = throwDyn (CmdLineError "syntax: `:m <module>'")
 375 setContext m | not (isUpper (head m)) || not (all isAlphaNumEx (tail m))
 376   = throwDyn (CmdLineError ("strange looking module name: `" ++ m ++ "'"))
 377     where
 378        isAlphaNumEx c = isAlphaNum c || c == '_'
 379 setContext str
 380   = do st <- getGHCiState
 381        new_cmstate <- io (cmSetContext (cmstate st) str)
 382        setGHCiState st{cmstate=new_cmstate}
 383
 384 changeDirectory :: String -> GHCi ()
 385 changeDirectory ('~':d) = do
 386    tilde <- io (getEnv "HOME")  -- will fail if HOME not defined
 387    io (setCurrentDirectory (tilde ++ '/':d))
 388 changeDirectory d = io (setCurrentDirectory d)
 389
 390 defineMacro :: String -> GHCi ()
 391 defineMacro s = do
 392   let (macro_name, definition) = break isSpace s
 393   cmds <- io (readIORef commands)
 394   if (null macro_name)
 395         then throwDyn (CmdLineError "invalid macro name")
 396         else do
 397   if (macro_name `elem` map fst cmds)
 398         then throwDyn (CmdLineError
 399                 ("command `" ++ macro_name ++ "' is already defined"))
 400         else do
 401
 402   -- give the expression a type signature, so we can be sure we're getting
 403   -- something of the right type.
 404   let new_expr = '(' : definition ++ ") :: String -> IO String"
 405
 406   -- compile the expression
 407   st <- getGHCiState
 408   dflags <- io getDynFlags
 409   (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
 410   setGHCiState st{cmstate = new_cmstate}
 411   case maybe_hv of
 412      Nothing -> return ()
 413      Just hv -> io (writeIORef commands --
 414                     ((macro_name, keepGoing (runMacro hv)) : cmds))
 415
 416 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
 417 runMacro fun s = do
 418   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 419   stringLoop (lines str)
 420
 421 undefineMacro :: String -> GHCi ()
 422 undefineMacro macro_name = do
 423   cmds <- io (readIORef commands)
 424   if (macro_name `elem` map fst builtin_commands)
 425         then throwDyn (CmdLineError
 426                 ("command `" ++ macro_name ++ "' cannot be undefined"))
 427         else do
 428   if (macro_name `notElem` map fst cmds)
 429         then throwDyn (CmdLineError
 430                 ("command `" ++ macro_name ++ "' not defined"))
 431         else do
 432   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 433
 434 loadModule :: String -> GHCi ()
 435 loadModule path = timeIt (loadModule' path)
 436
 437 loadModule' path = do
 438   state <- getGHCiState
 439   dflags <- io getDynFlags
 440   cmstate1 <- io (cmUnload (cmstate state) dflags)
 441   setGHCiState state{ cmstate = cmstate1, targets = [] }
 442   io (revertCAFs)                       -- always revert CAFs on load.
 443   (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 [path])
 444   setGHCiState state{ cmstate = cmstate2, targets = [path] }
 445   modulesLoadedMsg ok mods
 446
 447 reloadModule :: String -> GHCi ()
 448 reloadModule "" = do
 449   state <- getGHCiState
 450   case targets state of
 451    [] -> io (putStr "no current target\n")
 452    paths
 453       -> do io (revertCAFs)             -- always revert CAFs on reload.
 454             (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) paths)
 455             setGHCiState state{ cmstate=new_cmstate }
 456             modulesLoadedMsg ok mods
 457
 458 reloadModule _ = noArgs ":reload"
 459
 460
 461 modulesLoadedMsg ok mods = do
 462   let mod_commas
 463         | null mods = text "none."
 464         | otherwise = hsep (
 465             punctuate comma (map text mods)) <> text "."
 466   case ok of
 467     False ->
 468        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 469     True  ->
 470        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 471
 472
 473 typeOfExpr :: String -> GHCi ()
 474 typeOfExpr str
 475   = do st <- getGHCiState
 476        dflags <- io getDynFlags
 477        (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
 478        setGHCiState st{cmstate = new_cmstate}
 479        case maybe_tystr of
 480           Nothing    -> return ()
 481           Just tystr -> io (putStrLn tystr)
 482
 483 quit :: String -> GHCi Bool
 484 quit _ = return True
 485
 486 shellEscape :: String -> GHCi Bool
 487 shellEscape str = io (system str >> return False)
 488
 489 ----------------------------------------------------------------------------
 490 -- Code for `:set'
 491
 492 -- set options in the interpreter.  Syntax is exactly the same as the
 493 -- ghc command line, except that certain options aren't available (-C,
 494 -- -E etc.)
 495 --
 496 -- This is pretty fragile: most options won't work as expected.  ToDo:
 497 -- figure out which ones & disallow them.
 498
 499 setOptions :: String -> GHCi ()
 500 setOptions ""
 501   = do st <- getGHCiState
 502        let opts = options st
 503        io $ putStrLn (showSDoc (
 504               text "options currently set: " <>
 505               if null opts
 506                    then text "none."
 507                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 508            ))
 509 setOptions str
 510   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 511       let (plus_opts, minus_opts)  = partition isPlus (words str)
 512       mapM setOpt plus_opts
 513
 514       -- now, the GHC flags
 515       pkgs_before <- io (readIORef v_Packages)
 516       leftovers   <- io (processArgs static_flags minus_opts [])
 517       pkgs_after  <- io (readIORef v_Packages)
 518
 519       -- update things if the users wants more packages
 520       when (pkgs_before /= pkgs_after) $
 521          newPackages (pkgs_after \\ pkgs_before)
 522
 523       -- then, dynamic flags
 524       io $ do
 525         restoreDynFlags
 526         leftovers <- processArgs dynamic_flags leftovers []
 527         saveDynFlags
 528
 529         if (not (null leftovers))
 530                 then throwDyn (CmdLineError ("unrecognised flags: " ++
 531                                                 unwords leftovers))
 532                 else return ()
 533
 534
 535 unsetOptions :: String -> GHCi ()
 536 unsetOptions str
 537   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 538        let opts = words str
 539            (minus_opts, rest1) = partition isMinus opts
 540            (plus_opts, rest2)  = partition isPlus rest1
 541
 542        if (not (null rest2))
 543           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 544           else do
 545
 546        mapM unsetOpt plus_opts
 547
 548        -- can't do GHC flags for now
 549        if (not (null minus_opts))
 550           then throwDyn (CmdLineError "can't unset GHC command-line flags")
 551           else return ()
 552
 553 isMinus ('-':s) = True
 554 isMinus _ = False
 555
 556 isPlus ('+':s) = True
 557 isPlus _ = False
 558
 559 setOpt ('+':str)
 560   = case strToGHCiOpt str of
 561         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 562         Just o  -> setOption o
 563
 564 unsetOpt ('+':str)
 565   = case strToGHCiOpt str of
 566         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 567         Just o  -> unsetOption o
 568
 569 strToGHCiOpt :: String -> (Maybe GHCiOption)
 570 strToGHCiOpt "s" = Just ShowTiming
 571 strToGHCiOpt "t" = Just ShowType
 572 strToGHCiOpt "r" = Just RevertCAFs
 573 strToGHCiOpt _   = Nothing
 574
 575 optToStr :: GHCiOption -> String
 576 optToStr ShowTiming = "s"
 577 optToStr ShowType   = "t"
 578 optToStr RevertCAFs = "r"
 579
 580 newPackages new_pkgs = do
 581   state <- getGHCiState
 582   dflags <- io getDynFlags
 583   cmstate1 <- io (cmUnload (cmstate state) dflags)
 584   setGHCiState state{ cmstate = cmstate1, targets = [] }
 585
 586   io $ do
 587     pkgs <- getPackageInfo
 588     flushPackageCache pkgs
 589
 590     new_pkg_info <- getPackageDetails new_pkgs
 591     mapM_ (linkPackage False) (reverse new_pkg_info)
 592
 593 -----------------------------------------------------------------------------
 594 -- GHCi monad
 595
 596 data GHCiState = GHCiState
 597      {
 598         targets        :: [FilePath],
 599         cmstate        :: CmState,
 600         options        :: [GHCiOption]
 601      }
 602
 603 data GHCiOption
 604         = ShowTiming            -- show time/allocs after evaluation
 605         | ShowType              -- show the type of expressions
 606         | RevertCAFs            -- revert CAFs after every evaluation
 607         deriving Eq
 608
 609 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
 610 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
 611
 612 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
 613
 614 startGHCi :: GHCi a -> GHCiState -> IO a
 615 startGHCi g state = do ref <- newIORef state; unGHCi g ref
 616
 617 instance Monad GHCi where
 618   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
 619   return a  = GHCi $ \s -> return a
 620
 621 getGHCiState   = GHCi $ \r -> readIORef r
 622 setGHCiState s = GHCi $ \r -> writeIORef r s
 623
 624 isOptionSet :: GHCiOption -> GHCi Bool
 625 isOptionSet opt
 626  = do st <- getGHCiState
 627       return (opt `elem` options st)
 628
 629 setOption :: GHCiOption -> GHCi ()
 630 setOption opt
 631  = do st <- getGHCiState
 632       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 633
 634 unsetOption :: GHCiOption -> GHCi ()
 635 unsetOption opt
 636  = do st <- getGHCiState
 637       setGHCiState (st{ options = filter (/= opt) (options st) })
 638
 639 io m = GHCi $ \s -> m >>= \a -> return a
 640
 641 -----------------------------------------------------------------------------
 642 -- recursive exception handlers
 643
 644 -- Don't forget to unblock async exceptions in the handler, or if we're
 645 -- in an exception loop (eg. let a = error a in a) the ^C exception
 646 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
 647
 648 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
 649 ghciHandle h (GHCi m) = GHCi $ \s ->
 650    Exception.catch (m s)
 651         (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
 652
 653 ghciUnblock :: GHCi a -> GHCi a
 654 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
 655
 656 -----------------------------------------------------------------------------
 657 -- package loader
 658
 659 -- Left: full path name of a .o file, including trailing .o
 660 -- Right: "unadorned" name of a .DLL/.so
 661 --        e.g.    On unix     "qt"  denotes "libqt.so"
 662 --                On WinDoze  "burble"  denotes "burble.DLL"
 663 --        addDLL is platform-specific and adds the lib/.so/.DLL
 664 --        suffixes platform-dependently; we don't do that here.
 665 --
 666 -- For dynamic objects only, try to find the object file in all the
 667 -- directories specified in v_Library_Paths before giving up.
 668
 669 type LibrarySpec
 670    = Either FilePath String
 671
 672 showLS (Left nm)  = "(static) " ++ nm
 673 showLS (Right nm) = "(dynamic) " ++ nm
 674
 675 linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO ()
 676 linkPackages cmdline_lib_specs pkgs
 677    = do sequence_ [ linkPackage (name p `elem` loaded) p | p <- reverse pkgs ]
 678         lib_paths <- readIORef v_Library_paths
 679         mapM_ (preloadLib lib_paths) cmdline_lib_specs
 680      where
 681         -- packages that are already linked into GHCi
 682         loaded = [ "gmp", "rts", "std", "concurrent", "posix", "text", "util" ]
 683
 684         preloadLib :: [String] -> LibrarySpec -> IO ()
 685         preloadLib lib_paths lib_spec
 686            = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
 687                 case lib_spec of
 688                    Left static_ish
 689                       -> do b <- preload_static lib_paths static_ish
 690                             putStrLn (if b then "done" else "not found")
 691                    Right dll_unadorned
 692                       -> -- We add "" to the set of paths to try, so that
 693                          -- if none of the real paths match, we force addDLL
 694                          -- to look in the default dynamic-link search paths.
 695                          do b <- preload_dynamic (lib_paths++[""]) dll_unadorned
 696                             when (not b) (cantFind lib_paths lib_spec)
 697                             putStrLn "done"
 698
 699         cantFind :: [String] -> LibrarySpec -> IO ()
 700         cantFind paths spec
 701            = do putStr ("failed.\nCan't find " ++ showLS spec
 702                         ++ " in directories:\n"
 703                         ++ unlines (map ("   "++) paths) )
 704                 give_up
 705
 706         -- not interested in the paths in the static case.
 707         preload_static paths name
 708            = do b <- doesFileExist name
 709                 if not b then return False
 710                          else loadObj name >> return True
 711
 712         preload_dynamic [] name
 713            = return False
 714         preload_dynamic (path:paths) rootname
 715            = do maybe_errmsg <- addDLL path rootname
 716                 if    maybe_errmsg /= nullPtr
 717                  then preload_dynamic paths rootname
 718                  else return True
 719
 720         give_up
 721            = (throwDyn . CmdLineError)
 722                 "user specified .o/.so/.DLL could not be loaded."
 723
 724
 725 linkPackage :: Bool -> PackageConfig -> IO ()
 726 -- ignore rts and gmp for now (ToDo; better?)
 727 linkPackage loaded_in_ghci pkg
 728    | name pkg `elem` ["rts", "gmp"]
 729    = return ()
 730    | otherwise
 731    = do putStr ("Loading package " ++ name pkg ++ " ... ")
 732         -- For each obj, try obj.o and if that fails, obj.so.
 733         -- Complication: all the .so's must be loaded before any of the .o's.
 734         let dirs      =  library_dirs pkg
 735         let objs      =  hs_libraries pkg ++ extra_libraries pkg
 736         classifieds   <- mapM (locateOneObj dirs) objs
 737
 738         -- Don't load the .so libs if this is a package GHCi is already
 739         -- linked against, because we'll already have the .so linked in.
 740         let (so_libs, obj_libs) = partition isRight classifieds
 741         let sos_first | loaded_in_ghci = obj_libs
 742                       | otherwise      = so_libs ++ obj_libs
 743
 744         mapM loadClassified sos_first
 745         putStr "linking ... "
 746         resolveObjs
 747         putStrLn "done."
 748      where
 749         isRight (Right _) = True
 750         isRight (Left _)  = False
 751
 752 loadClassified :: LibrarySpec -> IO ()
 753 loadClassified (Left obj_absolute_filename)
 754    = do loadObj obj_absolute_filename
 755 loadClassified (Right dll_unadorned)
 756    = do maybe_errmsg <- addDLL "" dll_unadorned -- doesn't seem right to me
 757         if    maybe_errmsg == nullPtr
 758          then return ()
 759          else do str <- peekCString maybe_errmsg
 760                  throwDyn (CmdLineError ("can't load .so/.DLL for: "
 761                                        ++ dll_unadorned ++ " (" ++ str ++ ")" ))
 762
 763 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
 764 locateOneObj []     obj
 765    = return (Right obj) -- we assume
 766 locateOneObj (d:ds) obj
 767    = do let path = d ++ '/':obj ++ ".o"
 768         b <- doesFileExist path
 769         if b then return (Left path) else locateOneObj ds obj
 770
 771 -----------------------------------------------------------------------------
 772 -- timing & statistics
 773
 774 timeIt :: GHCi a -> GHCi a
 775 timeIt action
 776   = do b <- isOptionSet ShowTiming
 777        if not b
 778           then action
 779           else do allocs1 <- io $ getAllocations
 780                   time1   <- io $ getCPUTime
 781                   a <- action
 782                   allocs2 <- io $ getAllocations
 783                   time2   <- io $ getCPUTime
 784                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
 785                   return a
 786
 787 foreign import "getAllocations" getAllocations :: IO Int
 788
 789 printTimes :: Int -> Integer -> IO ()
 790 printTimes allocs psecs
 791    = do let secs = (fromIntegral psecs / (10^12)) :: Float
 792             secs_str = showFFloat (Just 2) secs
 793         putStrLn (showSDoc (
 794                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 795                          int allocs <+> text "bytes")))
 796
 797 -----------------------------------------------------------------------------
 798 -- reverting CAFs
 799
 800 foreign import revertCAFs :: IO ()      -- make it "safe", just in case