From d67f8993c6838e79c407dd827cfb089afb896037 Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Sun, 22 Nov 2020 16:32:33 -0800 Subject: [PATCH 1/3] Use unliftio over monad-control --- Data/Pool.hs | 43 +++++-------------------------------------- resource-pool.cabal | 2 +- 2 files changed, 6 insertions(+), 39 deletions(-) diff --git a/Data/Pool.hs b/Data/Pool.hs index 6764e8b..bb18e52 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 @@ -54,24 +50,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 { @@ -247,15 +226,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 @@ -295,14 +268,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 diff --git a/resource-pool.cabal b/resource-pool.cabal index 6a9bc09..5234e1d 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) From e430450f92828a4808ae61138b9e0c7864260581 Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Sun, 22 Nov 2020 16:38:19 -0800 Subject: [PATCH 2/3] Remove unneeded liftBase --- Data/Pool.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Data/Pool.hs b/Data/Pool.hs index bb18e52..c92ad40 100644 --- a/Data/Pool.hs +++ b/Data/Pool.hs @@ -248,7 +248,7 @@ withResource pool act = withRunInIO $ \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 ents <- readTVar entries case ents of (Entry{..}:es) -> writeTVar entries es >> return (return entry) @@ -288,7 +288,7 @@ tryWithResource pool act = withRunInIO $ \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) @@ -310,7 +310,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 #-} From 4189fd66cf4dd4ba741345421c0bdd7381563df4 Mon Sep 17 00:00:00 2001 From: Maxim Avanov Date: Tue, 14 Dec 2021 16:46:15 +0000 Subject: [PATCH 3/3] nix shell --- .gitignore | 6 +++++- default.nix | 51 +++++++++++++++++++++++++++++++++++++++++++++ resource-pool.cabal | 6 +----- shell.nix | 4 ++++ 4 files changed, 61 insertions(+), 6 deletions(-) create mode 100644 default.nix create mode 100644 shell.nix 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/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..80d3640 100644 --- a/resource-pool.cabal +++ b/resource-pool.cabal @@ -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