vault 0.3.1.6 → 0.3.2.0

raw patch · 20 files changed

+250/−79 lines, 20 filesdep +hspecdep +vaultdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: hspec, vault

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−0
• README.md +13/−0
• src/Data/Unique/Really.hs +2/−56
• src/Data/Unique/Really/Any.hs +3/−0
• src/Data/Unique/Really/Core.h +64/−0
• src/Data/Unique/Really/GHC.hs +3/−0
• src/Data/Vault/IO.h +1/−1
• src/Data/Vault/Lazy.hs +2/−0
• src/Data/Vault/ST/Lazy.hs +5/−1
• src/Data/Vault/ST/ST.h +2/−4
• src/Data/Vault/ST/Strict.hs +5/−1
• src/Data/Vault/ST/backends/GHC.h +8/−3
• src/Data/Vault/ST/backends/IORef.hs +15/−10
• src/Data/Vault/Strict.hs +3/−0
• src/Internal/Data/Vault/ST/IORef.hs +8/−0
• test/Data/Vault/ST/LazySpec.hs +6/−0
• test/Data/Vault/Spec.h +52/−0
• test/Internal/Data/Vault/ST/IORefSpec.hs +6/−0
• test/Spec.hs +10/−0
• vault.cabal +30/−3

@@ -1,5 +1,17 @@ ## Changelog for the `vault` package +**next version**++**0.3.2.0**++Changed++* Make value type of `Key` representational (in GHC backend)++Fixed++* Fix potential race condition in IORef backend.+ **0.3.1.6**  Added

@@ -40,5 +40,18 @@   [3]: mailto:apfelmus@quantentunnel.de  +Contributors+============ +Many thanks to... +* [Charly Coste](https://github.com/Changaco)+* [Elliott Hird](https://github.com/ehird)+* [Henning Thielemann](https://github.com/thielema)+* [konsumlamm](https://github.com/konsumlamm)+* [Mark Karpov](https://github.com/mrkkrp)+* [Ryan Scott](https://github.com/RyanGlScott)+* [Simon Jakobi](https://github.com/sjakobi)+* [Tom Ellis](https://github.com/tomjaguarpaw)++... and others!

@@ -3,62 +3,8 @@     Unique, newUnique, hashUnique,     ) where -import           Data.Hashable- #if UseGHC-import           Control.Exception (evaluate)-import qualified Data.Unique-import           System.Mem.StableName---- | An abstract unique value.--- Values of type 'Unique' may be compared for equality--- and hashed into Int.------ Note: Unlike the symbols from "Data.Unique", the symbols from this--- module do not become equal after reloads in the GHC interpreter!-newtype Unique = Unique (StableName Data.Unique.Unique) deriving (Eq)--newUnique = do-    x <- Data.Unique.newUnique-    _ <- evaluate x-    Unique <$> makeStableName x--hashUnique (Unique s) = hashStableName s-+import Data.Unique.Really.GHC #else--import Data.IORef-import System.IO.Unsafe (unsafePerformIO)--{-# NOINLINE refNumber #-}-refNumber :: IORef Integer-refNumber = unsafePerformIO $ newIORef 0--newNumber = atomicModifyIORef' refNumber $ \x -> let x' = x+1 in (x', x')---- | An abstract unique value.--- Values of type 'Unique' may be compared for equality--- and hashed into Int.------ NOTE: You haven't compiled this module with GHC.--- The functionality will be identitcal to "Data.Unique".-newtype Unique = Unique Integer deriving (Eq,Ord)--newUnique = Unique <$> newNumber-hashUnique (Unique s) = fromIntegral s--+import Data.Unique.Really.Any #endif--instance Hashable Unique where hashWithSalt s = hashWithSalt s . hashUnique---- | Creates a new object of type 'Unique'.--- The value returned will not compare equal to any other--- value of type 'Unique' returned by previous calls to 'newUnique'.--- There is no limit on the number of times you may call this function.-newUnique  :: IO Unique---- | Hashes a 'Unique' into an 'Int'.--- Two Uniques may hash to the same value, although in practice this is unlikely.--- The 'Int' returned makes a good hash key.-hashUnique :: Unique -> Int

