summaryrefslogtreecommitdiff
Side-by-side diff
Diffstat (more/less context) (ignore whitespace changes)
-rw-r--r--src/Data/Unique/Really.hs30
-rw-r--r--src/Data/Vault/IO.hs (renamed from src/Data/Vault.hs)24
-rw-r--r--src/Data/Vault/Lazy.hs6
-rw-r--r--src/Data/Vault/ST/Lazy.hs7
-rw-r--r--src/Data/Vault/ST/ST.hs (renamed from src/Data/Vault/ST.hs)58
-rw-r--r--src/Data/Vault/ST/Strict.hs8
-rw-r--r--src/Data/Vault/ST/backends/GHC.hs41
-rw-r--r--src/Data/Vault/ST_GHC.hs67
-rw-r--r--src/Data/Vault/ST_Pure.hs56
-rw-r--r--src/Data/Vault/Strict.hs6
-rw-r--r--vault.cabal48
11 files changed, 135 insertions, 216 deletions
diff --git a/src/Data/Unique/Really.hs b/src/Data/Unique/Really.hs
index 1ea946d..c7192e2 100644
--- a/src/Data/Unique/Really.hs
+++ b/src/Data/Unique/Really.hs
@@ -1,21 +1,15 @@
-{-----------------------------------------------------------------------------
- vault
-------------------------------------------------------------------------------}
-{-# LANGUAGE CPP #-}
+-- | An abstract interface to a unique symbol generator.
module Data.Unique.Really (
- -- | An abstract interface to a unique symbol generator.
-
Unique, newUnique, hashUnique,
) where
import Control.Applicative
-import System.IO.Unsafe (unsafePerformIO)
+import Data.Hashable
-#if __GLASGOW_HASKELL__
+#if UseGHC
import Control.Exception (evaluate)
import qualified Data.Unique
-import Data.Hashable
import System.Mem.StableName
-- | An abstract unique value.
@@ -28,27 +22,21 @@ newtype Unique = Unique (StableName Data.Unique.Unique) deriving (Eq)
newUnique = do
x <- Data.Unique.newUnique
- evaluate x
+ _ <- evaluate x
Unique <$> makeStableName x
hashUnique (Unique s) = hashStableName s
-instance Hashable Unique where hash = hashUnique
-
#else
import Data.IORef
+import System.IO.Unsafe (unsafePerformIO)
{-# NOINLINE refNumber #-}
refNumber :: IORef Integer
refNumber = unsafePerformIO $ newIORef 0
-newNumber = do
- x <- readIORef refNumber
- writeIORef refNumber $! x+1 -- FIXME: race condition!
- return x
-
-newtype Unique = Unique Integer deriving (Eq)
+newNumber = atomicModifyIORef' refNumber $ \x -> let x' = x+1 in (x', x')
-- | An abstract unique value.
-- Values of type 'Unique' may be compared for equality
@@ -56,6 +44,8 @@ newtype Unique = Unique Integer deriving (Eq)
--
-- 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
@@ -71,4 +61,6 @@ 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 \ No newline at end of file
+hashUnique :: Unique -> Int
+
+instance Hashable Unique where hashWithSalt s = hashWithSalt s . hashUnique
diff --git a/src/Data/Vault.hs b/src/Data/Vault/IO.hs
index c5b701c..02b4f62 100644
--- a/src/Data/Vault.hs
+++ b/src/Data/Vault/IO.hs
@@ -1,14 +1,8 @@
-{-----------------------------------------------------------------------------
- vault
-------------------------------------------------------------------------------}
-module Data.Vault (
- -- * Synopsis
- -- | A persistent store for values of arbitrary types.
-
+module Data.Vault.LAZINESS (
-- * Vault
Vault, Key,
empty, newKey, lookup, insert, adjust, delete, union,
-
+
-- * Locker
Locker,
lock, unlock,
@@ -16,23 +10,20 @@ module Data.Vault (
import Prelude hiding (lookup)
import Control.Monad.ST
-import qualified Data.Vault.ST as ST
+import qualified Data.Vault.ST.LAZINESS as ST
+
{-----------------------------------------------------------------------------
Vault
------------------------------------------------------------------------------}
+
-- | A persistent store for values of arbitrary types.
---
+--
-- This variant is the simplest and creates keys in the 'IO' monad.
-- See the module "Data.Vault.ST" if you want to use it with the 'ST' monad instead.
---
--- > type Vault :: *
--- > instance Monoid Vault
type Vault = ST.Vault RealWorld
-- | Keys for the vault.
---
--- > type Key :: * -> *
type Key = ST.Key RealWorld
-- | The empty vault.
@@ -66,9 +57,8 @@ union = ST.union
{-----------------------------------------------------------------------------
Locker
------------------------------------------------------------------------------}
+
-- | A persistent store for a single value.
---
--- > type Locker :: *
type Locker = ST.Locker RealWorld
-- | Put a single value into a 'Locker'.
diff --git a/src/Data/Vault/Lazy.hs b/src/Data/Vault/Lazy.hs
new file mode 100644
index 0000000..4c9cfdb
--- a/dev/null
+++ b/src/Data/Vault/Lazy.hs
@@ -0,0 +1,6 @@
+#define LAZINESS Lazy
+
+-- | A persistent store for values of arbitrary types.
+--
+-- The 'Vault' type in this module is strict in the keys but lazy in the values.
+#include "IO.hs"
diff --git a/src/Data/Vault/ST/Lazy.hs b/src/Data/Vault/ST/Lazy.hs
new file mode 100644
index 0000000..195cbd9
--- a/dev/null
+++ b/src/Data/Vault/ST/Lazy.hs
@@ -0,0 +1,7 @@
+#define LAZINESS Lazy
+
+-- | A persistent store for values of arbitrary types.
+-- Variant for the 'ST' monad.
+--
+-- The 'Vault' type in this module is strict in the keys but lazy in the values.
+#include "ST.hs"
diff --git a/src/Data/Vault/ST.hs b/src/Data/Vault/ST/ST.hs
index 52e3c9a..d342455 100644
--- a/src/Data/Vault/ST.hs
+++ b/src/Data/Vault/ST/ST.hs
@@ -1,16 +1,8 @@
-{-----------------------------------------------------------------------------
- vault
-------------------------------------------------------------------------------}
-{-# LANGUAGE CPP #-}
-module Data.Vault.ST (
- -- * Synopsis
- -- | A persistent store for values of arbitrary types.
- -- Variant for the 'ST' monad.
-
+module Data.Vault.ST.LAZINESS (
-- * Vault
Vault, Key,
empty, newKey, lookup, insert, adjust, delete, union,
-
+
-- * Locker
Locker,
lock, unlock,
@@ -18,83 +10,63 @@ module Data.Vault.ST (
import Data.Monoid (Monoid(..))
import Prelude hiding (lookup)
+import Control.Applicative hiding (empty)
import Control.Monad.ST
+import Control.Monad.ST.Unsafe as STUnsafe
+
+import Data.Unique.Really
{-
- The GHC-specific implementation uses unsafeCoerce
+ The GHC-specific implementation uses unsafeCoerce
for reasons of efficiency.
-
+
See http://apfelmus.nfshost.com/blog/2011/09/04-vault.html
for the second implementation that doesn't need to
bypass the type checker.
-}
-#if __GLASGOW_HASKELL__
-import qualified Data.Vault.ST_GHC as ST
+#if UseGHC
+#include "backends/GHC.hs"
#else
-import qualified Data.Vault.ST_Pure as ST
+#include "backends/IORef.hs"
#endif
{-----------------------------------------------------------------------------
Vault
------------------------------------------------------------------------------}
--- | A persistent store for values of arbitrary types.
---
--- This variant is the simplest and creates keys in the 'IO' monad.
--- See the module "Data.Vault.ST" if you want to use it with the 'ST' monad instead.
---
--- > type Vault :: * -> *
--- > instance Monoid Vault
-type Vault = ST.Vault
-
-instance Monoid (ST.Vault s) where
+
+instance Monoid (Vault s) where
mempty = empty
mappend = union
--- | Keys for the vault.
---
--- > type Key :: * -> * -> *
-type Key = ST.Key
-
-- | The empty vault.
empty :: Vault s
-empty = ST.empty
+empty = Vault Map.empty
-- | Create a new key for use with a vault.
newKey :: ST s (Key s a)
-newKey = ST.newKey
-- | Lookup the value of a key in the vault.
lookup :: Key s a -> Vault s -> Maybe a
-lookup = ST.lookup
-- | Insert a value for a given key. Overwrites any previous value.
insert :: Key s a -> a -> Vault s -> Vault s
-insert = ST.insert
-- | Adjust the value for a given key if it's present in the vault.
adjust :: (a -> a) -> Key s a -> Vault s -> Vault s
-adjust = ST.adjust
-- | Delete a key from the vault.
delete :: Key s a -> Vault s -> Vault s
-delete = ST.delete
-- | Merge two vaults (left-biased).
union :: Vault s -> Vault s -> Vault s
-union = ST.union
+union (Vault m) (Vault m') = Vault $ Map.union m m'
{-----------------------------------------------------------------------------
Locker
------------------------------------------------------------------------------}
--- | A persistent store for a single value.
---
--- > type Locker :: * -> *
-type Locker = ST.Locker
-- | Put a single value into a 'Locker'.
lock :: Key s a -> a -> Locker s
-lock = ST.lock
-- | Retrieve the value from the 'Locker'.
unlock :: Key s a -> Locker s -> Maybe a
-unlock = ST.unlock
diff --git a/src/Data/Vault/ST/Strict.hs b/src/Data/Vault/ST/Strict.hs
new file mode 100644
index 0000000..8bd9a03
--- a/dev/null
+++ b/src/Data/Vault/ST/Strict.hs
@@ -0,0 +1,8 @@
+#define LAZINESS Strict
+#define IsStrict 1
+
+-- | A persistent store for values of arbitrary types.
+-- Variant for the 'ST' monad.
+--
+-- The 'Vault' type in this module is strict in both keys and values.
+#include "ST.hs"
diff --git a/src/Data/Vault/ST/backends/GHC.hs b/src/Data/Vault/ST/backends/GHC.hs
new file mode 100644
index 0000000..854db22
--- a/dev/null
+++ b/src/Data/Vault/ST/backends/GHC.hs
@@ -0,0 +1,41 @@
+-- This implementation is specific to GHC
+-- und uses unsafeCoerce for reasons of efficiency.
+import GHC.Exts (Any)
+import Unsafe.Coerce (unsafeCoerce)
+
+import qualified Data.HashMap.LAZINESS as Map
+type Map = Map.HashMap
+
+toAny :: a -> Any
+toAny = unsafeCoerce
+
+fromAny :: Any -> a
+fromAny = unsafeCoerce
+
+{-----------------------------------------------------------------------------
+ Vault
+------------------------------------------------------------------------------}
+newtype Vault s = Vault (Map Unique Any)
+newtype Key s a = Key Unique
+
+newKey = STUnsafe.unsafeIOToST $ Key <$> newUnique
+
+lookup (Key k) (Vault m) = fromAny <$> Map.lookup k m
+
+insert (Key k) x (Vault m) = Vault $ Map.insert k (toAny x) m
+
+adjust f (Key k) (Vault m) = Vault $ Map.adjust f' k m
+ where f' = toAny . f . fromAny
+
+delete (Key k) (Vault m) = Vault $ Map.delete k m
+
+{-----------------------------------------------------------------------------
+ Locker
+------------------------------------------------------------------------------}
+data Locker s = Locker !Unique !Any
+
+lock (Key k) = Locker k . toAny
+
+unlock (Key k) (Locker k' a)
+ | k == k' = Just $ fromAny a
+ | otherwise = Nothing
diff --git a/src/Data/Vault/ST_GHC.hs b/src/Data/Vault/ST_GHC.hs
deleted file mode 100644
index 69af37b..0000000
--- a/src/Data/Vault/ST_GHC.hs
+++ b/dev/null
@@ -1,67 +0,0 @@
-{-----------------------------------------------------------------------------
- vault
-------------------------------------------------------------------------------}
-module Data.Vault.ST_GHC where
-
-import Prelude hiding (lookup)
-import Data.Functor
-import Data.IntMap (IntMap)
-import qualified Data.IntMap as IntMap
-import Data.IORef
-import Control.Monad.ST
-
-
-import Data.Unique.Really
-
--- This implementation is specific to GHC
--- und uses unsafeCoerce for reasons of efficiency.
-import GHC.Exts (Any)
-import Unsafe.Coerce (unsafeCoerce)
-
-import qualified Data.HashMap.Lazy as Map
-type Map = Map.HashMap
-
-toAny :: a -> Any
-toAny = unsafeCoerce
-
-fromAny :: Any -> a
-fromAny = unsafeCoerce
-
-{-----------------------------------------------------------------------------
- Vault
-------------------------------------------------------------------------------}
-newtype Vault s = Vault (Map Unique Any)
-newtype Key s a = Key Unique
-
-empty :: Vault s
-empty = Vault Map.empty
-
-newKey :: ST s (Key s a)
-newKey = unsafeIOToST $ Key <$> newUnique
-
-lookup :: Key s a -> Vault s -> Maybe a
-lookup (Key k) (Vault m) = fromAny <$> Map.lookup k m
-
-insert :: Key s a -> a -> Vault s -> Vault s
-insert (Key k) x (Vault m) = Vault $ Map.insert k (toAny x) m
-
-adjust :: (a -> a) -> Key s a -> Vault s -> Vault s
-adjust f (Key k) (Vault m) = Vault $ Map.adjust f' k m
- where f' = toAny . f . fromAny
-
-delete (Key k) (Vault m) = Vault $ Map.delete k m
-
-union (Vault m) (Vault m') = Vault $ Map.union m m'
-
-{-----------------------------------------------------------------------------
- Locker
-------------------------------------------------------------------------------}
-data Locker s = Locker !Unique Any
-
-lock :: Key s a -> a -> Locker s
-lock (Key k) = Locker k . toAny
-
-unlock :: Key s a -> Locker s -> Maybe a
-unlock (Key k) (Locker k' a)
- | k == k' = Just $ fromAny a
- | otherwise = Nothing
diff --git a/src/Data/Vault/ST_Pure.hs b/src/Data/Vault/ST_Pure.hs
deleted file mode 100644
index b1b8561..0000000
--- a/src/Data/Vault/ST_Pure.hs
+++ b/dev/null
@@ -1,56 +0,0 @@
-{-----------------------------------------------------------------------------
- vault
-------------------------------------------------------------------------------}
-module Data.Vault.ST_Pure where
-
-import Prelude hiding (lookup)
-import Data.Functor
-import Data.IORef
-import Control.Applicative
-import Control.Monad.ST
-
-import System.IO.Unsafe (unsafePerformIO)
-
-import Data.Unique
-
-import qualified Data.Map as Map
-type Map = Map.Map
-
-{-----------------------------------------------------------------------------
- Locker
-------------------------------------------------------------------------------}
-data Key s a = Key !Unique (IORef (Maybe a))
-data Locker s = Locker !Unique (IO ())
-
-lock :: Key s a -> a -> Locker s
-lock (Key u ref) x = Locker u $ writeIORef ref $ Just x
-
-unlock :: Key s a -> Locker s -> Maybe a
-unlock (Key _ ref) (Locker _ m) = unsafePerformIO $ do
- m
- mx <- readIORef ref -- FIXME: race condition!
- writeIORef ref Nothing
- return mx
-
-{-----------------------------------------------------------------------------
- Vault
-------------------------------------------------------------------------------}
--- implemented as a collection of lockers
-newtype Vault s = Vault (Map Unique (Locker s))
-
-empty = Vault Map.empty
-
-newKey :: ST s (Key s a)
-newKey = unsafeIOToST $ Key <$> newUnique <*> newIORef Nothing
-
-lookup :: Key s a -> Vault s -> Maybe a
-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 :: (a -> a) -> Key s a -> Vault s -> Vault s
-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
-union (Vault m) (Vault m') = Vault $ Map.union m m'
diff --git a/src/Data/Vault/Strict.hs b/src/Data/Vault/Strict.hs
new file mode 100644
index 0000000..e29fd7f
--- a/dev/null
+++ b/src/Data/Vault/Strict.hs
@@ -0,0 +1,6 @@
+#define LAZINESS Strict
+
+-- | A persistent store for values of arbitrary types.
+--
+-- The 'Vault' type in this module is strict in both keys and values.
+#include "IO.hs"
diff --git a/vault.cabal b/vault.cabal
index 97125ab..d3bd9cd 100644
--- a/vault.cabal
+++ b/vault.cabal
@@ -1,5 +1,5 @@
Name: vault
-Version: 0.2.0.1
+Version: 0.3.0.2
Synopsis: a persistent store for values of arbitrary types
Description:
A /vault/ is a persistent store for values of arbitrary types.
@@ -10,37 +10,57 @@ Description:
hence the name.
.
Also provided is a /locker/ type, representing a store for a single element.
-
+ .
+ Changelog:
+ .
+ * 0.3.0.2 - Fix tarball.
+ .
+ * 0.3.0.1 - Use CPP to reduce code duplication.
+ .
+ * 0.3.0.0 - Split modules into Lazy and Strict variants, no default choice.
+ Add Hashable instance to Data.Unique.Really for all implementations.
+
Category: Data
License: BSD3
License-file: LICENSE
Author: Heinrich Apfelmus, Elliott Hird
Maintainer: Heinrich Apfelmus <apfelmus at quantentunnel de>
Homepage: https://github.com/HeinrichApfelmus/vault
-Copyright: (c) Heinrich Apfelmus 2011
+Copyright: (c) Heinrich Apfelmus 2011-2013
build-type: Simple
cabal-version: >= 1.6
-extra-source-files: Readme.md
+extra-source-files:
+ Readme.md
+ src/Data/Vault/IO.hs
+ src/Data/Vault/ST/ST.hs
+ src/Data/Vault/ST/backends/GHC.hs
source-repository head
type: git
location: git://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.*, containers >= 0.4 && < 0.6
- if impl(ghc)
- build-depends: unordered-containers >= 0.2.1.0 && < 0.3,
- hashable == 1.1.*
+ build-depends: base >= 4.5 && < 4.7,
+ containers >= 0.4 && < 0.6,
+ unordered-containers >= 0.2.3.0 && < 0.3,
+ hashable >= 1.1.2.5 && < 1.3
- ghc-options: -Wall
extensions: CPP
+ ghc-options: -Wall -fno-warn-missing-signatures
+
exposed-modules:
- Data.Vault,
- Data.Vault.ST,
+ Data.Vault.Lazy,
+ Data.Vault.Strict,
+ Data.Vault.ST.Lazy,
+ Data.Vault.ST.Strict,
Data.Unique.Really
- other-modules:
- Data.Vault.ST_GHC,
- Data.Vault.ST_Pure
+
+ if impl(ghc) && flag(UseGHC)
+ CPP-options: -DUseGHC