diff --git a/Util/AtomString.hs b/Util/AtomString.hs --- a/Util/AtomString.hs +++ b/Util/AtomString.hs @@ -114,9 +114,7 @@ fromStringWEHacked str = do either <- tryJust - (\ exception -> case dynExceptions exception of - Nothing -> Nothing -- don't handle this as it's not even a dyn. - Just dyn -> + (\ dyn -> case fromDynamic dyn of Nothing -> Nothing -- not a fromStringError. Just (FromStringExcep mess) -> Just mess @@ -130,7 +128,7 @@ return (toWithError either) fromStringError :: String -> a -fromStringError mess = throwDyn (FromStringExcep mess) +fromStringError mess = throw $ toDyn (FromStringExcep mess) newtype FromStringExcep = FromStringExcep String deriving (Typeable) diff --git a/Util/Bytes.hs b/Util/Bytes.hs --- a/Util/Bytes.hs +++ b/Util/Bytes.hs @@ -80,9 +80,7 @@ import System.IO import System.IO.Error -import Control.Exception(Exception(IOException),throw) - - +import Control.Exception (throw) -- ---------------------------------------------------------------------- -- The datatypes @@ -175,11 +173,10 @@ throwEOF handle = do let - eofError = IOException ( + eofError = mkIOError eofErrorType "BinaryIO" (Just handle) Nothing - ) throw eofError -- ---------------------------------------------------------------------- diff --git a/Util/Computation.hs b/Util/Computation.hs --- a/Util/Computation.hs +++ b/Util/Computation.hs @@ -1,4 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | -- Description : Miscellaneous Monads, in particular 'Computation.WithError'. @@ -117,7 +118,7 @@ -- Type Definitions -- -------------------------------------------------------------------------- -type Answer a = Either Exception a +type Answer a = Either SomeException a -- -------------------------------------------------------------------------- -- Done @@ -150,7 +151,7 @@ propagate (Right v) = return v catchall :: IO a -> IO a -> IO a -catchall c1 c2 = Control.Exception.catch c1 (\ _ -> c2) +catchall c1 c2 = Control.Exception.catch c1 (\ (_ :: SomeException) -> c2) tryUntilOK :: IO a -> IO a tryUntilOK c = catchall c (tryUntilOK c) @@ -285,7 +286,7 @@ v <- act return (Value v) -exceptionToError :: (Exception -> Maybe String) -> IO a -> IO (WithError a) +exceptionToError :: Exception e => (e -> Maybe String) -> IO a -> IO (WithError a) exceptionToError testFn action = catchJust testFn diff --git a/Util/Debug.hs b/Util/Debug.hs --- a/Util/Debug.hs +++ b/Util/Debug.hs @@ -125,7 +125,7 @@ Left error -> do alwaysDebug ("AlwaysDebug.debug caught "++mess) - throw error + throw (error :: SomeException) Right success -> return success (@@:) :: String -> IO a -> IO a @@ -140,7 +140,7 @@ wrapErrorIO :: String -> a -> IO a wrapErrorIO str value = - Control.Exception.catchJust errorCalls (value `seq` return value) - (\ mess -> error (str++":"++mess)) + Control.Exception.catch (value `seq` return value) + (\ mess -> error (str ++ ":"++ show (mess :: ErrorCall))) diff --git a/Util/ExtendedPrelude.hs b/Util/ExtendedPrelude.hs --- a/Util/ExtendedPrelude.hs +++ b/Util/ExtendedPrelude.hs @@ -511,7 +511,7 @@ } deriving (Typeable) mkBreakFn :: ObjectID -> BreakFn -mkBreakFn id mess = throwDyn (FallOutExcep {fallOutId = id,mess = mess}) +mkBreakFn id mess = throw $ toDyn (FallOutExcep {fallOutId = id,mess = mess}) newFallOut :: IO (ObjectID,IO a -> IO (Either String a)) @@ -523,12 +523,8 @@ return (id,tryFn) -isOurFallOut :: ObjectID -> Exception -> Maybe String -isOurFallOut oId exception = - case dynExceptions exception of - Nothing -> Nothing - -- don't handle this as it's not even a dyn. - Just dyn -> +isOurFallOut :: ObjectID -> Dyn -> Maybe String +isOurFallOut oId dyn = case fromDynamic dyn of Nothing -> Nothing -- not a fallout. Just fallOutExcep -> if fallOutId fallOutExcep /= oId @@ -552,7 +548,7 @@ do (objectId,catchFn) <- newGeneralFallOut let - breakFn a = throwDyn (GeneralFallOutExcep { + breakFn a = throw $ toDyn (GeneralFallOutExcep { generalFallOutId = objectId,a=a}) return (GeneralBreakFn breakFn,catchFn) @@ -569,10 +565,7 @@ let tryFn act = tryJust - (\ exception -> case dynExceptions exception of - Nothing -> Nothing - -- don't handle this as it's not even a dyn. - Just dyn -> + (\ dyn -> case fromDynamic dyn of Nothing -> Nothing -- not a fallout, or not the right type of a. @@ -593,16 +586,14 @@ -- General catch function for our exceptions. -- ------------------------------------------------------------------------ -ourExcepToMess :: Exception -> Maybe String -ourExcepToMess excep = case dynExceptions excep of - Nothing -> Nothing - Just dyn -> +ourExcepToMess :: Dyn -> Maybe String +ourExcepToMess dyn = case fromDynamic dyn of Just fallOut -> Just ("Fall-out exception " ++ show (fallOutId fallOut) ++ ": " ++ mess fallOut) Nothing -> Just ("Mysterious dynamic exception " ++ show dyn) -showException2 :: Exception -> String +showException2 :: Dyn -> String showException2 exception = fromMaybe (show exception) (ourExcepToMess exception) diff --git a/Util/IOExtras.hs b/Util/IOExtras.hs --- a/Util/IOExtras.hs +++ b/Util/IOExtras.hs @@ -22,9 +22,6 @@ simpleModifyIORef, -- :: IORef a -> (a -> (a,b)) -> IO b -- carry out a pure modification of an IORef. - -- From ghc5.05 onwards, we should be able to use atomicModifyIORef - -- for this. - ) where import System.IO.Error @@ -46,11 +43,8 @@ catchGeneral discriminator action = do result <- tryJust - (\ excep -> - case ioErrors excep of - Nothing -> Nothing - Just ioError -> - if discriminator ioError + (\ ioErr -> + if discriminator ioErr then Just () else @@ -61,8 +55,8 @@ Left () -> return Nothing Right success -> return (Just success) -catchErrorCalls :: IO a -> IO (Either String a) -catchErrorCalls action = tryJust errorCalls action +catchErrorCalls :: IO a -> IO (Either ErrorCall a) +catchErrorCalls = Control.Exception.try hGetLineR :: Read a => Handle -> IO a hGetLineR handle = diff --git a/Util/Registry.hs b/Util/Registry.hs --- a/Util/Registry.hs +++ b/Util/Registry.hs @@ -460,7 +460,7 @@ Left error -> do putVal lockedRegistry from valInOpt - Control.Exception.throw error + Control.Exception.throw (error :: SomeException) Right (valOutOpt,extra) -> do putVal lockedRegistry from valOutOpt diff --git a/Util/Thread.hs b/Util/Thread.hs --- a/Util/Thread.hs +++ b/Util/Thread.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -20,7 +21,7 @@ -- ALMOST identical with standard action. -- The differences are (a) that it takes an extra string argument -- (which goes first); (b) if the thread fails because of - -- "BlockedOnDeadMVar" nothing is printed, but we output a + -- "BlockedOnMVar" nothing is printed, but we output a -- message to "debug" which includes the label. -- NB. This function no longer seems to be necessary in recent -- versions of GHC (current is 6.02.1) so please don't use it. @@ -29,7 +30,7 @@ -- This wraps an action so that if killed nothing is printed and it -- just returns. This is useful for Expect and other things which -- get rid of a redundant thread by killing it. - -- Now changed so that it also prints nothing for BlockedOnDeadMVar + -- Now changed so that it also prints nothing for BlockedOnMVar -- delay thread execution @@ -105,10 +106,15 @@ do result <- tryJust - (\ exception -> case exception of - AsyncException ThreadKilled -> Just () - BlockedOnDeadMVar -> Just () - _ -> Nothing + (\ exception -> case fromException exception of + Just ThreadKilled -> Just () + _ -> case fromException exception of +#if __GLASGOW_HASKELL__ >= 612 + Just BlockedIndefinitelyOnMVar -> Just () +#else + Just BlockedOnDeadMVar -> Just () +#endif + _ -> Nothing ) action case result of @@ -133,8 +139,12 @@ newAction = do error <- tryJust - (\ exception -> case exception of - BlockedOnDeadMVar -> Just () + (\ exception -> case fromException exception of +#if __GLASGOW_HASKELL__ >= 612 + Just BlockedIndefinitelyOnMVar -> Just () +#else + Just BlockedOnDeadMVar -> Just () +#endif _ -> Nothing ) action @@ -174,7 +184,7 @@ mapM takeMVar mVars -- this version is careful to propagate exceptions, at a slight cost. -mapMConcurrentExcep :: (a -> IO b) -> [a] -> IO [b] +mapMConcurrentExcep :: forall a b . (a -> IO b) -> [a] -> IO [b] mapMConcurrentExcep mapFn [] = return [] mapMConcurrentExcep mapFn [a] = do @@ -182,7 +192,7 @@ return [b] mapMConcurrentExcep mapFn as = do - (mVars :: [MVar (Either Exception b)]) <- mapM + (mVars :: [MVar (Either SomeException b)]) <- mapM (\ a -> do mVar <- newEmptyMVar diff --git a/uni-util.cabal b/uni-util.cabal --- a/uni-util.cabal +++ b/uni-util.cabal @@ -1,5 +1,5 @@ name: uni-util -version: 2.2.0.0 +version: 2.2.1.0 build-type: Simple license: LGPL license-file: LICENSE @@ -14,7 +14,7 @@ They are kept for compatibility reason and put on hackage to ease installation. cabal-version: >= 1.4 -Tested-With: GHC==6.8.3, GHC==6.10.4, GHC==6.12.3 +Tested-With: GHC==6.10.4, GHC==6.12.3 extra-source-files: include/new_object.h include/default_options.h @@ -45,7 +45,7 @@ include-dirs: include c-sources: new_object.c, default_options.c - build-depends: base >= 3 && < 4, parsec < 3, mtl, directory, + build-depends: base >= 4 && < 5, parsec < 3, mtl, directory, network, containers, bytestring, array, old-time if flag(base4) @@ -57,7 +57,4 @@ if os(windows) cpp-options: -DWINDOWS - if impl(ghc < 6.10) - extensions: PatternSignatures - else - ghc-options: -fwarn-unused-imports -fno-warn-warnings-deprecations + ghc-options: -fwarn-unused-imports -fno-warn-warnings-deprecations