@@ -0,0 +1,3 @@+#define MODULE_NAME Data.Unique.Really.Any+#undef  BACKEND_GHC+#include "Core.h"

@@ -0,0 +1,64 @@+-- | An abstract interface to a unique symbol generator.+module MODULE_NAME (+    Unique, newUnique, hashUnique,+    ) where++import           Data.Hashable++#if BACKEND_GHC+import           Control.Exception (evaluate)+import qualified Data.Unique+import           System.Mem.StableName++-- | An abstract unique value.+-- Values of type 'Unique' may be compared for equality+-- and hashed into Int.+--+-- Note: Unlike the symbols from "Data.Unique", the symbols from this+-- module do not become equal after reloads in the GHC interpreter!+newtype Unique = Unique (StableName Data.Unique.Unique) deriving (Eq)++newUnique = do+    x <- Data.Unique.newUnique+    _ <- evaluate x+    Unique <$> makeStableName x++hashUnique (Unique s) = hashStableName s++#else++import Data.IORef+import System.IO.Unsafe (unsafePerformIO)++{-# NOINLINE refNumber #-}+refNumber :: IORef Integer+refNumber = unsafePerformIO $ newIORef 0++newNumber = atomicModifyIORef' refNumber $ \x -> let x' = x+1 in (x', x')++-- | An abstract unique value.+-- Values of type 'Unique' may be compared for equality+-- and hashed into Int.+--+-- NOTE: You haven't compiled this module with GHC.+-- The functionality will be identitcal to "Data.Unique".+newtype Unique = Unique Integer deriving (Eq,Ord)++newUnique = Unique <$> newNumber+hashUnique (Unique s) = fromIntegral s+++#endif++instance Hashable Unique where hashWithSalt s = hashWithSalt s . hashUnique++-- | Creates a new object of type 'Unique'.+-- The value returned will not compare equal to any other+-- value of type 'Unique' returned by previous calls to 'newUnique'.+-- There is no limit on the number of times you may call this function.+newUnique  :: IO Unique++-- | Hashes a 'Unique' into an 'Int'.+-- Two Uniques may hash to the same value, although in practice this is unlikely.+-- The 'Int' returned makes a good hash key.+hashUnique :: Unique -> Int

@@ -0,0 +1,3 @@+#define MODULE_NAME Data.Unique.Really.GHC+#define BACKEND_GHC 1+#include "Core.h"

