[project @ 2002-12-12 13:21:46 by ross]

[ghc-hetmet.git] / ghc / compiler / ghci / InteractiveUI.hs

diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs
index 8660650..5801a38 100644 (file)
--- a/ghc/compiler/ghci/InteractiveUI.hs
+++ b/ghc/compiler/ghci/InteractiveUI.hs
@@ -1,6 +1,6 @@
 {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
 -----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.134 2002/09/13 15:02:32 simonpj Exp $
+-- $Id: InteractiveUI.hs,v 1.139 2002/12/12 13:21:46 ross Exp $
 --
 -- GHC Interactive User Interface
 --
@@ -24,7 +24,7 @@ import DriverFlags
 import DriverState
 import DriverUtil      ( remove_spaces, handle )
 import Linker          ( initLinker, showLinkerState, linkLibraries )
-import Finder          ( flushPackageCache )
+import Finder          ( flushFinderCache )
 import Util
 import Id              ( isRecordSelector, recordSelectorFieldLabel, 
                          isDataConWrapId, isDataConId, idName )
@@ -37,6 +37,7 @@ import Name           ( Name, isHomePackageName, nameSrcLoc, nameOccName,
                          NamedThing(..) )
 import OccName         ( isSymOcc )
 import BasicTypes      ( defaultFixity, SuccessFlag(..) )
+import Packages
 import Outputable
 import CmdLineOpts     ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags,
                          restoreDynFlags, dopt_unset )
@@ -74,6 +75,8 @@ import Foreign                ( nullPtr )
 import Foreign.C.String        ( CString, peekCString, withCString )
 import Data.IORef      ( IORef, newIORef, readIORef, writeIORef )
 
+import GHC.Posix       ( setNonBlockingFD )
+
 -----------------------------------------------------------------------------
 
 ghciWelcomeMsg = "\ 
@@ -154,11 +157,8 @@ interactiveUI cmstate paths cmdline_objs = do
 
    dflags <- getDynFlags
 
-   -- Link in the available packages
+       -- packages are loaded "on-demand" now
    initLinker
-       --      Now that demand-loading works, we don't really need to pre-load the packages
-       --   pkgs <- getPackages
-       --   linkPackages dflags  pkgs
    linkLibraries dflags cmdline_objs
 
        -- Initialise buffering for the *interpreted* I/O system
@@ -295,7 +295,7 @@ fileLoop hdl prompt = do
    l <- io (IO.try (hGetLine hdl))
    case l of
        Left e | isEOFError e -> return ()
-              | otherwise    -> throw e
+              | otherwise    -> io (ioError e)
        Right l -> 
          case remove_spaces l of
            "" -> fileLoop hdl prompt
@@ -319,7 +319,10 @@ readlineLoop = do
    cmstate <- getCmState
    (mod,imports) <- io (cmGetContext cmstate)
    io yield
-   l <- io (readline (mkPrompt mod imports))
+   l <- io (readline (mkPrompt mod imports)
+               `finally` setNonBlockingFD 0)
+               -- readline sometimes puts stdin into blocking mode,
+               -- so we need to put it back for the IO library
    case l of
        Nothing -> return ()
        Just l  ->
@@ -331,16 +334,22 @@ readlineLoop = do
                  if quit then return () else readlineLoop
 #endif
 
--- Top level exception handler, just prints out the exception 
--- and carries on.
 runCommand :: String -> GHCi Bool
-runCommand c = 
-  ghciHandle ( \exception -> do
-               flushInterpBuffers
-               showException exception
-               return False
-            ) $
-  doCommand c
+runCommand c = ghciHandle handler (doCommand c)
+
+-- This is the exception handler for exceptions generated by the
+-- user's code; it normally just prints out the exception.  The
+-- handler must be recursive, in case showing the exception causes
+-- more exceptions to be raised.
+--
+-- Bugfix: if the user closed stdout or stderr, the flushing will fail,
+-- raising another exception.  We therefore don't put the recursive
+-- handler arond the flushing operation, so if stderr is closed
+-- GHCi will just die gracefully rather than going into an infinite loop.
+handler :: Exception -> GHCi Bool
+handler exception = do
+  flushInterpBuffers
+  ghciHandle handler (showException exception >> return False)
 
 showException (DynException dyn) =
   case fromDynamic dyn of
@@ -829,13 +838,20 @@ setOptions wds =
       pkgs_after  <- io (readIORef v_Packages)
 
       -- update things if the users wants more packages
-      when (pkgs_before /= pkgs_after) $
-        newPackages (pkgs_after \\ pkgs_before)
+      let new_packages = pkgs_after \\ pkgs_before
+      when (not (null new_packages)) $
+        newPackages new_packages
+
+      -- don't forget about the extra command-line flags from the 
+      -- extra_ghc_opts fields in the new packages
+      new_package_details <- io (getPackageDetails new_packages)
+      let pkg_extra_opts = concatMap extra_ghc_opts new_package_details
+      pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts [])
 
       -- then, dynamic flags
       io $ do 
        restoreDynFlags
-        leftovers <- processArgs dynamic_flags leftovers []
+        leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) []
        saveDynFlags
 
         if (not (null leftovers))
@@ -894,10 +910,6 @@ newPackages new_pkgs = do  -- The new packages are already in v_Packages
   dflags   <- io getDynFlags
   cmstate1 <- io (cmUnload (cmstate state) dflags)
   setGHCiState state{ cmstate = cmstate1, targets = [] }
-
-  io $ do pkgs <- getPackageInfo
-         flushPackageCache pkgs
-
   setContextAfterLoad []
 
 -----------------------------------------------------------------------------
@@ -1003,7 +1015,7 @@ io m = GHCi { unGHCi = \s -> m >>= return }
 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
 ghciHandle h (GHCi m) = GHCi $ \s -> 
    Exception.catch (m s) 
-       (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
+       (\e -> unGHCi (ghciUnblock (h e)) s)
 
 ghciUnblock :: GHCi a -> GHCi a
 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
@@ -1035,14 +1047,6 @@ printTimes allocs psecs
                         int allocs <+> text "bytes")))
 
 -----------------------------------------------------------------------------
--- utils
-
-looksLikeModuleName [] = False
-looksLikeModuleName (c:cs) = isUpper c && all isAlphaNumEx cs
-
-isAlphaNumEx c = isAlphaNum c || c == '_' || c == '.'
-
------------------------------------------------------------------------------
 -- reverting CAFs
        
 revertCAFs :: IO ()