packages feed

vault 0.2.0.4 → 0.3.0.0

raw patch · 14 files changed

+645/−336 lines, 14 filesdep ~basedep ~containersdep ~hashable

Dependency ranges changed: base, containers, hashable, unordered-containers

Files

src/Data/Unique/Really.hs view
@@ -9,13 +9,12 @@     ) where  import Control.Applicative-import System.IO.Unsafe (unsafePerformIO)+import Data.Hashable  #if UseGHC  import Control.Exception (evaluate) import qualified Data.Unique-import Data.Hashable import System.Mem.StableName  -- | An abstract unique value.@@ -28,25 +27,21 @@  newUnique = do     x <- Data.Unique.newUnique-    evaluate x+    _ <- evaluate x     Unique <$> makeStableName x  hashUnique (Unique s) = hashStableName s -instance Hashable Unique where hashWithSalt s = hashWithSalt s . 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+newNumber = atomicModifyIORef' refNumber $ \x -> let x' = x+1 in (x', x')  newtype Unique = Unique Integer deriving (Eq) @@ -72,3 +67,5 @@ -- 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
− src/Data/Vault.hs 
@@ -1,80 +0,0 @@-{------------------------------------------------------------------------------    vault-------------------------------------------------------------------------------}-module Data.Vault (-    -- * Synopsis-    -- | A persistent store for values of arbitrary types.-    -    -- * Vault-    Vault, Key,-    empty, newKey, lookup, insert, adjust, delete, union,-    -    -- * Locker-    Locker,-    lock, unlock,-    ) where--import Prelude hiding (lookup)-import Control.Monad.ST-import qualified Data.Vault.ST 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.-empty :: Vault-empty = ST.empty---- | Create a new key for use with a vault.-newKey :: IO (Key a)-newKey = stToIO ST.newKey---- | Lookup the value of a key in the vault.-lookup :: Key a -> Vault -> Maybe a-lookup = ST.lookup---- | Insert a value for a given key. Overwrites any previous value.-insert :: Key a -> a -> Vault -> Vault-insert = ST.insert---- | Adjust the value for a given key if it's present in the vault.-adjust :: (a -> a) -> Key a -> Vault -> Vault-adjust = ST.adjust---- | Delete a key from the vault.-delete :: Key a -> Vault -> Vault-delete = ST.delete---- | Merge two vaults (left-biased).-union :: Vault -> Vault -> Vault-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'.-lock :: Key a -> a -> Locker-lock = ST.lock---- | Retrieve the value from the 'Locker'.-unlock :: Key a -> Locker -> Maybe a-unlock = ST.unlock
+ src/Data/Vault/Lazy.hs view
@@ -0,0 +1,82 @@+{-----------------------------------------------------------------------------+    vault+------------------------------------------------------------------------------}+module Data.Vault.Lazy (+    -- * Synopsis+    -- | A persistent store for values of arbitrary types.+    --+    -- The 'Vault' type in this module is strict in the keys but lazy in the values.+    +    -- * Vault+    Vault, Key,+    empty, newKey, lookup, insert, adjust, delete, union,+    +    -- * Locker+    Locker,+    lock, unlock,+    ) where++import Prelude hiding (lookup)+import Control.Monad.ST+import qualified Data.Vault.ST.Lazy 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.+empty :: Vault+empty = ST.empty++-- | Create a new key for use with a vault.+newKey :: IO (Key a)+newKey = stToIO ST.newKey++-- | Lookup the value of a key in the vault.+lookup :: Key a -> Vault -> Maybe a+lookup = ST.lookup++-- | Insert a value for a given key. Overwrites any previous value.+insert :: Key a -> a -> Vault -> Vault+insert = ST.insert++-- | Adjust the value for a given key if it's present in the vault.+adjust :: (a -> a) -> Key a -> Vault -> Vault+adjust = ST.adjust++-- | Delete a key from the vault.+delete :: Key a -> Vault -> Vault+delete = ST.delete++-- | Merge two vaults (left-biased).+union :: Vault -> Vault -> Vault+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'.+lock :: Key a -> a -> Locker+lock = ST.lock++-- | Retrieve the value from the 'Locker'.+unlock :: Key a -> Locker -> Maybe a+unlock = ST.unlock
− src/Data/Vault/ST.hs 
@@ -1,100 +0,0 @@-{------------------------------------------------------------------------------    vault-------------------------------------------------------------------------------}-{-# LANGUAGE CPP #-}-module Data.Vault.ST (-    -- * Synopsis-    -- | A persistent store for values of arbitrary types.-    -- Variant for the 'ST' monad.-    -    -- * Vault-    Vault, Key,-    empty, newKey, lookup, insert, adjust, delete, union,-    -    -- * Locker-    Locker,-    lock, unlock,-    ) where--import Data.Monoid (Monoid(..))-import Prelude hiding (lookup)-import Control.Monad.ST--{--    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 UseGHC-import qualified Data.Vault.ST_GHC as ST-#else-import qualified Data.Vault.ST_Pure as ST-#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-    mempty = empty-    mappend = union---- | Keys for the vault.------ > type Key :: * -> * -> *-type Key = ST.Key---- | The empty vault.-empty :: Vault s-empty = ST.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--{------------------------------------------------------------------------------    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
+ src/Data/Vault/ST/GHC_Lazy.hs view
@@ -0,0 +1,64 @@+{-----------------------------------------------------------------------------+    vault+------------------------------------------------------------------------------}+module Data.Vault.ST.GHC_Lazy where++import Prelude hiding (lookup)+import Data.Functor+import Control.Monad.ST+import Control.Monad.ST.Unsafe as STUnsafe++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 = STUnsafe.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
+ src/Data/Vault/ST/GHC_Strict.hs view
@@ -0,0 +1,64 @@+{-----------------------------------------------------------------------------+    vault+------------------------------------------------------------------------------}+module Data.Vault.ST.GHC_Strict where++import Prelude hiding (lookup)+import Data.Functor+import Control.Monad.ST+import Control.Monad.ST.Unsafe as STUnsafe++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.Strict 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 = STUnsafe.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
+ src/Data/Vault/ST/Lazy.hs view
@@ -0,0 +1,103 @@+{-----------------------------------------------------------------------------+    vault+------------------------------------------------------------------------------}+{-# LANGUAGE CPP #-}+module Data.Vault.ST.Lazy (+    -- * Synopsis+    -- | 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.++    +    -- * Vault+    Vault, Key,+    empty, newKey, lookup, insert, adjust, delete, union,+    +    -- * Locker+    Locker,+    lock, unlock,+    ) where++import Data.Monoid (Monoid(..))+import Prelude hiding (lookup)+import Control.Monad.ST++{-+    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 UseGHC+import qualified Data.Vault.ST.GHC_Lazy as ST+#else+import qualified Data.Vault.ST.Pure_Lazy as ST+#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+    mempty = empty+    mappend = union++-- | Keys for the vault.+--+-- > type Key :: * -> * -> *+type Key = ST.Key++-- | The empty vault.+empty :: Vault s+empty = ST.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++{-----------------------------------------------------------------------------+    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
+ src/Data/Vault/ST/Pure_Lazy.hs view
@@ -0,0 +1,58 @@+{-----------------------------------------------------------------------------+    vault+------------------------------------------------------------------------------}+module Data.Vault.ST.Pure_Lazy where++import Prelude hiding (lookup)+import Data.Functor+import Data.IORef+import Control.Applicative+import Control.Monad.ST++import System.IO.Unsafe (unsafePerformIO)+import Control.Monad.ST.Unsafe++import Data.Unique++import qualified Data.Map.Lazy 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 = Control.Monad.ST.Unsafe.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'
+ src/Data/Vault/ST/Pure_Strict.hs view
@@ -0,0 +1,60 @@+{-----------------------------------------------------------------------------+    vault+    +    FIXME: Make Implementation actually strict!+------------------------------------------------------------------------------}+module Data.Vault.ST.Pure_Strict where++import Prelude hiding (lookup)+import Data.Functor+import Data.IORef+import Control.Applicative+import Control.Monad.ST++import System.IO.Unsafe (unsafePerformIO)+import Control.Monad.ST.Unsafe++import Data.Unique++import qualified Data.Map.Strict 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 = x `seq` (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 = Control.Monad.ST.Unsafe.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'
+ src/Data/Vault/ST/Strict.hs view
@@ -0,0 +1,102 @@+{-----------------------------------------------------------------------------+    vault+------------------------------------------------------------------------------}+{-# LANGUAGE CPP #-}+module Data.Vault.ST.Strict (+    -- * Synopsis+    -- | 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.+    +    -- * Vault+    Vault, Key,+    empty, newKey, lookup, insert, adjust, delete, union,+    +    -- * Locker+    Locker,+    lock, unlock,+    ) where++import Data.Monoid (Monoid(..))+import Prelude hiding (lookup)+import Control.Monad.ST++{-+    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 UseGHC+import qualified Data.Vault.ST.GHC_Strict as ST+#else+import qualified Data.Vault.ST.Pure_Strict as ST+#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+    mempty = empty+    mappend = union++-- | Keys for the vault.+--+-- > type Key :: * -> * -> *+type Key = ST.Key++-- | The empty vault.+empty :: Vault s+empty = ST.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++{-----------------------------------------------------------------------------+    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
− src/Data/Vault/ST_GHC.hs 
@@ -1,71 +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-#if MIN_VERSION_base(4,4,0)-import Control.Monad.ST.Unsafe as STUnsafe-#else-import Control.Monad.ST as STUnsafe-#endif--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 = STUnsafe.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
− src/Data/Vault/ST_Pure.hs 
@@ -1,58 +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 Control.Monad.ST.Unsafe--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 = Control.Monad.ST.Unsafe.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'
+ src/Data/Vault/Strict.hs view
@@ -0,0 +1,82 @@+{-----------------------------------------------------------------------------+    vault+------------------------------------------------------------------------------}+module Data.Vault.Strict (+    -- * Synopsis+    -- | A persistent store for values of arbitrary types.+    --+    -- The 'Vault' type in this module is strict in both keys and values.+    +    -- * Vault+    Vault, Key,+    empty, newKey, lookup, insert, adjust, delete, union,+    +    -- * Locker+    Locker,+    lock, unlock,+    ) where++import Prelude hiding (lookup)+import Control.Monad.ST+import qualified Data.Vault.ST.Strict 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.+empty :: Vault+empty = ST.empty++-- | Create a new key for use with a vault.+newKey :: IO (Key a)+newKey = stToIO ST.newKey++-- | Lookup the value of a key in the vault.+lookup :: Key a -> Vault -> Maybe a+lookup = ST.lookup++-- | Insert a value for a given key. Overwrites any previous value.+insert :: Key a -> a -> Vault -> Vault+insert = ST.insert++-- | Adjust the value for a given key if it's present in the vault.+adjust :: (a -> a) -> Key a -> Vault -> Vault+adjust = ST.adjust++-- | Delete a key from the vault.+delete :: Key a -> Vault -> Vault+delete = ST.delete++-- | Merge two vaults (left-biased).+union :: Vault -> Vault -> Vault+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'.+lock :: Key a -> a -> Locker+lock = ST.lock++-- | Retrieve the value from the 'Locker'.+unlock :: Key a -> Locker -> Maybe a+unlock = ST.unlock
vault.cabal view
@@ -1,5 +1,5 @@ Name:               vault-Version:            0.2.0.4+Version:            0.3.0.0 Synopsis:           a persistent store for values of arbitrary types Description:   A /vault/ is a persistent store for values of arbitrary types.@@ -10,14 +10,19 @@   hence the name.   .   Also provided is a /locker/ type, representing a store for a single element.-  +  .+  Changelog:+  .+  * 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@@ -28,28 +33,29 @@     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) && flag(UseGHC)-        build-depends:  unordered-containers >= 0.2.1.0 && < 0.3,-                        hashable >= 1.1 && < 1.3 -        CPP-options:    -DUseGHC+    build-depends:      base == 4.6.*, containers == 0.5.*,+                        unordered-containers >= 0.2.3.0 && < 0.3,+                        hashable >= 1.1.2.5 && < 1.3      extensions:         CPP---    ghc-options:        -Wall+    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                         -    if impl(ghc) && flag(UseGHC)-        other-modules: Data.Vault.ST_GHC+    if impl(ghc)+        CPP-options:    -DUseGHC+        other-modules:+                        Data.Vault.ST.GHC_Lazy,+                        Data.Vault.ST.GHC_Strict     else-        other-modules: Data.Vault.ST_Pure+        other-modules:+                        Data.Vault.ST.Pure_Lazy,+                        Data.Vault.ST.Pure_Strict