@@ -1,4 +1,4 @@-module Data.Vault.LAZINESS (+module MODULE_NAME (     -- * Vault     Vault, Key,     empty, newKey, lookup, insert, adjust, delete, union,

@@ -1,4 +1,6 @@ #define LAZINESS Lazy+#define MODULE_NAME Data.Vault.Lazy+-- BACKEND_GHC is fixed by the import of Data.Vault.ST.*  -- | A persistent store for values of arbitrary types. --

@@ -1,4 +1,8 @@-#define LAZINESS Lazy+#define LAZINESS    Lazy+#define MODULE_NAME Data.Vault.ST.Lazy+#if UseGHC+#define BACKEND_GHC 1+#endif  -- | A persistent store for values of arbitrary types. -- Variant for the 'ST' monad.

@@ -2,7 +2,7 @@ {-# LANGUAGE RoleAnnotations #-} #endif -module Data.Vault.ST.LAZINESS (+module MODULE_NAME (     -- * Vault     Vault, Key,     empty, newKey, lookup, insert, adjust, delete, union,@@ -16,8 +16,6 @@ import Control.Monad.ST import Control.Monad.ST.Unsafe (unsafeIOToST) -import Data.Unique.Really- {-     The GHC-specific implementation uses  unsafeCoerce     for reasons of efficiency.@@ -26,7 +24,7 @@     for the second implementation that doesn't need to     bypass the type checker. -}-#if UseGHC+#if BACKEND_GHC #include "backends/GHC.h" #else #include "backends/IORef.hs"

@@ -1,5 +1,9 @@-#define LAZINESS Strict+#define LAZINESS    Strict+#define MODULE_NAME Data.Vault.ST.Strict #define IsStrict 1+#if UseGHC+#define BACKEND_GHC 1+#endif  -- | A persistent store for values of arbitrary types. -- Variant for the 'ST' monad.

@@ -1,5 +1,10 @@--- This implementation is specific to GHC--- und uses  unsafeCoerce  for reasons of efficiency.+-- This implementation is specific to GHC because it uses Any,+-- from and to which it is valid to unsafeCoerce any type.  Using+-- unsafeCoerce avoids picking up a Typeable constraint. This+-- implementation is more efficient than the alternative implementation+-- in terms of IORef.++import Data.Unique.Really.GHC import GHC.Exts (Any) import Unsafe.Coerce (unsafeCoerce) @@ -20,7 +25,7 @@  #if __GLASGOW_HASKELL__ >= 708 type role Vault nominal-type role Key nominal nominal+type role Key nominal representational #endif  newKey = unsafeIOToST $ Key <$> newUnique

@@ -1,4 +1,6 @@+import Control.Concurrent.MVar import Data.IORef+import Data.Unique.Really.Any import System.IO.Unsafe (unsafePerformIO)  import qualified Data.Map.LAZINESS as Map@@ -7,19 +9,22 @@ {-----------------------------------------------------------------------------     Locker ------------------------------------------------------------------------------}-data Key s a  = Key    !Unique (IORef (Maybe a))+data Key s a  = Key    !Unique (IORef (Maybe a)) (MVar ()) data Locker s = Locker !Unique (IO ())  #if IsStrict-lock (Key u ref) x = x `seq` (Locker u $ writeIORef ref $ Just x)+lock (Key u ref _) x = x `seq` (Locker u $ writeIORef ref $ Just x) #else-lock (Key u ref) x = Locker u $ writeIORef ref $ Just x+lock (Key u ref _) x = Locker u $ writeIORef ref $ Just x #endif -unlock (Key k ref) (Locker k' m)+unlock (Key k ref locked) (Locker k' m)     | k == k' = unsafePerformIO $ do+        takeMVar locked         m-        readIORef ref     -- FIXME: race condition!+        val <- readIORef ref+        putMVar locked ()+        pure val     | otherwise = Nothing  {-----------------------------------------------------------------------------@@ -28,13 +33,13 @@ -- implemented as a collection of lockers newtype Vault s = Vault (Map Unique (Locker s)) -newKey = unsafeIOToST $ Key <$> newUnique <*> newIORef Nothing+newKey = unsafeIOToST $ Key <$> newUnique <*> newIORef Nothing <*> newMVar () -lookup key@(Key k _)   (Vault m) = unlock key =<< Map.lookup k m+lookup key@(Key k _ _)   (Vault m) = unlock key =<< Map.lookup k m -insert key@(Key k _) x (Vault m) = Vault $ Map.insert k (lock key x) m+insert key@(Key k _ _) x (Vault m) = Vault $ Map.insert k (lock key x) m -adjust f key@(Key k _) (Vault m) = Vault $ Map.update f' k m+adjust f key@(Key k _ _) (Vault m) = Vault $ Map.update f' k m     where f' = fmap (lock key . f) . unlock key -delete (Key k _) (Vault m)  = Vault $ Map.delete k m+delete (Key k _ _) (Vault m)  = Vault $ Map.delete k m

@@ -1,4 +1,7 @@ #define LAZINESS Strict+#define MODULE_NAME Data.Vault.Strict+-- BACKEND_GHC is fixed by the import of Data.Vault.ST.*+  -- | A persistent store for values of arbitrary types. --

@@ -0,0 +1,8 @@+#define LAZINESS Lazy+#define MODULE_NAME Internal.Data.Vault.ST.IORef+#undef  BACKEND_GHC++-- | FOR TESTING ONLY. DO NOT USE!+--+-- 'Vault' implementation using 'IORef' for testing purposes.+#include "../../../../Data/Vault/ST/ST.h"

@@ -0,0 +1,6 @@+module Data.Vault.ST.LazySpec (spec) where++#define MODULE_UNDER_TEST Data.Vault.ST.Lazy+#define TEST_NAME "Data.Vault.ST.Lazy"++#include "../Spec.h"

@@ -0,0 +1,52 @@+import Prelude hiding (lookup)++import Control.Concurrent (forkFinally, threadDelay)+import Control.Concurrent.MVar (MVar, putMVar, takeMVar, newEmptyMVar)+import Control.Monad.ST (RealWorld, stToIO)+import Test.Hspec+import MODULE_UNDER_TEST++newKey' :: IO (Key RealWorld a)+newKey' = stToIO newKey++spec :: Spec+spec = describe TEST_NAME $ do++  describe "Locker" $ do++    it "unlock retrieves locked item" $ do+      key <- newKey' :: IO (Key RealWorld Int)+      unlock key (lock key 42) `shouldBe` Just 42++    it "unlock with different key retrieves Nothing" $ do+      key  <- newKey' :: IO (Key RealWorld Int)+      key' <- newKey' :: IO (Key RealWorld Int)+      unlock key' (lock key 42) `shouldBe` Nothing++    -- Even though the code contained a potential race condition,+    -- this test was unable to trigger it.+    -- Still, we keep it as a regression test.+    it "no race condition for simultaneous unlock" $ do+      key  <- newKey' :: IO (Key RealWorld Int)+      let check n = unlock key (lock key n) `shouldBe` Just n+      race $ map check [1..500]++  describe "Vault" $ do++    it "lookup empty returns Nothing" $ do+      key <- newKey' :: IO (Key RealWorld Int)+      lookup key empty `shouldBe` Nothing++{-----------------------------------------------------------------------------+    Helper functions+------------------------------------------------------------------------------}+-- | Race multiple IO actions against each other.+race :: [IO ()] -> IO ()+race xs = do+    mvars <- mapM (\_ -> newEmptyMVar :: IO (MVar ())) xs+    sequence $+        zipWith+          (\mvar m -> forkFinally (threadDelay 10 >> m) (const $ putMVar mvar ()))+          mvars+          xs+    mapM_ takeMVar mvars

@@ -0,0 +1,6 @@+module Internal.Data.Vault.ST.IORefSpec (spec) where++#define MODULE_UNDER_TEST Internal.Data.Vault.ST.IORef+#define TEST_NAME "Internal.Data.Vault.ST.IORef"++#include "../../../../Data/Vault/Spec.h"

@@ -0,0 +1,10 @@+module Main (main) where+ +import Test.Hspec+import qualified Data.Vault.ST.LazySpec+import qualified Internal.Data.Vault.ST.IORefSpec+ +main :: IO ()+main = hspec $ do+  Data.Vault.ST.LazySpec.spec+  Internal.Data.Vault.ST.IORefSpec.spec

@@ -1,6 +1,11 @@ cabal-version:      3.4 name:               vault-version:            0.3.1.6++-- Package Versioning Policy: https://pvp.haskell.org+-- PVP summary:     +-+------- breaking API changes+--                  | | +----- non-breaking API additions+--                  | | | +--- code changes with no API change+version:            0.3.2.0 synopsis:           a persistent store for values of arbitrary types description:   A /vault/ is a persistent store for values of arbitrary types.@@ -29,14 +34,16 @@    || ==9.4.8    || ==9.6.7    || ==9.8.4-   || ==9.10.2-   || ==9.12.2+   || ==9.10.3+   || ==9.12.4  extra-source-files:+  src/Data/Unique/Really/Core.h   src/Data/Vault/IO.h   src/Data/Vault/ST/backends/GHC.h   src/Data/Vault/ST/backends/IORef.hs   src/Data/Vault/ST/ST.h+  test/Data/Vault/Spec.h extra-doc-files:   CHANGELOG.md   README.md@@ -66,6 +73,10 @@     Data.Vault.ST.Lazy     Data.Vault.ST.Strict     Data.Vault.Strict+    Internal.Data.Vault.ST.IORef+  other-modules:+    Data.Unique.Really.Any+    Data.Unique.Really.GHC    if (impl(ghc) && flag(useghc))     cpp-options: -DUseGHC@@ -73,3 +84,19 @@   if impl(mhs)     build-depends:       , unordered-containers >= 0.2.21++test-suite test+  type:               exitcode-stdio-1.0+  hs-source-dirs:     test+  default-language:   Haskell2010+  default-extensions: CPP+  ghc-options:        -threaded+  build-depends:+    , base+    , vault+    , hspec           >=2.11.0 && <2.12++  main-is:            Spec.hs+  other-modules:+    Data.Vault.ST.LazySpec+    Internal.Data.Vault.ST.IORefSpec