vault 0.1.0.0 → 0.2.0.0
raw patch · 6 files changed
+310/−44 lines, 6 filesdep +hashabledep +unordered-containers
Dependencies added: hashable, unordered-containers
Files
- src/Data/Unique/Really.hs +74/−0
- src/Data/Vault.hs +32/−9
- src/Data/Vault/ST.hs +64/−30
- src/Data/Vault/ST_GHC.hs +67/−0
- src/Data/Vault/ST_Pure.hs +56/−0
- vault.cabal +17/−5
+ src/Data/Unique/Really.hs view
@@ -0,0 +1,74 @@+{-----------------------------------------------------------------------------+ vault+------------------------------------------------------------------------------}+{-# LANGUAGE CPP #-}+module Data.Unique.Really (+ -- | An abstract interface to a unique symbol generator.+ + Unique, newUnique, hashUnique,+ ) where++import Control.Applicative+import System.IO.Unsafe (unsafePerformIO)++#if __GLASGOW_HASKELL__++import Control.Exception (evaluate)+import qualified Data.Unique+import Data.Hashable+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++instance Hashable Unique where hash = hashUnique++#else++import Data.IORef++{-# 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)++-- | 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".+newUnique = Unique <$> newNumber+hashUnique (Unique s) = fromIntegral s+++#endif++-- | 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
src/Data/Vault.hs view
@@ -1,31 +1,38 @@ {------------------------------------------------------------------------------ Vault- - A typed, persistent store for values of arbitrary types- - This implementation uses unsafeCoerce for reasons of efficiency.- See http://apfelmus.nfshost.com/blog/2011/09/04-vault.html- for an implementation that doesn't need to bypass the type checker.+ 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 --- | A typed, persistent store for values of arbitrary types.+{-----------------------------------------------------------------------------+ 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. ----- > Key :: * -> *+-- > type Key :: * -> * type Key = ST.Key RealWorld -- | The empty vault.@@ -55,3 +62,19 @@ -- | 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 view
@@ -1,66 +1,100 @@ {------------------------------------------------------------------------------ Vault- - A typed, persistent store for values of arbitrary types- - This implementation uses unsafeCoerce for reasons of efficiency.- See http://apfelmus.nfshost.com/blog/2011/09/04-vault.html- for an implementation that doesn't need to bypass the type checker.+ 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 Data.Monoid hiding (Any)-import Data.Functor-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Unique import Control.Monad.ST -import GHC.Exts (Any) -- ghc specific tricks-import Unsafe.Coerce (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+#else+import qualified Data.Vault.ST_Pure as ST+#endif --- | A typed, persistent store for values of arbitrary types.+{-----------------------------------------------------------------------------+ Vault+------------------------------------------------------------------------------}+-- | A persistent store for values of arbitrary types. -- --- This variant has more complex types so that you can create keys in the 'ST' monad.--- See the module "Data.Vault" if you'd like to use a simpler version with the 'IO' monad.--- You can also use both variants simultaneously; they share a single representation.-newtype Vault s = Vault (Map Unique Any)--- | Keys for the vault.-newtype Key s a = Key Unique+-- 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 (Vault s) where+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 = Vault Map.empty+empty = ST.empty -- | Create a new key for use with a vault. newKey :: ST s (Key s a)-newKey = Key <$> unsafeIOToST newUnique+newKey = ST.newKey -- | Lookup the value of a key in the vault. lookup :: Key s a -> Vault s -> Maybe a-lookup (Key k) (Vault m) = unsafeCoerce <$> Map.lookup k m +lookup = ST.lookup -- | Insert a value for a given key. Overwrites any previous value. insert :: Key s a -> a -> Vault s -> Vault s-insert (Key k) x (Vault m) = Vault $ Map.insert k (unsafeCoerce x) m+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 f (Key k) (Vault m) = Vault $ Map.alter f' k m- where f' = unsafeCoerce . f . unsafeCoerce+adjust = ST.adjust -- | Delete a key from the vault. delete :: Key s a -> Vault s -> Vault s-delete (Key k) (Vault m) = Vault $ Map.delete k m+delete = ST.delete -- | Merge two vaults (left-biased). union :: Vault s -> Vault s -> Vault s-union (Vault m) (Vault m') = Vault $ Map.union m m'+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 view
@@ -0,0 +1,67 @@+{-----------------------------------------------------------------------------+ 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
+ src/Data/Vault/ST_Pure.hs view
@@ -0,0 +1,56 @@+{-----------------------------------------------------------------------------+ 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'
vault.cabal view
@@ -1,13 +1,15 @@ Name: vault-Version: 0.1.0.0-Synopsis: a typed, persistent store for values of arbitrary types+Version: 0.2.0.0+Synopsis: a persistent store for values of arbitrary types Description:- A /vault/ is a typed, persistent store for values of arbitrary types.+ A /vault/ is a persistent store for values of arbitrary types. It's like having first-class access to the storage space behind IORefs. . The data structure is analogous to a bank vault, where you can access different bank boxes with different keys; hence the name.+ .+ Also provided is a /locker/ type, representing a store for a single element. Category: Data License: BSD3@@ -29,6 +31,16 @@ Library hs-source-dirs: src build-depends: base == 4.*, containers == 0.4.*- ghc-options: -Wall- exposed-modules: Data.Vault, Data.Vault.ST+ if impl(ghc)+ build-depends: unordered-containers >= 0.2.1.0 && < 0.3,+ hashable == 1.1.* + ghc-options: -Wall+ extensions: CPP+ exposed-modules:+ Data.Vault,+ Data.Vault.ST,+ Data.Unique.Really+ other-modules:+ Data.Vault.ST_GHC,+ Data.Vault.ST_Pure