add double colon and double arrow symbols (-fglasgow-exts)

[ghc-hetmet.git] / ghc / compiler / main / GHC.hs

diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs
index 2ff5229..e278626 100644 (file)
--- a/ghc/compiler/main/GHC.hs
+++ b/ghc/compiler/main/GHC.hs
@@ -37,7 +37,7 @@ module GHC (
        TypecheckedSource, ParsedSource, RenamedSource,
 
        -- * Inspecting the module structure of the program
-       ModuleGraph, ModSummary(..),
+       ModuleGraph, ModSummary(..), ModLocation(..),
        getModuleGraph,
        isLoaded,
        topSortModuleGraph,
@@ -97,7 +97,7 @@ module GHC (
        -- ** Type constructors
        TyCon, 
        tyConTyVars, tyConDataCons, tyConArity,
-       isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
+       isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
        getSynTyConDefn,
 
        -- ** Type variables
@@ -191,7 +191,7 @@ import Id           ( Id, idType, isImplicitId, isDeadBinder,
 import Var             ( TyVar )
 import TysPrim         ( alphaTyVars )
 import TyCon           ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
-                         isPrimTyCon, tyConArity,
+                         isPrimTyCon, isFunTyCon, tyConArity,
                          tyConTyVars, tyConDataCons, getSynTyConDefn )
 import Class           ( Class, classSCTheta, classTvsFds, classMethods )
 import FunDeps         ( pprFundeps )
@@ -219,31 +219,38 @@ import FiniteMap
 import Panic
 import Digraph
 import Bag             ( unitBag )
-import ErrUtils                ( Severity(..), showPass, Messages, fatalErrorMsg, debugTraceMsg,
+import ErrUtils                ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg,
                          mkPlainErrMsg, printBagOfErrors, printErrorsAndWarnings )
 import qualified ErrUtils
-import PrelNames       ( mAIN )
 import Util
 import StringBuffer    ( StringBuffer, hGetStringBuffer )
 import Outputable
 import SysTools                ( cleanTempFilesExcept )
 import BasicTypes
 import TcType           ( tcSplitSigmaTy, isDictTy )
-import FastString      ( mkFastString )
-
-import Directory        ( getModificationTime, doesFileExist )
-import Maybe           ( isJust, isNothing, fromJust )
-import Maybes          ( orElse, expectJust, mapCatMaybes )
-import List            ( partition, nub )
-import qualified List
-import Monad           ( unless, when )
-import System          ( exitWith, ExitCode(..) )
-import Time            ( ClockTime )
-import EXCEPTION as Exception hiding (handle)
-import DATA_IOREF
-import IO
+import Maybes          ( expectJust, mapCatMaybes )
+
+import Control.Concurrent
+import System.Directory ( getModificationTime, doesFileExist )
+import Data.Maybe      ( isJust, isNothing, fromJust )
+import Data.List       ( partition, nub )
+import qualified Data.List as List
+import Control.Monad   ( unless, when )
+import System.Exit     ( exitWith, ExitCode(..) )
+import System.Time     ( ClockTime )
+import Control.Exception as Exception hiding (handle)
+import Data.IORef
+import System.IO
+import System.IO.Error ( isDoesNotExistError )
+import System.IO.Unsafe        ( unsafePerformIO )
 import Prelude hiding (init)
 
+#if __GLASGOW_HASKELL__ < 600
+import System.IO as System.IO.Error ( try )
+#else
+import System.IO.Error ( try )
+#endif
+
 -- -----------------------------------------------------------------------------
 -- Exception handlers
 
@@ -305,6 +312,8 @@ defaultCleanupHandler dflags inner =
 init :: [String] -> IO [String]
 init args = do
    -- catch ^C
+   main_thread <- myThreadId
+   putMVar interruptTargetThread [main_thread]
    installSignalHandlers
 
    -- Grab the -B option if there is one
@@ -630,7 +639,7 @@ load2 s@(Session ref) how_much mod_graph = do
              when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $
                debugTraceMsg dflags 1 (text ("Warning: output was redirected with -o, " ++
                                              "but no output will be generated\n" ++
-                                             "because there is no " ++ moduleUserString main_mod ++ " module."))
+                                             "because there is no " ++ moduleString main_mod ++ " module."))
 
              -- link everything together
               linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env1)
@@ -1460,7 +1469,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc
        case maybe_buf of
           Just (_,t) -> check_timestamp old_summary location src_fn t
           Nothing    -> do
-               m <- IO.try (getModificationTime src_fn)
+               m <- System.IO.Error.try (getModificationTime src_fn)
                case m of
                   Right t -> check_timestamp old_summary location src_fn t
                   Left e | isDoesNotExistError e -> find_it
@@ -1982,14 +1991,17 @@ runStmt (Session ref) expr
                        writeIORef ref new_hsc_env
                        return (RunOk names)
 
-
--- We run the statement in a "sandbox" to protect the rest of the
--- system from anything the expression might do.  For now, this
--- consists of just wrapping it in an exception handler, but see below
--- for another version.
-
+-- When running a computation, we redirect ^C exceptions to the running
+-- thread.  ToDo: we might want a way to continue even if the target
+-- thread doesn't die when it receives the exception... "this thread
+-- is not responding".
 sandboxIO :: IO a -> IO (Either Exception a)
-sandboxIO thing = Exception.try thing
+sandboxIO thing = do
+  m <- newEmptyMVar
+  ts <- takeMVar interruptTargetThread
+  child <- forkIO (do res <- Exception.try thing; putMVar m res)
+  putMVar interruptTargetThread (child:ts)
+  takeMVar m `finally` modifyMVar_ interruptTargetThread (return.tail)
 
 {-
 -- This version of sandboxIO runs the expression in a completely new