ghc/compiler/ghci/InteractiveUI.hs

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