diff --git a/.gitignore b/.gitignore index 62c8935..3a93640 100644 --- a/.gitignore +++ b/.gitignore @@ -1 +1,5 @@ -.idea/ \ No newline at end of file +.idea/ +hls.exe +.local +dist-newstyle +cabal.project.local \ No newline at end of file diff --git a/Data/Pool.hs b/Data/Pool.hs index 7b44d5a..8405001 100644 --- a/Data/Pool.hs +++ b/Data/Pool.hs @@ -1,9 +1,5 @@ {-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards, ScopedTypeVariables, RankNTypes, DeriveDataTypeable #-} -#if MIN_VERSION_monad_control(0,3,0) -{-# LANGUAGE FlexibleContexts #-} -#endif - #if !MIN_VERSION_base(4,3,0) {-# LANGUAGE RankNTypes #-} #endif @@ -57,24 +53,7 @@ import Data.Typeable (Typeable) import GHC.Conc.Sync (labelThread) import qualified Control.Exception as E import qualified Data.Vector as V - -#if MIN_VERSION_monad_control(0,3,0) -import Control.Monad.Trans.Control (MonadBaseControl, control) -import Control.Monad.Base (liftBase) -#else -import Control.Monad.IO.Control (MonadControlIO, controlIO) -import Control.Monad.IO.Class (liftIO) -#define control controlIO -#define liftBase liftIO -#endif - -#if MIN_VERSION_base(4,3,0) -import Control.Exception (mask) -#else --- Don't do any async exception protection for older GHCs. -mask :: ((forall a. IO a -> IO a) -> IO b) -> IO b -mask f = f id -#endif +import UnliftIO (MonadUnliftIO, mask, withRunInIO) -- | A single resource pool entry. data Entry a = Entry { @@ -281,15 +260,9 @@ purgeLocalPool destroy LocalPool{..} = do -- destroy a pooled resource, as doing so will almost certainly cause -- a subsequent user (who expects the resource to be valid) to throw -- an exception. -withResource :: -#if MIN_VERSION_monad_control(0,3,0) - (MonadBaseControl IO m) -#else - (MonadControlIO m) -#endif - => Pool a -> (a -> m b) -> m b +withResource :: MonadUnliftIO m => Pool a -> (a -> m b) -> m b {-# SPECIALIZE withResource :: Pool a -> (a -> IO b) -> IO b #-} -withResource pool act = control $ \runInIO -> mask $ \restore -> do +withResource pool act = withRunInIO $ \runInIO -> mask $ \restore -> do (resource, local) <- takeResource pool ret <- restore (runInIO (act resource)) `onException` destroyResource pool local resource @@ -309,7 +282,7 @@ withResource pool act = control $ \runInIO -> mask $ \restore -> do takeResource :: Pool a -> IO (a, LocalPool a) takeResource pool@Pool{..} = do local@LocalPool{..} <- getLocalPool pool - resource <- liftBase . join . atomically $ do + resource <- join . atomically $ do modifyTVar_ takeVar (+ 1) ents <- readTVar entries case ents of @@ -332,14 +305,8 @@ takeResource pool@Pool{..} = do -- returns immediately with 'Nothing' (ie. the action function is /not/ called). -- Conversely, if a resource can be borrowed from the pool without blocking, the -- action is performed and it's result is returned, wrapped in a 'Just'. -tryWithResource :: forall m a b. -#if MIN_VERSION_monad_control(0,3,0) - (MonadBaseControl IO m) -#else - (MonadControlIO m) -#endif - => Pool a -> (a -> m b) -> m (Maybe b) -tryWithResource pool act = control $ \runInIO -> mask $ \restore -> do +tryWithResource :: forall m a b. MonadUnliftIO m => Pool a -> (a -> m b) -> m (Maybe b) +tryWithResource pool act = withRunInIO $ \runInIO -> mask $ \restore -> do res <- tryTakeResource pool case res of Just (resource, local) -> do @@ -358,7 +325,7 @@ tryWithResource pool act = control $ \runInIO -> mask $ \restore -> do tryTakeResource :: Pool a -> IO (Maybe (a, LocalPool a)) tryTakeResource pool@Pool{..} = do local@LocalPool{..} <- getLocalPool pool - resource <- liftBase . join . atomically $ do + resource <- join . atomically $ do ents <- readTVar entries case ents of (Entry{..}:es) -> writeTVar entries es >> return (return . Just $ entry) @@ -380,7 +347,7 @@ tryTakeResource pool@Pool{..} = do -- Internal, just to not repeat code for 'takeResource' and 'tryTakeResource' getLocalPool :: Pool a -> IO (LocalPool a) getLocalPool Pool{..} = do - i <- liftBase $ ((`mod` numStripes) . hash) <$> myThreadId + i <- ((`mod` numStripes) . hash) <$> myThreadId return $ localPools V.! i #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE getLocalPool #-} @@ -425,11 +392,11 @@ destroyAllResources Pool{..} = V.forM_ localPools $ purgeLocalPool destroy -- | @stats pool reset@ returns statistics on each 'LocalPool' as well as a summary across the entire Pool. -- When @reset@ is true, the stats are reset. stats :: Pool a -> Bool -> IO Stats -stats Pool{..} reset = do +stats Pool{..} reset = do let stripeStats LocalPool{..} = atomically $ do s <- liftM5 PoolStats (readTVar highwaterVar) (readTVar inUse) (readTVar takeVar) (readTVar createVar) (readTVar createFailureVar) when reset $ do - mapM_ (\v -> writeTVar v 0) [takeVar, createVar, createFailureVar] + mapM_ (\v -> writeTVar v 0) [takeVar, createVar, createFailureVar] writeTVar highwaterVar $! currentUsage s return s diff --git a/default.nix b/default.nix new file mode 100644 index 0000000..d58ba2b --- /dev/null +++ b/default.nix @@ -0,0 +1,51 @@ +{}: + +let + commonEnvs = builtins.fetchGit { + url = "https://github.com/avanov/nix-common.git"; + ref = "master"; + rev = "9d81a5757aa0dfb7ca68edccd081bdf591c6df9e"; + }; + ghcEnv = import "${commonEnvs}/ghc-env.nix" {}; + pkgs = ghcEnv.pkgs; + + macOsDeps = with pkgs; lib.optionals stdenv.isDarwin [ + darwin.apple_sdk.frameworks.CoreServices + darwin.apple_sdk.frameworks.ApplicationServices + ]; + + devEnv = pkgs.mkShell { + # Sets the build inputs, i.e. what will be available in our + # local environment. + nativeBuildInputs = with pkgs; [ + cabal-install + cabal2nix + cachix + + cacert + glibcLocales + + gnumake + gitAndTools.pre-commit + haskell-language-server + ghc + + zlib + ] ++ macOsDeps; + shellHook = '' + export PROJECT_PLATFORM="${builtins.currentSystem}" + export LANG=en_GB.UTF-8 + + # https://cabal.readthedocs.io/en/3.4/installing-packages.html#environment-variables + export CABAL_DIR=$PWD/.local/${builtins.currentSystem}/cabal + + # symbolic link to Language Server to satisfy VSCode Haskell plugins + ln -s -f `which haskell-language-server` $PWD/hls.exe + ''; + }; + +in + +{ + inherit devEnv; +} diff --git a/resource-pool.cabal b/resource-pool.cabal index 9b44a9f..3cc6a31 100644 --- a/resource-pool.cabal +++ b/resource-pool.cabal @@ -32,11 +32,11 @@ library build-depends: base >= 4.4 && < 5, hashable, - monad-control >= 0.2.0.1, transformers, transformers-base >= 0.4, stm >= 2.3, time, + unliftio, vector >= 0.7 if flag(developer) @@ -48,8 +48,4 @@ library source-repository head type: git - location: http://github.com/bos/pool - -source-repository head - type: mercurial - location: http://bitbucket.org/bos/pool + location: http://github.com/avanov/pool diff --git a/shell.nix b/shell.nix new file mode 100644 index 0000000..61bf9db --- /dev/null +++ b/shell.nix @@ -0,0 +1,4 @@ +let + environment = import ./default.nix {}; +in + environment.devEnv