diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,15 @@ ## Changelog for the `vault` package +**0.3.1.6** + +Added + +* Add support for MicroHs + +Removed + +* Dropped support for `GHC < 8.4` + **0.3.1.5** * Compatibility with GHC-9.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,3 @@ -[![Build Status](https://travis-ci.org/HeinrichApfelmus/vault.png)](https://travis-ci.org/HeinrichApfelmus/vault) - - *Vault* is a tiny library that provides a single data structure called *vault*. A *vault* is a type-safe, persistent storage for values of arbitrary types. Like `IORef`, I want to be able to store values of any type in it, but unlike `IORef`, I want the storage space to behave like a persistent, first-class data structure, as appropriate for a purely functional language. diff --git a/src/Data/Unique/Really.hs b/src/Data/Unique/Really.hs --- a/src/Data/Unique/Really.hs +++ b/src/Data/Unique/Really.hs @@ -3,14 +3,12 @@ Unique, newUnique, hashUnique, ) where -import Control.Applicative ((<$>)) -import Data.Hashable +import Data.Hashable #if UseGHC - -import Control.Exception (evaluate) +import Control.Exception (evaluate) import qualified Data.Unique -import System.Mem.StableName +import System.Mem.StableName -- | An abstract unique value. -- Values of type 'Unique' may be compared for equality @@ -52,6 +50,8 @@ #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'. @@ -62,5 +62,3 @@ -- 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 - -instance Hashable Unique where hashWithSalt s = hashWithSalt s . hashUnique diff --git a/src/Data/Vault/IO.h b/src/Data/Vault/IO.h --- a/src/Data/Vault/IO.h +++ b/src/Data/Vault/IO.h @@ -12,7 +12,6 @@ import Control.Monad.ST import qualified Data.Vault.ST.LAZINESS as ST - {----------------------------------------------------------------------------- Vault ------------------------------------------------------------------------------} diff --git a/src/Data/Vault/ST/ST.h b/src/Data/Vault/ST/ST.h --- a/src/Data/Vault/ST/ST.h +++ b/src/Data/Vault/ST/ST.h @@ -12,12 +12,9 @@ lock, unlock, ) where -import Data.Monoid (Monoid(..)) -import Data.Semigroup (Semigroup((<>))) import Prelude hiding (lookup) -import Control.Applicative ((<$>)) import Control.Monad.ST -import Control.Monad.ST.Unsafe as STUnsafe +import Control.Monad.ST.Unsafe (unsafeIOToST) import Data.Unique.Really @@ -44,7 +41,6 @@ instance Monoid (Vault s) where mempty = empty - mappend = union -- | The empty vault. empty :: Vault s diff --git a/src/Data/Vault/ST/backends/GHC.h b/src/Data/Vault/ST/backends/GHC.h --- a/src/Data/Vault/ST/backends/GHC.h +++ b/src/Data/Vault/ST/backends/GHC.h @@ -23,7 +23,7 @@ type role Key nominal nominal #endif -newKey = STUnsafe.unsafeIOToST $ Key <$> newUnique +newKey = unsafeIOToST $ Key <$> newUnique lookup (Key k) (Vault m) = fromAny <$> Map.lookup k m diff --git a/src/Data/Vault/ST/backends/IORef.hs b/src/Data/Vault/ST/backends/IORef.hs new file mode 100644 --- /dev/null +++ b/src/Data/Vault/ST/backends/IORef.hs @@ -0,0 +1,40 @@ +import Data.IORef +import System.IO.Unsafe (unsafePerformIO) + +import qualified Data.Map.LAZINESS as Map +type Map = Map.Map + +{----------------------------------------------------------------------------- + Locker +------------------------------------------------------------------------------} +data Key s a = Key !Unique (IORef (Maybe a)) +data Locker s = Locker !Unique (IO ()) + +#if IsStrict +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 +#endif + +unlock (Key k ref) (Locker k' m) + | k == k' = unsafePerformIO $ do + m + readIORef ref -- FIXME: race condition! + | otherwise = Nothing + +{----------------------------------------------------------------------------- + Vault +------------------------------------------------------------------------------} +-- implemented as a collection of lockers +newtype Vault s = Vault (Map Unique (Locker s)) + +newKey = unsafeIOToST $ Key <$> newUnique <*> newIORef Nothing + +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 + +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 diff --git a/vault.cabal b/vault.cabal --- a/vault.cabal +++ b/vault.cabal @@ -1,7 +1,8 @@ -Name: vault -Version: 0.3.1.5 -Synopsis: a persistent store for values of arbitrary types -Description: +cabal-version: 3.4 +name: vault +version: 0.3.1.6 +synopsis: a persistent store for values of arbitrary types +description: A /vault/ is a persistent store for values of arbitrary types. It's like having first-class access to the storage space behind IORefs. . @@ -11,61 +12,64 @@ . Also provided is a /locker/ type, representing a store for a single element. -Category: Data -License: BSD3 -License-file: LICENSE -Author: Heinrich Apfelmus, Elliott Hird -Maintainer: Heinrich Apfelmus -Homepage: https://github.com/HeinrichApfelmus/vault -Copyright: (c) Heinrich Apfelmus 2011-2013 - -build-type: Simple -cabal-version: >= 1.10 -Tested-With: GHC == 7.6.3 - ,GHC == 7.8.4 - ,GHC == 7.10.3 - ,GHC == 8.0.2 - ,GHC == 8.2.2 - ,GHC == 8.4.4 - ,GHC == 8.6.5 - ,GHC == 8.8.3 - ,GHC == 8.10.1 +category: Data +license: BSD-3-Clause +license-file: LICENSE +author: Heinrich Apfelmus, Elliott Hird +maintainer: Heinrich Apfelmus +homepage: https://github.com/HeinrichApfelmus/vault +copyright: (c) Heinrich Apfelmus 2011-2026 +tested-with: + GHC ==8.4.4 + || ==8.6.5 + || ==8.8.4 + || ==8.10.7 + || ==9.0.2 + || ==9.2.8 + || ==9.4.8 + || ==9.6.7 + || ==9.8.4 + || ==9.10.2 + || ==9.12.2 extra-source-files: - CHANGELOG.md - README.md - src/Data/Vault/IO.h - src/Data/Vault/ST/ST.h - src/Data/Vault/ST/backends/GHC.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 +extra-doc-files: + CHANGELOG.md + README.md source-repository head - type: git - location: git://github.com/HeinrichApfelmus/vault.git + type: git + location: https://github.com/HeinrichApfelmus/vault.git flag UseGHC - description: Use GHC-specific packages and extensions. - default: True - -Library - hs-source-dirs: src - build-depends: base >= 4.5 && < 4.16, - containers >= 0.4 && < 0.7, - unordered-containers >= 0.2.3.0 && < 0.3, - hashable >= 1.1.2.5 && < 1.4 + description: Use GHC-specific packages and extensions. + default: True - if impl(ghc < 8.0) - build-depends: semigroups >= 0.1 && < 1.0 +library + default-language: Haskell2010 + default-extensions: CPP + build-depends: + , base >=4.11 && <4.23 + , containers >=0.5 && <0.9 + , hashable >=1.1.2.5 && <1.6 + , unordered-containers >=0.2.3.0 && <0.3 - default-language: Haskell2010 - default-extensions: CPP - ghc-options: -Wall -fno-warn-missing-signatures + ghc-options: -Wall -fno-warn-missing-signatures + hs-source-dirs: src + exposed-modules: + Data.Unique.Really + Data.Vault.Lazy + Data.Vault.ST.Lazy + Data.Vault.ST.Strict + Data.Vault.Strict - exposed-modules: - Data.Vault.Lazy, - Data.Vault.Strict, - Data.Vault.ST.Lazy, - Data.Vault.ST.Strict, - Data.Unique.Really + if (impl(ghc) && flag(useghc)) + cpp-options: -DUseGHC - if impl(ghc) && flag(UseGHC) - CPP-options: -DUseGHC + if impl(mhs) + build-depends: + , unordered-containers >= 0.2.21